sem_ch12.adb (Qualify_Universal_Operands): New routine.

2016-04-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch12.adb (Qualify_Universal_Operands): New routine.
	(Save_References_In_Operator): Add explicit qualifications in
	the generic template for all operands of universal type.
	* sem_type.adb (Disambiguate): Update the call to Matches.
	(Matches): Reimplemented.
	* sem_util.ads, sem_util.adb (Yields_Universal_Type): New routine.

From-SVN: r235254

gcc/ada/ChangeLog

+2016-04-20  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* sem_ch12.adb (Qualify_Universal_Operands): New routine.
+	(Save_References_In_Operator): Add explicit qualifications in
+	the generic template for all operands of universal type.
+	* sem_type.adb (Disambiguate): Update the call to Matches.
+	(Matches): Reimplemented.
+	* sem_util.ads, sem_util.adb (Yields_Universal_Type): New routine.
+
 2016-04-20  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch13.adb (Rep_Item_Too_Late): Better error message for

gcc/ada/sem_ch12.adb

@@ -13848,6 +13848,19 @@ package body Sem_Ch12 is
       --  global because it is used to denote a specific compilation unit at
       --  the time the instantiations will be analyzed.
 
+      procedure Qualify_Universal_Operands
+        (Op        : Node_Id;
+         Func_Call : Node_Id);
+      --  Op denotes a binary or unary operator in generic template Templ. Node
+      --  Func_Call is the function call alternative of the operator within the
+      --  the analyzed copy of the template. Change each operand which yields a
+      --  universal type by wrapping it into a qualified expression
+      --
+      --    Actual_Typ'(Operand)
+      --
+      --  where Actual_Typ is the type of corresponding actual parameter of
+      --  Operand in Func_Call.
+
       procedure Reset_Entity (N : Node_Id);
       --  Save semantic information on global entity so that it is not resolved
       --  again at instantiation time.
@@ -13938,6 +13951,109 @@ package body Sem_Ch12 is
          end if;
       end Is_Global;
 
+      --------------------------------
+      -- Qualify_Universal_Operands --
+      --------------------------------
+
+      procedure Qualify_Universal_Operands
+        (Op        : Node_Id;
+         Func_Call : Node_Id)
+      is
+         procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id);
+         --  Rewrite operand Opnd as a qualified expression of the form
+         --
+         --    Actual_Typ'(Opnd)
+         --
+         --  where Actual is the corresponding actual parameter of Opnd in
+         --  function call Func_Call.
+
+         function Qualify_Type
+           (Loc : Source_Ptr;
+            Typ : Entity_Id) return Node_Id;
+         --  Qualify type Typ by creating a selected component of the form
+         --
+         --    Scope_Of_Typ.Typ
+
+         ---------------------
+         -- Qualify_Operand --
+         ---------------------
+
+         procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is
+            Loc  : constant Source_Ptr := Sloc (Opnd);
+            Typ  : constant Entity_Id  := Etype (Actual);
+            Mark : Node_Id;
+
+         begin
+            --  Qualify the operand when it is of a universal type. Note that
+            --  the template is unanalyzed and it is not possible to directly
+            --  query the type. This transformation is not done when the type
+            --  of the actual is internally generated because the type will be
+            --  regenerated in the instance.
+
+            if Yields_Universal_Type (Opnd)
+              and then Comes_From_Source (Typ)
+              and then not Is_Hidden (Typ)
+            then
+               --  The type of the actual may be a global reference. Save this
+               --  information by creating a reference to it.
+
+               if Is_Global (Typ) then
+                  Mark := New_Occurrence_Of (Typ, Loc);
+
+               --  Otherwise rely on resolution to find the proper type within
+               --  the instance.
+
+               else
+                  Mark := Qualify_Type (Loc, Typ);
+               end if;
+
+               Rewrite (Opnd,
+                 Make_Qualified_Expression (Loc,
+                   Subtype_Mark => Mark,
+                   Expression   => Relocate_Node (Opnd)));
+            end if;
+         end Qualify_Operand;
+
+         ------------------
+         -- Qualify_Type --
+         ------------------
+
+         function Qualify_Type
+           (Loc : Source_Ptr;
+            Typ : Entity_Id) return Node_Id
+         is
+            Scop   : constant Entity_Id := Scope (Typ);
+            Result : Node_Id;
+
+         begin
+            Result := Make_Identifier (Loc, Chars (Typ));
+
+            if Present (Scop) and then Scop /= Standard_Standard then
+               Result :=
+                 Make_Selected_Component (Loc,
+                   Prefix        => Make_Identifier (Loc, Chars (Scop)),
+                   Selector_Name => Result);
+            end if;
+
+            return Result;
+         end Qualify_Type;
+
+         --  Local variables
+
+         Actuals : constant List_Id := Parameter_Associations (Func_Call);
+
+      --  Start of processing for Qualify_Universal_Operands
+
+      begin
+         if Nkind (Op) in N_Binary_Op then
+            Qualify_Operand (Left_Opnd  (Op), First (Actuals));
+            Qualify_Operand (Right_Opnd (Op), Next (First (Actuals)));
+
+         elsif Nkind (Op) in N_Unary_Op then
+            Qualify_Operand (Right_Opnd (Op), First (Actuals));
+         end if;
+      end Qualify_Universal_Operands;
+
       ------------------
       -- Reset_Entity --
       ------------------
