diff mbox

[Ada] Constraint_Error on spurious ambiguity in instance

Message ID 20160420102003.GA74859@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet April 20, 2016, 10:20 a.m. UTC
This match modifies the processing of generics to aid overload resolution of
binary and unary operators in instances. This is achieved by installing type
conversions in the form of qualified expressions for each operand that yields
a universal type.

------------
-- Source --
------------

--  px.ads

package PX is
   pragma Pure;
   Min_Integer : constant := -2**31;
   Max_Integer : constant := 2**31 - 1;

   subtype Integer_T is Integer   range Min_Integer .. Max_Integer;
   subtype Natural_T is Integer_T range 0 .. Integer_T'last;
   subtype String_T  is String;
end PX;

--  pg.ads

with PX;

generic
   type Element_T is (<>);
   type Index_T is (<>);
   type String_T is array (Index_T range <>) of Element_T;
   Blank_Element : in Element_T;

package PG is
   function Left_Piece
     (Str           : in String_T;
      Size          : in PX.Natural_T;
      Pad_Character : in Element_T := Blank_Element) return String_T;
end PG;

--  pg.adb

package body PG is
   subtype Null_String_T is String_T (Index_T'Last .. Index_T'First);
   Null_String : constant Null_String_T := (others => Element_T'First);

   function "+" (L : in PX.Integer_T; R : in Index_T     ) return Index_T;
   function "+" (L : in Index_T;      R : in PX.Integer_T) return Index_T; 
   function "-" (L : in Index_T;      R : in PX.Integer_T) return Index_T;

   function "+" (L : in PX.Integer_T; R : in Index_T) return Index_T is
   begin
      return Index_T'Val (L + Index_T'Pos(R));
   end "+";

   function "+" (L : in Index_T; R : in PX.Integer_T) return Index_T is
   begin
      return Index_T'Val (Index_T'Pos (L) + R);
   end "+";

   function "-" (L : in Index_T; R : in PX.Integer_T) return Index_T is
   begin
      return Index_T'Val (Index_T'Pos (L) - R);
   end "-";

   function Left_Piece
     (Str           : in String_T;
      Size          : in PX.Natural_T;
      Pad_Character : in Element_T := Blank_Element) return String_T
   is
   begin
      if Size > 0 then
         declare
            Result : String_T (Index_T'First .. Index_T'First + Size - 1);

         begin
            if Size < Str'Length then
               Result := Str (Str'First .. Str'First + Size - 1);

            elsif Size = Str'Length then
               Result := Str;

            else
               if Str'Length > 0 then
                  Result (Result'First .. Result'First + Str'Length - 1) :=
                    Str;
               end if;

               Result (Result'First + Str'Length .. Result'Last) :=
                 (others => Pad_Character);
            end if;

            return Result;
         end;

      else
         return Null_String;
      end if;
   end Left_Piece;
end PG;

--  nullstr.adb

with Ada.Text_IO; use Ada.Text_IO;
with PG;

procedure Nullstr is
   package PPG is new PG
     (Element_T     => Character,
      Index_T       => Positive,
      String_T      => String,
      Blank_Element => '$');

begin
   Put_Line (PPG.Left_Piece ("abcdef", 6));
   Put_Line (PPG.Left_Piece ("abcde", 6));
   Put_Line (PPG.Left_Piece ("", 6));
end Nullstr;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q nullstr.adb
$ ./nullstr
abcdef
abcde$
$$$$$$

Tested on x86_64-pc-linux-gnu, committed on trunk

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.
diff mbox

Patch

Index: sem_type.adb
===================================================================
--- sem_type.adb	(revision 235199)
+++ sem_type.adb	(working copy)
@@ -1316,13 +1316,13 @@ 
       --  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 @@ 
       -- 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
+            --  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
-         return T1 = T2
-           or else
-             (Is_Numeric_Type (T2)
-               and then (T1 = Universal_Real or else T1 = Universal_Integer));
+         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 @@ 
 
       It1  := It;
       Nam1 := It.Nam;
+
       while I /= I2 loop
          Get_Next_Interp (I, It);
       end loop;
@@ -1967,10 +2036,7 @@ 
                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;
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb	(revision 235243)
+++ sem_ch12.adb	(working copy)
@@ -13848,6 +13848,19 @@ 
       --  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 @@ 
          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 @@ 
                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,13 +14841,21 @@ 
                --  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
                      Set_Etype (N, Etype (N2));
                   else
                      Set_Associated_Node (N, Empty);
-                     Set_Etype (N, Empty);
+                     Set_Etype           (N, Empty);
                   end if;
 
                --  The operator was folded into a literal
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 235251)
+++ sem_util.adb	(working copy)
@@ -20957,4 +20957,63 @@ 
       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;
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 235249)
+++ sem_util.ads	(working copy)
@@ -2295,4 +2295,7 @@ 
    --    * 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;