[gcc r13-601] [Ada] Crash building VSS with compiler built with assertions

[gcc r13-601] [Ada] Crash building VSS with compiler built with assertions

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:ddb82555b422eb175471a3f4df40b27f872ce9bf

commit r13-601-gddb82555b422eb175471a3f4df40b27f872ce9bf
Author: Javier Miranda <miranda@adacore.com>
Date:   Fri Apr 1 22:12:05 2022 +0000

    [Ada] Crash building VSS with compiler built with assertions
    
    When a tagged type T has aspect String_Literal, a derived type defines a
    null extension T2, and the context to resolve the use of an object of
    type T2 where the string literal is applicable is a class-wide type the
    frontend crashes trying to evaluate if the object is a null extension.
    This problem does not reproduce when the compiler is built with
    assertions disabled.
    
    gcc/ada/
    
            * sem_ch6.adb (Find_Corresponding_Spec): Avoid calling
            Is_Null_Extension with a class-wide type entity.
            (Overrides_Visible_Function): Handle alias entities.
            * sem_res.adb (Has_Applicable_User_Defined_Literal): Conversion
            not needed if the result type of the call is class-wide or if
            the result type matches the context type.
            * sem_util.ads (Is_Null_Extension): Adding documentation.
            (Is_Null_Extension_Of): Adding documentation.
            * sem_util.adb (Is_Null_Extension): Adding assertion.
            (Is_Null_Extension_Of): Adding assertions.

Diff:
---
 gcc/ada/sem_ch6.adb  | 6 ++++--
 gcc/ada/sem_res.adb  | 7 ++++++-
 gcc/ada/sem_util.adb | 5 +++++
 gcc/ada/sem_util.ads | 2 ++
 4 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index c9e57e95b10..a5373583207 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9867,7 +9867,8 @@ package body Sem_Ch6 is
                  and then Ada_Version >= Ada_2005
                  and then not Comes_From_Source (E)
                  and then Has_Controlling_Result (E)
-                 and then Is_Null_Extension (Etype (E))
+                 and then (not Is_Class_Wide_Type (Etype (E))
+                            and then Is_Null_Extension (Etype (E)))
                  and then Comes_From_Source (Spec)
                then
                   Set_Has_Completion (E, False);
@@ -11265,7 +11266,8 @@ package body Sem_Ch6 is
 
             function Overrides_Private_Part_Op return Boolean is
                Over_Decl : constant Node_Id :=
-                             Unit_Declaration_Node (Overridden_Operation (S));
+                             Unit_Declaration_Node
+                               (Ultimate_Alias (Overridden_Operation (S)));
                Subp_Decl : constant Node_Id := Unit_Declaration_Node (S);
 
             begin
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 33f445d69b9..060fcfc5508 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -559,7 +559,12 @@ package body Sem_Res is
 
          Set_Etype (Call, Etype (Callee));
 
-         if Base_Type (Etype (Call)) /= Base_Type (Typ) then
+         --  Conversion not needed if the result type of the call is class-wide
+         --  or if the result type matches the context type.
+
+         if not Is_Class_Wide_Type (Typ)
+           and then 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
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index a059d1eb933..762fe48d1c9 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -19279,6 +19279,8 @@ package body Sem_Util is
       Type_Decl : Node_Id;
       Type_Def  : Node_Id;
    begin
+      pragma Assert (not Is_Class_Wide_Type (T));
+
       if Ignore_Privacy then
          Type_Decl := Parent (Underlying_Type (Base_Type (T)));
       else
@@ -19311,7 +19313,10 @@ package body Sem_Util is
         := Underlying_Type (Base_Type (Ancestor));
       Descendant_Type : Entity_Id := Underlying_Type (Base_Type (Descendant));
    begin
+      pragma Assert (not Is_Class_Wide_Type (Descendant));
+      pragma Assert (not Is_Class_Wide_Type (Ancestor));
       pragma Assert (Descendant_Type /= Ancestor_Type);
+
       while Descendant_Type /= Ancestor_Type loop
          if not Is_Null_Extension
                   (Descendant_Type, Ignore_Privacy => True)
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 6f28fe0b652..b6c70ca2300 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -2209,12 +2209,14 @@ package Sem_Util is
    --  Given a tagged type, returns True if argument is a type extension
    --  that introduces no new components (discriminant or nondiscriminant).
    --  Ignore_Privacy should be True for use in implementing dynamic semantics.
+   --  Cannot be called with class-wide types.
 
    function Is_Null_Extension_Of
      (Descendant, Ancestor : Entity_Id) return Boolean;
    --  Given two tagged types, the first a descendant of the second,
    --  returns True if every component of Descendant is inherited
    --  (directly or indirectly) from Ancestor. Privacy is ignored.
+   --  Cannot be called with class-wide types.
 
    function Is_Null_Record_Definition (Record_Def : Node_Id) return Boolean;
    --  Returns True for an N_Record_Definition node that has no user-defined