[Ada] Spurious error on user-defined literal and operator

Message ID 20211025150936.GA346849@adacore.com
State Committed
Commit 51e38f3b2873554f6481b0dc1e7cd4b8359a2b5f
Headers
Series [Ada] Spurious error on user-defined literal and operator |

Commit Message

Pierre-Marie de Rodat Oct. 25, 2021, 3:09 p.m. UTC
  This patch improves the handling of the Ada_2022 aspect involving
user-defined literals on integers, reals, and strings, when the literal
that must be converted to a type (for which the aspect is defined)
appears as an operand of a predefined operator. The target type may be
given by the type of the context, or by the type of another operand of
the operator.

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

gcc/ada/

	* sem_ch4.adb (Has_Possible_Literal_Aspects): If analysis of an
	operator node fails to find  a possible interpretation, and one
	of its operands is a literal or a named number, assign to the
	node the corresponding class type (Any_Integer, Any_String,
	etc).
	(Operator_Check): Call it before emitting a type error.
	* sem_res.adb (Has_Applicable_User_Defined_Literal): Given a
	literal and a type, determine whether the type has a
	user_defined aspect that can apply to the literal, and rewrite
	the node as call to the corresponding function. Most of the code
	was previously in procedure Resolve.
	(Try_User_Defined_Literal): Check operands of a predefined
	operator that fails to resolve, and apply
	Has_Applicable_User_Defined_Literal to literal operands if any,
	to find if a conversion will allow the operator to resolve
	properly.
	(Resolve): Call the above when a literal or an operator with a
	literal operand fails to resolve.
  

Patch

diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -281,6 +281,19 @@  package body Sem_Ch4 is
    --  type is not directly visible. The routine uses this type to emit a more
    --  informative message.
 
+   function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean;
+   --  Ada_2022: if an operand is a literal it may be subject to an
+   --  implicit conversion to a type for which a user-defined literal
+   --  function exists. During the first pass of type resolution we do
+   --  not know the context imposed on the literal, so we assume that
+   --  the literal type is a valid candidate and rely on the second pass
+   --  of resolution to find the type with the proper aspect. We only
+   --  add this interpretation if no other one was found, which may be
+   --  too restrictive but seems sufficient to handle most proper uses
+   --  of the new aspect. It is unclear whether a full implementation of
+   --  these aspects can be achieved without larger modifications to the
+   --  two-pass resolution algorithm.
+
    procedure Remove_Abstract_Operations (N : Node_Id);
    --  Ada 2005: implementation of AI-310. An abstract non-dispatching
    --  operation is not a candidate interpretation.
@@ -7541,6 +7554,9 @@  package body Sem_Ch4 is
             then
                return;
 
+            elsif Has_Possible_Literal_Aspects (N) then
+               return;
+
             --  If we have a logical operator, one of whose operands is
             --  Boolean, then we know that the other operand cannot resolve to
             --  Boolean (since we got no interpretations), but in that case we
@@ -7857,6 +7873,69 @@  package body Sem_Ch4 is
       end if;
    end Operator_Check;
 
+   ----------------------------------
+   -- Has_Possible_Literal_Aspects --
+   ----------------------------------
+
+   function Has_Possible_Literal_Aspects (N : Node_Id) return Boolean is
+      R : constant Node_Id := Right_Opnd (N);
+      L : Node_Id := Empty;
+
+      procedure Check_Literal_Opnd (Opnd : Node_Id);
+      --  If an operand is a literal to which an aspect may apply,
+      --  add the corresponding type to operator node.
+
+      ------------------------
+      -- Check_Literal_Opnd --
+      ------------------------
+
+      procedure Check_Literal_Opnd (Opnd : Node_Id) is
+      begin
+         if Nkind (Opnd) in N_Numeric_Or_String_Literal
+           or else (Is_Entity_Name (Opnd)
+             and then Present (Entity (Opnd))
+             and then Is_Named_Number (Entity (Opnd)))
+         then
+            Add_One_Interp (N, Etype (Opnd), Etype (Opnd));
+         end if;
+      end Check_Literal_Opnd;
+
+   --  Start of processing for Has_Possible_Literal_Aspects
+
+   begin
+      if Ada_Version < Ada_2022 then
+         return False;
+      end if;
+
+      if Nkind (N) in N_Binary_Op then
+         L := Left_Opnd (N);
+      else
+         L := Empty;
+      end if;
+      Check_Literal_Opnd (R);
+
+      --  Check left operand only if right one did not provide a
+      --  possible interpretation. Note that literal types are not
+      --  overloadable, in the sense that there is no overloadable
+      --  entity name whose several interpretations can be used to
+      --  indicate possible resulting types, so there is no way to
+      --  provide more than one interpretation to the operator node.
+      --  The choice of one operand over the other is arbitrary at
+      --  this point, and may lead to spurious resolution when both
+      --  operands are literals of different kinds, but the second
+      --  pass of resolution will examine anew both operands to
+      --  determine whether a user-defined literal may apply to
+      --  either or both.
+
+      if Present (L)
+        and then Etype (N) = Any_Type
+      then
+         Check_Literal_Opnd (L);
+      end if;
+
+      return Etype (N) /= Any_Type;
+   end Has_Possible_Literal_Aspects;
+
    --------------------------------
    -- Remove_Abstract_Operations --
    --------------------------------


diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -103,6 +103,14 @@  package body Sem_Res is
 
    --  Note that Resolve_Attribute is separated off in Sem_Attr
 
+   function Has_Applicable_User_Defined_Literal
+     (N   : Node_Id;
+      Typ : Entity_Id) return Boolean;
+   --  If N is a literal or a named number, check whether Typ
+   --  has a user-defined literal aspect that can apply to N.
+   --  If present, replace N with a call to the corresponding
+   --  function and return True.
+
    procedure Check_Discriminant_Use (N : Node_Id);
    --  Enforce the restrictions on the use of discriminants when constraining
    --  a component of a discriminated type (record or concurrent type).
@@ -286,6 +294,15 @@  package body Sem_Res is
    --  is only one requires a search over all visible entities, and happens
    --  only in very pathological cases (see 6115-006).
 
+   function Try_User_Defined_Literal
+     (N   : Node_Id;
+      Typ : Entity_Id) return Boolean;
+   --  If an operator node has a literal operand, check whether the type
+   --  of the context, or the type of the other operand has a user-defined
+   --  literal aspect that can be applied to the literal to resolve the node.
+   --  If such aspect exists, replace literal with a call to the
+   --  corresponing function and return True, return false otherwise.
+
    -------------------------
    -- Ambiguous_Character --
    -------------------------
@@ -409,6 +426,165 @@  package body Sem_Res is
       end if;
    end Analyze_And_Resolve;
 
