[Ada] Fix issues with compiling ACATS test for user-defined literals

The draft ACATS test (which we developed) for the Ada 2022 feature of
user-defined literals has compile-time problems that are fixed with this
set of changes.  Two of these involve the resolution of named numbers
in the context where an implicit literal conversion can occur, and for
equality when a literal or named number is an operand. Furthermore,
the compiler can hang in some cases when a numeric literal is used
in a context where the expected type is a type derived two levels
down from a tagged type that specifies a literal aspect.

gcc/ada/

	* sem_res.adb
	(Resolve_Equality_Op): Add handling for equality ops with
	user-defined literal operands.
	* sem_util.ads
	(Is_User_Defined_Literal): Update spec comment to indicate
	inclusion of named number cases.
	* sem_util.adb
	(Corresponding_Primitive_Op): Rather than following the chain of
	ancestor subprograms via Alias and Overridden_Operation links, we
	check for matching profiles between primitive subprograms of the
	descendant type and the ancestor subprogram (by calling a new
	nested function Profile_Matches_Ancestor). This prevents the
	compiler from hanging due to circular linkages via those fields
	that can occur between inherited and overriding subprograms
	(which might indicate a latent bug, but one that may be rather
	delicate to resolve).
	(Profile_Matches_Ancestor): New nested subprogram to compare the
	profile of a primitive subprogram with the profile of a candidate
	ancestor subprogram.
	(Is_User_Defined_Literal): Also return True in cases where the
	node N denotes a named number (E_Name_Integer and E_Named_Real).

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f61846717c9294cc7efb0e12d05e7dd4bfe5e155..4b76595fb9e30ac68b1d207d86fc7fa4fc0fdeba 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -8876,6 +8876,20 @@ package body Sem_Res is
          end if;
 
       else
+
+         --  For Ada 2022, check for user-defined literals when the type has
+         --  the appropriate aspect.
+
+         if Has_Applicable_User_Defined_Literal (L, Etype (R)) then
+            Resolve (L, Etype (R));
+            Set_Etype (N, Standard_Boolean);
+         end if;
+
+         if Has_Applicable_User_Defined_Literal (R, Etype (L)) then
+            Resolve (R, Etype (L));
+            Set_Etype (N, Standard_Boolean);
+         end if;
+
          --  Deal with other error cases
 
          if T = Any_String    or else

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5d83956398b5605a6875a1436a1c78cc22320099..b70876486ca781787baf8a62af4aaa9871c23772 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -7182,7 +7182,51 @@ package body Sem_Util is
       Typ  : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op);
       Elmt : Elmt_Id;
       Subp : Entity_Id;
