[gcc r14-3689] ada: Crash on creation of extra formals on type extension

[gcc r14-3689] ada: Crash on creation of extra formals on type extension

[Marc Poulhi?s]

https://gcc.gnu.org/g:2aa1a9205e3e9581e771c7d02e35fd03bff9fce3

commit r14-3689-g2aa1a9205e3e9581e771c7d02e35fd03bff9fce3
Author: Javier Miranda <miranda@adacore.com>
Date:   Sat Aug 19 16:50:42 2023 +0000

    ada: Crash on creation of extra formals on type extension
    
    The compiler blows up processing an overriding dispatching function
    of a derived tagged type that returns a private tagged type that
    has an access type discriminant.
    
    gcc/ada/
    
            * accessibility.ads (Needs_Result_Accessibility_Extra_Formal): New
            subprogram.
            * accessibility.adb (Needs_Result_Accessibility_Level_Param): New
            subprogram.
            (Needs_Result_Accessibility_Extra_Formal): New subprogram,
            temporarily keep the previous behavior of the frontend.
            * sem_ch6.adb (Create_Extra_Formals): Replace occurrences of
            function Needs_Result_Accessibility_Level_Param by calls to
            function Needs_Result_Accessibility_Extra_Formal.
            (Extra_Formals_OK): Ditto.

Diff:
---
 gcc/ada/accessibility.adb | 54 +++++++++++++++++++++++++++++++++++++++++++++--
 gcc/ada/accessibility.ads | 12 ++++++++++-
 gcc/ada/sem_ch6.adb       |  8 +++----
 3 files changed, 67 insertions(+), 7 deletions(-)

diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index bc897d1ef18c..6b4ec5b9d242 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -56,6 +56,16 @@ with Tbuild;         use Tbuild;
 
 package body Accessibility is
 
+   function Needs_Result_Accessibility_Level_Param
+     (Func_Id  : Entity_Id;
+      Func_Typ : Entity_Id) return Boolean;
+   --  Subsidiary of functions Needs_Result_Accessibility_Extra_Formal and
+   --  Needs_Result_Accessibility_Level_Param. Return True if the function
+   --  needs an implicit parameter to identify the accessibility level of
+   --  the function result "determined by the point of call". Func_Typ is
+   --  the function return type; this function returns False if Func_Typ is
+   --  Empty.
+
    ---------------------------
    -- Accessibility_Message --
    ---------------------------
@@ -1892,6 +1902,34 @@ package body Accessibility is
                and then Is_Explicitly_Aliased (Entity (Prefix (Exp)));
    end Is_Special_Aliased_Formal_Access;
 
+   ---------------------------------------------
+   -- Needs_Result_Accessibility_Extra_Formal --
+   ---------------------------------------------
+
+   function Needs_Result_Accessibility_Extra_Formal
+     (Func_Id : Entity_Id) return Boolean
+   is
+      Func_Typ : Entity_Id;
+
+   begin
+      if Present (Underlying_Type (Etype (Func_Id))) then
+         Func_Typ := Underlying_Type (Etype (Func_Id));
+
+      --  Case of a function returning a private type which is not completed
+      --  yet. The support for this case is required because this function is
+      --  called to create the extra formals of dispatching primitives, and
+      --  they may be frozen before we see the full-view of their returned
+      --  private type.
+
+      else
+         --  Temporarily restore previous behavior
+         --  Func_Typ := Etype (Func_Id);
+         Func_Typ := Empty;
+      end if;
+
+      return Needs_Result_Accessibility_Level_Param (Func_Id, Func_Typ);
+   end Needs_Result_Accessibility_Extra_Formal;
+
    --------------------------------------
    -- Needs_Result_Accessibility_Level --
    --------------------------------------
@@ -1901,6 +1939,18 @@ package body Accessibility is
    is
       Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
 
+   begin
+      return Needs_Result_Accessibility_Level_Param (Func_Id, Func_Typ);
+   end Needs_Result_Accessibility_Level;
+
+   --------------------------------------------
+   -- Needs_Result_Accessibility_Level_Param --
+   --------------------------------------------
+
+   function Needs_Result_Accessibility_Level_Param
+     (Func_Id  : Entity_Id;
+      Func_Typ : Entity_Id) return Boolean
+   is
       function Has_Unconstrained_Access_Discriminant_Component
         (Comp_Typ : Entity_Id) return Boolean;
       --  Returns True if any component of the type has an unconstrained access
@@ -1952,7 +2002,7 @@ package body Accessibility is
       --  Flag used to temporarily disable a "True" result for tagged types.
       --  See comments further below for details.
 
-   --  Start of processing for Needs_Result_Accessibility_Level
+   --  Start of processing for Needs_Result_Accessibility_Level_Param
 
    begin
       --  False if completion unavailable, which can happen when we are
@@ -2028,7 +2078,7 @@ package body Accessibility is
       else
          return False;
       end if;
-   end Needs_Result_Accessibility_Level;
+   end Needs_Result_Accessibility_Level_Param;
 
    ------------------------------------------
    -- Prefix_With_Safe_Accessibility_Level --
diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads
index e30c90ab6a79..731fea125f48 100644
--- a/gcc/ada/accessibility.ads
+++ b/gcc/ada/accessibility.ads
@@ -197,11 +197,21 @@ package Accessibility is
    --  prefix is an aliased formal of Scop and that Scop returns an anonymous
    --  access type. See RM 3.10.2 for more details.
 
+   function Needs_Result_Accessibility_Extra_Formal
+     (Func_Id : Entity_Id) return Boolean;
+   --  Ada 2012 (AI05-0234): Return True if the function needs an implicit
+   --  parameter to identify the accessibility level of the function result.
+   --  If the type of the function result is a private type and its completion
+   --  is unavailable, which can happen when we are analyzing an abstract
+   --  subprogram, determines its result using the returned private type. This
+   --  function is used by Create_Extra_Formals.
+
    function Needs_Result_Accessibility_Level
      (Func_Id : Entity_Id) return Boolean;
    --  Ada 2012 (AI05-0234): Return True if the function needs an implicit
    --  parameter to identify the accessibility level of the function result
-   --  "determined by the point of call".
+   --  "determined by the point of call". Return False if the type of the
+   --  function result is a private type and its completion is unavailable.
 
    function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
    --  Return the accessibility level of the view denoted by Subp
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 53011f465a8a..297371a2c160 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -9139,13 +9139,13 @@ package body Sem_Ch6 is
       begin
          Ada_Version := Ada_2022;
 
-         if Needs_Result_Accessibility_Level (Ref_E)
+         if Needs_Result_Accessibility_Extra_Formal (Ref_E)
            or else
              (Present (Parent_Subp)
-                and then Needs_Result_Accessibility_Level (Parent_Subp))
+                and then Needs_Result_Accessibility_Extra_Formal (Parent_Subp))
            or else
              (Present (Alias_Subp)
-                and then Needs_Result_Accessibility_Level (Alias_Subp))
+                and then Needs_Result_Accessibility_Extra_Formal (Alias_Subp))
          then
             Set_Extra_Accessibility_Of_Result (E,
               Add_Extra_Formal (E, Standard_Natural, E, "L"));
@@ -9694,7 +9694,7 @@ package body Sem_Ch6 is
       --  Check attribute Extra_Accessibility_Of_Result
 
       if Ekind (E) in E_Function | E_Subprogram_Type
-        and then Needs_Result_Accessibility_Level (E)
+        and then Needs_Result_Accessibility_Extra_Formal (E)
         and then No (Extra_Accessibility_Of_Result (E))
       then
          return False;