+   -------------------------------------
+   -- Has_Applicable_User_Defined_Literal --
+   -------------------------------------
+
+   function Has_Applicable_User_Defined_Literal
+     (N   : Node_Id;
+      Typ : Entity_Id) return Boolean
+   is
+      Loc  : constant Source_Ptr := Sloc (N);
+      Literal_Aspect_Map :
+        constant array (N_Numeric_Or_String_Literal) of Aspect_Id :=
+          (N_Integer_Literal => Aspect_Integer_Literal,
+           N_Real_Literal    => Aspect_Real_Literal,
+           N_String_Literal  => Aspect_String_Literal);
+
+      Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id :=
+        (E_Named_Integer => Aspect_Integer_Literal,
+         E_Named_Real    => Aspect_Real_Literal);
+
+      Lit_Aspect : Aspect_Id;
+
+      Callee : Entity_Id;
+      Name   : Node_Id;
+      Param1 : Node_Id;
+      Param2 : Node_Id;
+      Params : List_Id;
+      Call   : Node_Id;
+      Expr   : Node_Id;
+
+   begin
+      if (Nkind (N) in N_Numeric_Or_String_Literal
+           and then Present
+            (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
+        or else
+          (Nkind (N) = N_Identifier
+            and then Is_Named_Number (Entity (N))
+            and then
+              Present
+                (Find_Aspect
+                  (Typ, Named_Number_Aspect_Map (Ekind (Entity (N))))))
+      then
+         Lit_Aspect :=
+           (if Nkind (N) = N_Identifier
+            then Named_Number_Aspect_Map (Ekind (Entity (N)))
+            else Literal_Aspect_Map (Nkind (N)));
+         Callee :=
+           Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
+         Name := Make_Identifier (Loc, Chars (Callee));
+
+         if Is_Derived_Type (Typ)
+           and then Is_Tagged_Type (Typ)
+           and then Base_Type (Etype (Callee)) /= Base_Type (Typ)
+         then
+            Callee :=
+              Corresponding_Primitive_Op
+                (Ancestor_Op     => Callee,
+                 Descendant_Type => Base_Type (Typ));
+         end if;
+
+         --  Handle an identifier that denotes a named number.
+
+         if Nkind (N) = N_Identifier then
+            Expr := Expression (Declaration_Node (Entity (N)));
+
+            if Ekind (Entity (N)) = E_Named_Integer then
+               UI_Image (Expr_Value (Expr), Decimal);
+               Start_String;
+               Store_String_Chars
+                 (UI_Image_Buffer (1 .. UI_Image_Length));
+               Param1 := Make_String_Literal (Loc, End_String);
+               Params := New_List (Param1);
+
+            else
+               UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal);
+               Start_String;
+
+               if UR_Is_Negative (Expr_Value_R (Expr)) then
+                  Store_String_Chars ("-");
+               end if;
+
+               Store_String_Chars
+                 (UI_Image_Buffer (1 .. UI_Image_Length));
+               Param1 := Make_String_Literal (Loc, End_String);
+
+               --  Note: Set_Etype is called below on Param1
+
+               UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal);
+               Start_String;
+               Store_String_Chars
+                 (UI_Image_Buffer (1 .. UI_Image_Length));
+               Param2 := Make_String_Literal (Loc, End_String);
+               Set_Etype (Param2, Standard_String);
+
+               Params := New_List (Param1, Param2);
+
+               if Present (Related_Expression (Callee)) then
+                  Callee := Related_Expression (Callee);
+               else
+                  Error_Msg_NE
+                    ("cannot resolve & for a named real", N, Callee);
+                  return False;
+               end if;
+            end if;
+
+         elsif Nkind (N) = N_String_Literal then
+            Param1 := Make_String_Literal (Loc, Strval (N));
+            Params := New_List (Param1);
+
+         else
+            Param1 :=
+              Make_String_Literal
+                (Loc, String_From_Numeric_Literal (N));
+            Params := New_List (Param1);
+         end if;
+
+         Call :=
+           Make_Function_Call
+             (Sloc                   => Loc,
+              Name                   => Name,
+              Parameter_Associations => Params);
+
+         Set_Entity (Name, Callee);
+         Set_Is_Overloaded (Name, False);
+
+         if Lit_Aspect = Aspect_String_Literal then
+            Set_Etype (Param1, Standard_Wide_Wide_String);
+         else
+            Set_Etype (Param1, Standard_String);
+         end if;
+
+         Set_Etype (Call, Etype (Callee));
+
+         if Base_Type (Etype (Call)) /= Base_Type (Typ) then
+            --  Conversion may be needed in case of an inherited
+            --  aspect of a derived type. For a null extension, we
+            --  use a null extension aggregate instead because the
+            --  downward type conversion would be illegal.
+
+            if Is_Null_Extension_Of
+                 (Descendant => Typ,
+                  Ancestor   => Etype (Call))
+            then
+               Call := Make_Extension_Aggregate (Loc,
+                         Ancestor_Part       => Call,
+                         Null_Record_Present => True);
+            else
+               Call := Convert_To (Typ, Call);
+            end if;
+         end if;
+
+         Rewrite (N, Call);
+
+         Analyze_And_Resolve (N, Typ);
+         return True;
+      else
+         return False;
+      end if;
+   end Has_Applicable_User_Defined_Literal;
+
    ----------------------------
    -- Check_Discriminant_Use --
    ----------------------------
@@ -2156,16 +2332,6 @@  package body Sem_Res is
          return;
       end Resolution_Failed;
 
-      Literal_Aspect_Map :
-        constant array (N_Numeric_Or_String_Literal) of Aspect_Id :=
-          (N_Integer_Literal => Aspect_Integer_Literal,
-           N_Real_Literal    => Aspect_Real_Literal,
-           N_String_Literal  => Aspect_String_Literal);
-
-      Named_Number_Aspect_Map : constant array (Named_Kind) of Aspect_Id :=
-        (E_Named_Integer => Aspect_Integer_Literal,
-         E_Named_Real    => Aspect_Real_Literal);
-
    --  Start of processing for Resolve
 
    begin