@@ -14716,7 +14832,8 @@ package body Sem_Ch12 is
                Reset_Entity (N);
 
             --  The analysis of the generic copy transformed the operator into
-            --  some other construct. Propagate the changes to the template.
+            --  some other construct. Propagate the changes to the template if
+            --  applicable.
 
             else
                N2 := Get_Associated_Node (N);
@@ -14724,6 +14841,14 @@ package body Sem_Ch12 is
                --  The operator resoved to a function call
 
                if Nkind (N2) = N_Function_Call then
+
+                  --  Add explicit qualifications in the generic template for
+                  --  all operands of universal type. This aids resolution by
+                  --  preserving the actual type of a literal or an attribute
+                  --  that yields a universal result.
+
+                  Qualify_Universal_Operands (N, N2);
+
                   E := Entity (Name (N2));
 
                   if Present (E) and then Is_Global (E) then

gcc/ada/sem_type.adb

@@ -1316,13 +1316,13 @@ package body Sem_Type is
       --  the generic. Within the instance the actual is represented by a
       --  constructed subprogram renaming.
 
-      function Matches (Actual, Formal : Node_Id) return Boolean;
-      --  Look for exact type match in an instance, to remove spurious
-      --  ambiguities when two formal types have the same actual.
+      function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean;
+      --  Determine whether function Func_Id is an exact match for binary or
+      --  unary operator Op.
 
       function Operand_Type return Entity_Id;
-      --  Determine type of operand for an equality operation, to apply
-      --  Ada 2005 rules to equality on anonymous access types.
+      --  Determine type of operand for an equality operation, to apply Ada
+      --  2005 rules to equality on anonymous access types.
 
       function Standard_Operator return Boolean;
       --  Check whether subprogram is predefined operator declared in Standard.
@@ -1412,14 +1412,82 @@ package body Sem_Type is
       -- Matches --
       -------------
 
-      function Matches (Actual, Formal : Node_Id) return Boolean is
-         T1 : constant Entity_Id := Etype (Actual);
-         T2 : constant Entity_Id := Etype (Formal);
+      function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is
+         function Matching_Types
+           (Opnd_Typ   : Entity_Id;
+            Formal_Typ : Entity_Id) return Boolean;
+         --  Determine whether operand type Opnd_Typ and formal parameter type
+         --  Formal_Typ are either the same or compatible.
+
+         --------------------
+         -- Matching_Types --
+         --------------------
+
+         function Matching_Types
+           (Opnd_Typ   : Entity_Id;
+            Formal_Typ : Entity_Id) return Boolean
+         is
          begin