-      Prim : Entity_Id;
+
+      function Profile_Matches_Ancestor (S : Entity_Id) return Boolean;
+      --  Returns True if subprogram S has the proper profile for an
+      --  overriding of Ancestor_Op (that is, corresponding formals either
+      --  have the same type, or are corresponding controlling formals,
+      --  and similarly for result types).
+
+      ------------------------------
+      -- Profile_Matches_Ancestor --
+      ------------------------------
+
+      function Profile_Matches_Ancestor (S : Entity_Id) return Boolean is
+         F1 : Entity_Id := First_Formal (Ancestor_Op);
+         F2 : Entity_Id := First_Formal (S);
+
+      begin
+         if Ekind (Ancestor_Op) /= Ekind (S) then
+            return False;
+         end if;
+
+         --  ??? This should probably account for anonymous access formals,
+         --  but the parent function (Corresponding_Primitive_Op) is currently
+         --  only called for user-defined literal functions, which can't have
+         --  such formals. But if this is ever used in a more general context
+         --  it should be extended to handle such formals (and result types).
+
+         while Present (F1) and then Present (F2) loop
+            if Etype (F1) = Etype (F2)
+              or else Is_Ancestor (Typ, Etype (F2))
+            then
+               Next_Formal (F1);
+               Next_Formal (F2);
+            else
+               return False;
+            end if;
+         end loop;
+
+         return No (F1)
+           and then No (F2)
+           and then (Etype (Ancestor_Op) = Etype (S)
+                      or else Is_Ancestor (Typ, Etype (S)));
+      end Profile_Matches_Ancestor;
+
+   --  Start of processing for Corresponding_Primitive_Op
+
    begin
       pragma Assert (Is_Dispatching_Operation (Ancestor_Op));
       pragma Assert (Is_Ancestor (Typ, Descendant_Type)
@@ -7193,12 +7237,12 @@ package body Sem_Util is
       while Present (Elmt) loop
          Subp := Node (Elmt);
 
-         --  For regular primitives we only need to traverse the chain of
-         --  ancestors when the name matches the name of Ancestor_Op, but
-         --  for predefined dispatching operations we cannot rely on the
-         --  name of the primitive to identify a candidate since their name
-         --  is internally built adding a suffix to the name of the tagged
-         --  type.
+         --  For regular primitives we need to check the profile against
+         --  the ancestor when the name matches the name of Ancestor_Op,
+         --  but for predefined dispatching operations we cannot rely on
+         --  the name of the primitive to identify a candidate since their
+         --  name is internally built by adding a suffix to the name of the
+         --  tagged type.
 
          if Chars (Subp) = Chars (Ancestor_Op)
            or else Is_Predefined_Dispatching_Operation (Subp)
@@ -7214,26 +7258,10 @@ package body Sem_Util is
                   return Alias (Subp);
                end if;
 
-            --  Traverse the chain of ancestors searching for Ancestor_Op.
-            --  Overridden primitives have attribute Overridden_Operation;
-            --  inherited primitives have attribute Alias.
-
-            else
-               Prim := Subp;
-
-               while Present (Overridden_Operation (Prim))
-                 or else Present (Alias (Prim))
-               loop
-                  if Present (Overridden_Operation (Prim)) then
-                     Prim := Overridden_Operation (Prim);
-                  else
-                     Prim := Alias (Prim);
-                  end if;
+            --  Otherwise, return subprogram when profile matches its ancestor
 
-                  if Prim = Ancestor_Op then
-                     return Subp;
-                  end if;
-               end loop;
+            elsif Profile_Matches_Ancestor (Subp) then
+               return Subp;
             end if;
          end if;
 
@@ -21620,8 +21648,22 @@ package body Sem_Util is
            N_String_Literal  => Aspect_String_Literal);
 
    begin
-      return Nkind (N) in N_Numeric_Or_String_Literal
-        and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N))));
+      --  Return True when N is either a literal or a named number and the
+      --  type has the appropriate user-defined literal aspect.
+
+      return (Nkind (N) in N_Numeric_Or_String_Literal
+        and then Present (Find_Aspect (Typ, Literal_Aspect_Map (Nkind (N)))))
+          or else
+            (Is_Entity_Name (N)
+              and then Present (Entity (N))
+              and then
+                ((Ekind (Entity (N)) = E_Named_Integer
+                    and then
+                      Present (Find_Aspect (Typ, Aspect_Integer_Literal)))
+                   or else
+                     (Ekind (Entity (N)) = E_Named_Real
+                        and then
+                          Present (Find_Aspect (Typ, Aspect_Real_Literal)))));
    end Is_User_Defined_Literal;
 
    --------------------------------------

diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 001e58f48082f10c66dd02a580625b0edca6f403..132c2b8cddf3da7c4924a85507d97aa1ef8b5bfb 100644 (file)
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2500,7 +2500,9 @@ package Sem_Util is
      (N   : Node_Id;
       Typ : Entity_Id) return Boolean;
    pragma Inline (Is_User_Defined_Literal);
-   --  Determine whether N is a user-defined literal for Typ
+   --  Determine whether N is a user-defined literal for Typ, including
+   --  the case where N denotes a named number of the appropriate kind
+   --  when Typ has an Integer_Literal or Real_Literal aspect.
 
    function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
    --  Determine whether N denotes a reference to a variable which captures the