From: Eric Botcazou <ebotcazou@adacore.com>
Date: Fri, 27 Jan 2023 23:08:24 +0000 (+0100)
Subject: ada: Implement inheritance of user-defined literal aspects for untagged types
X-Git-Tag: basepoints/gcc-15~9242
X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=bac7eb85ef0caca4e55b362f688776dbea14feb9;p=thirdparty%2Fgcc.git

ada: Implement inheritance of user-defined literal aspects for untagged types

In Ada 2022, user-defined literal aspects are nonoverridable but the named
subprograms present in them can be overridden, including for untagged types.

gcc/ada/

	* sem_res.adb (Has_Applicable_User_Defined_Literal): Apply the
	same processing for derived untagged types as for tagged types.
	* sem_util.ads (Corresponding_Primitive_Op): Adjust description.
	* sem_util.adb (Corresponding_Primitive_Op): Handle untagged
	types.
---

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index df9ccb184683..f6634da42a78 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -492,7 +492,6 @@ package body Sem_Res is
          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 :=
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 38dc654f7bee..1d8d4fc30f81 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6483,9 +6483,8 @@ package body Sem_Util is
      (Ancestor_Op     : Entity_Id;
       Descendant_Type : Entity_Id) return Entity_Id
    is
-      Typ  : constant Entity_Id := Find_Dispatching_Type (Ancestor_Op);
-      Elmt : Elmt_Id;
-      Subp : Entity_Id;
+      function Find_Untagged_Type_Of (Prim : Entity_Id) return Entity_Id;
+      --  Search for the untagged type of the primitive operation Prim.
 
       function Profile_Matches_Ancestor (S : Entity_Id) return Boolean;
       --  Returns True if subprogram S has the proper profile for an
@@ -6493,6 +6492,34 @@ package body Sem_Util is
       --  have the same type, or are corresponding controlling formals,
       --  and similarly for result types).
 
+      ---------------------------
+      -- Find_Untagged_Type_Of --
+      ---------------------------
+
+      function Find_Untagged_Type_Of (Prim : Entity_Id) return Entity_Id is
+         E : Entity_Id := First_Entity (Scope (Prim));
+
+      begin
+         while Present (E) and then E /= Prim loop
+            if not Is_Tagged_Type (E)
+              and then Present (Direct_Primitive_Operations (E))
+              and then Contains (Direct_Primitive_Operations (E), Prim)
+            then
+               return E;
+            end if;
+
+            Next_Entity (E);
+         end loop;
+
+         pragma Assert (False);
+         return Empty;
+      end Find_Untagged_Type_Of;
+
+      Typ  : constant Entity_Id :=
+               (if Is_Dispatching_Operation (Ancestor_Op)
+                 then Find_Dispatching_Type (Ancestor_Op)
+                 else Find_Untagged_Type_Of (Ancestor_Op));
+
       ------------------------------
       -- Profile_Matches_Ancestor --
       ------------------------------
@@ -6529,10 +6556,14 @@ package body Sem_Util is
                       or else Is_Ancestor (Typ, Etype (S)));
       end Profile_Matches_Ancestor;
 
+      --  Local variables
+
+      Elmt : Elmt_Id;
+      Subp : Entity_Id;
+
    --  Start of processing for Corresponding_Primitive_Op
 
    begin
-      pragma Assert (Is_Dispatching_Operation (Ancestor_Op));
       pragma Assert (Is_Ancestor (Typ, Descendant_Type)
                       or else Is_Progenitor (Typ, Descendant_Type));
 
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index f98e05615fda..42c6d249e2f6 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -618,9 +618,9 @@ package Sem_Util is
    --  Possible optimization???
 
    function Corresponding_Primitive_Op
-       (Ancestor_Op     : Entity_Id;
-        Descendant_Type : Entity_Id) return Entity_Id;
-   --  Given a primitive subprogram of a tagged type and a (distinct)
+     (Ancestor_Op     : Entity_Id;
+      Descendant_Type : Entity_Id) return Entity_Id;
+   --  Given a primitive subprogram of a first type and a (distinct)
    --  descendant type of that type, find the corresponding primitive
    --  subprogram of the descendant type.