-         return T1 = T2
-           or else
-             (Is_Numeric_Type (T2)
-               and then (T1 = Universal_Real or else T1 = Universal_Integer));
+            --  A direct match
+
+            if Opnd_Typ = Formal_Typ then
+               return True;
+
+            --  Any integer type matches universal integer
+
+            elsif Opnd_Typ = Universal_Integer
+              and then Is_Integer_Type (Formal_Typ)
+            then
+               return True;
+
+            --  Any floating point type matches universal real
+
+            elsif Opnd_Typ = Universal_Real
+              and then Is_Floating_Point_Type (Formal_Typ)
+            then
+               return True;
+
+            --  The type of the formal parameter maps a generic actual type to
+            --  a generic formal type. If the operand type is the type being
+            --  mapped in an instance, then this is a match.
+
+            elsif Is_Generic_Actual_Type (Formal_Typ)
+              and then Etype (Formal_Typ) = Opnd_Typ
+            then
+               return True;
+
+            --  ??? There are possibly other cases to consider
+
+            else
+               return False;
+            end if;
+         end Matching_Types;
+
+         --  Local variables
+
+         F1      : constant Entity_Id := First_Formal (Func_Id);
+         F1_Typ  : constant Entity_Id := Etype (F1);
+         F2      : constant Entity_Id := Next_Formal (F1);
+         F2_Typ  : constant Entity_Id := Etype (F2);
+         Lop_Typ : constant Entity_Id := Etype (Left_Opnd  (Op));
+         Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op));
+
+      --  Start of processing for Matches
+
+      begin
+         if Lop_Typ = F1_Typ then
+            return Matching_Types (Rop_Typ, F2_Typ);
+
+         elsif Rop_Typ = F2_Typ then
+            return Matching_Types (Lop_Typ, F1_Typ);
+
+         --  Otherwise this is not a good match bechause each operand-formal
+         --  pair is compatible only on base type basis which is not specific
+         --  enough.
+
+         else
+            return False;
+         end if;
       end Matches;
 
       ------------------
@@ -1697,6 +1765,7 @@ package body Sem_Type is
 
       It1  := It;
       Nam1 := It.Nam;
+
       while I /= I2 loop
          Get_Next_Interp (I, It);
       end loop;
@@ -1967,10 +2036,7 @@ package body Sem_Type is
                end;
 
             elsif Nkind (N) in N_Binary_Op then
-               if Matches (Left_Opnd (N), First_Formal (Nam1))
-                 and then
-                   Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
-               then
+               if Matches (N, Nam1) then
                   return It1;
                else
                   return It2;

gcc/ada/sem_util.adb

@@ -20957,4 +20957,63 @@ package body Sem_Util is
       end if;
    end Yields_Synchronized_Object;
 
+   ---------------------------
+   -- Yields_Universal_Type --
+   ---------------------------
+
+   function Yields_Universal_Type (N : Node_Id) return Boolean is
+      Nam : Name_Id;
+
+   begin
+      --  Integer and real literals are of a universal type
+
+      if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
+         return True;
+
+      --  The values of certain attributes are of a universal type
+
+      elsif Nkind (N) = N_Attribute_Reference then
+         Nam := Attribute_Name (N);
+
+         return
+           Nam = Name_Aft
+             or else Nam = Name_Alignment
+             or else Nam = Name_Component_Size
+             or else Nam = Name_Count
+             or else Nam = Name_Delta
+             or else Nam = Name_Digits
+             or else Nam = Name_Exponent
+             or else Nam = Name_First_Bit
+             or else Nam = Name_Fore
+             or else Nam = Name_Last_Bit
+             or else Nam = Name_Length
+             or else Nam = Name_Machine_Emax
+             or else Nam = Name_Machine_Emin
+             or else Nam = Name_Machine_Mantissa
+             or else Nam = Name_Machine_Radix
+             or else Nam = Name_Max_Alignment_For_Allocation
+             or else Nam = Name_Max_Size_In_Storage_Elements
+             or else Nam = Name_Model_Emin
+             or else Nam = Name_Model_Epsilon
+             or else Nam = Name_Model_Mantissa
+             or else Nam = Name_Model_Small
+             or else Nam = Name_Modulus
+             or else Nam = Name_Pos
+             or else Nam = Name_Position
+             or else Nam = Name_Safe_First
+             or else Nam = Name_Safe_Last
+             or else Nam = Name_Scale
+             or else Nam = Name_Size
+             or else Nam = Name_Small
+             or else Nam = Name_Wide_Wide_Width
+             or else Nam = Name_Wide_Width
+             or else Nam = Name_Width;
+
+      --  ??? There are possibly other cases to consider
+
+      else
+         return False;
+      end if;
+   end Yields_Universal_Type;
+
 end Sem_Util;

gcc/ada/sem_util.ads

@@ -2295,4 +2295,7 @@ package Sem_Util is
    --    * A synchronized interface type
    --    * A task type
 
+   function Yields_Universal_Type (N : Node_Id) return Boolean;
+   --  Determine whether unanalyzed node N yields a universal type
+
 end Sem_Util;