@@ -2884,143 +3050,14 @@  package body Sem_Res is
                end;
             end if;
 
-            --  Rewrite Literal as a call if the corresponding literal aspect
-            --  is set.
+            --  If node is a literal and context type has a user-defined
+            --  literal aspect, rewrite node as a call to the corresponding
+            --  function, which plays the role of an implicit conversion.
 
-            if (Nkind (N) in N_Numeric_Or_String_Literal
-                 and then
-                   Present
-                     (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
-              or else
-                (Nkind (N) = N_Identifier
-                  and then Is_Named_Number (Entity (N))
-                  and then
-                    Present
-                      (Find_Aspect
-                        (Typ, Named_Number_Aspect_Map (Ekind (Entity (N))))))
+            if Nkind (N) in
+                N_Numeric_Or_String_Literal | N_Identifier
+              and then Has_Applicable_User_Defined_Literal (N, Typ)
             then
-               declare
-                  Lit_Aspect : constant Aspect_Id :=
-                    (if Nkind (N) = N_Identifier
-                     then Named_Number_Aspect_Map (Ekind (Entity (N)))
-                     else Literal_Aspect_Map (Nkind (N)));
-
-                  Loc  : constant Source_Ptr := Sloc (N);
-
-                  Callee : Entity_Id :=
-                    Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
-
-                  Name : constant Node_Id :=
-                    Make_Identifier (Loc, Chars (Callee));
-
-                  Param1 : Node_Id;
-                  Param2 : Node_Id;
-                  Params : List_Id;
-                  Call   : Node_Id;
-                  Expr   : Node_Id;
-
-               begin
-                  if Is_Derived_Type (Typ)
-                    and then Is_Tagged_Type (Typ)
-                    and then Base_Type (Etype (Callee)) /= Base_Type (Typ)
-                  then
-                     Callee :=
-                       Corresponding_Primitive_Op
-                         (Ancestor_Op     => Callee,
-                          Descendant_Type => Base_Type (Typ));
-                  end if;
-
-                  if Nkind (N) = N_Identifier then
-                     Expr := Expression (Declaration_Node (Entity (N)));
-
-                     if Ekind (Entity (N)) = E_Named_Integer then
-                        UI_Image (Expr_Value (Expr), Decimal);
-                        Start_String;
-                        Store_String_Chars
-                          (UI_Image_Buffer (1 .. UI_Image_Length));
-                        Param1 := Make_String_Literal (Loc, End_String);
-                        Params := New_List (Param1);
-
-                     else
-                        UI_Image (Norm_Num (Expr_Value_R (Expr)), Decimal);
-                        Start_String;
-
-                        if UR_Is_Negative (Expr_Value_R (Expr)) then
-                           Store_String_Chars ("-");
-                        end if;
-
-                        Store_String_Chars
-                          (UI_Image_Buffer (1 .. UI_Image_Length));
-                        Param1 := Make_String_Literal (Loc, End_String);
-
-                        --  Note: Set_Etype is called below on Param1
-
-                        UI_Image (Norm_Den (Expr_Value_R (Expr)), Decimal);
-                        Start_String;
-                        Store_String_Chars
-                          (UI_Image_Buffer (1 .. UI_Image_Length));
-                        Param2 := Make_String_Literal (Loc, End_String);
-                        Set_Etype (Param2, Standard_String);
-
-                        Params := New_List (Param1, Param2);
-
-                        if Present (Related_Expression (Callee)) then
-                           Callee := Related_Expression (Callee);
-                        else
-                           Error_Msg_NE
-                             ("cannot resolve & for a named real", N, Callee);
-                           return;
-                        end if;
-                     end if;
-
-                  elsif Nkind (N) = N_String_Literal then
-                     Param1 := Make_String_Literal (Loc, Strval (N));
-                     Params := New_List (Param1);
-                  else
-                     Param1 :=
-                       Make_String_Literal
-                         (Loc, String_From_Numeric_Literal (N));
-                     Params := New_List (Param1);
-                  end if;
-
-                  Call :=
-                    Make_Function_Call
-                      (Sloc                   => Loc,
-                       Name                   => Name,
-                       Parameter_Associations => Params);
-
-                  Set_Entity (Name, Callee);
-                  Set_Is_Overloaded (Name, False);
-
-                  if Lit_Aspect = Aspect_String_Literal then
-                     Set_Etype (Param1, Standard_Wide_Wide_String);
-                  else
-                     Set_Etype (Param1, Standard_String);
-                  end if;
-
-                  Set_Etype (Call, Etype (Callee));
-
-                  if Base_Type (Etype (Call)) /= Base_Type (Typ) then
-                     --  Conversion may be needed in case of an inherited
-                     --  aspect of a derived type. For a null extension, we
-                     --  use a null extension aggregate instead because the
-                     --  downward type conversion would be illegal.
-
-                     if Is_Null_Extension_Of
-                          (Descendant => Typ,
-                           Ancestor   => Etype (Call))
-                     then
-                        Call := Make_Extension_Aggregate (Loc,
-                                  Ancestor_Part       => Call,
-                                  Null_Record_Present => True);
-                     else
-                        Call := Convert_To (Typ, Call);
-                     end if;
-                  end if;
-
-                  Rewrite (N, Call);
-               end;
-
                Analyze_And_Resolve (N, Typ);
                return;
             end if;
@@ -3116,6 +3153,14 @@  package body Sem_Res is
                     ("missing ALL or SOME in quantified expression",
                      Defining_Identifier (First (Component_Associations (N))));
 
+               --  For an operator with no interpretation, check whether
+               --  one of its operands may be a user-defined literal.
+
+               elsif Nkind (N) in N_Op
+                 and then Try_User_Defined_Literal (N, Typ)
+               then
+                  return;
+
                else
                   Wrong_Type (N, Typ);
                end if;
@@ -12847,6 +12892,76 @@  package body Sem_Res is
       end if;
    end Simplify_Type_Conversion;
 
+   ------------------------------
+   -- Try_User_Defined_Literal --
+   ------------------------------
+
+   function Try_User_Defined_Literal
+     (N   : Node_Id;
+      Typ : Entity_Id) return Boolean
+   is
+   begin
+      if Nkind (N) in N_Op_Add | N_Op_Divide | N_Op_Mod | N_Op_Multiply
+        | N_Op_Rem | N_Op_Subtract
+      then
+
+         --  Both operands must have the same type as the context.
+         --  (ignoring for now fixed-point and exponentiation ops).
+
+         if Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ) then
+            Resolve (Left_Opnd (N), Typ);
+            Analyze_And_Resolve (N, Typ);
+            return True;
+         end if;
+
+         if
+           Has_Applicable_User_Defined_Literal (Left_Opnd (N), Typ)
+         then
+            Resolve (Right_Opnd (N), Typ);
+            Analyze_And_Resolve (N, Typ);
+            return True;
+
+         else
+            return False;
+         end if;
+
+      elsif Nkind (N) in N_Binary_Op then
+         --  For other operators the context does not impose a type on
+         --  the operands, but their types must match.
+
+         if (Nkind (Left_Opnd (N))
+           not in N_Integer_Literal | N_String_Literal | N_Real_Literal)
+         and then
+           Has_Applicable_User_Defined_Literal
+             (Right_Opnd (N), Etype (Left_Opnd (N)))
+         then
+            Analyze_And_Resolve (N, Typ);
+            return True;
+
+         elsif (Nkind (Right_Opnd (N))
+           not in N_Integer_Literal | N_String_Literal | N_Real_Literal)
+         and then
+           Has_Applicable_User_Defined_Literal
+             (Left_Opnd (N), Etype (Right_Opnd (N)))
+         then
+            Analyze_And_Resolve (N, Typ);
+            return True;
+         else
+            return False;
+         end if;
+
+      elsif Nkind (N) in N_Unary_Op
+        and then
+          Has_Applicable_User_Defined_Literal (Right_Opnd (N), Typ)
+      then
+         Analyze_And_Resolve (N, Typ);
+         return True;
+
+      else   --  Other operators
+         return False;
+      end if;
+   end Try_User_Defined_Literal;
+
    -----------------------------
    -- Unique_Fixed_Point_Type --
    -----------------------------