ada: Crash on creation of extra formals on type extension

Revert previous patch and fix the pending issue.

gcc/ada/

	* accessibility.ads (Needs_Result_Accessibility_Extra_Formal):
	Removed.
	* accessibility.adb (Needs_Result_Accessibility_Level_Param):
	Removed.
	(Needs_Result_Accessibility_Extra_Formal): Removed.
	(Needs_Result_Accessibility_Level): Revert previous patch.
	* sem_ch6.adb (Parent_Subprogram): Handle function overriding an
	enumeration literal.
	(Create_Extra_Formals): Ensure that the parent subprogram has all
	its extra formals.

diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index 6b4ec5b9d242b209fd1c09354495541fe5c7bc37..bc897d1ef18c2efdec094923c9ca2bc1ead41cfa 100644 (file)
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -56,16 +56,6 @@ 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 --
    ---------------------------
@@ -1902,34 +1892,6 @@ 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 --
    --------------------------------------
@@ -1939,18 +1901,6 @@ 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
@@ -2002,7 +1952,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_Param
+   --  Start of processing for Needs_Result_Accessibility_Level
 
    begin
       --  False if completion unavailable, which can happen when we are
@@ -2078,7 +2028,7 @@ package body Accessibility is
       else
          return False;
       end if;
-   end Needs_Result_Accessibility_Level_Param;
+   end Needs_Result_Accessibility_Level;
 
    ------------------------------------------
    -- Prefix_With_Safe_Accessibility_Level --

diff --git a/gcc/ada/accessibility.ads b/gcc/ada/accessibility.ads
index 731fea125f48e5e55df32387f00cece472d27138..000e9b6e1e41316782340260e7fe737397f091c6 100644 (file)
--- a/gcc/ada/accessibility.ads
+++ b/gcc/ada/accessibility.ads
@@ -197,15 +197,6 @@ 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

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 612a9e97221d3577ce9280b6f29864874db8518f..a0dad86149f65523984d95ebdd7367a903f94a64 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -8766,7 +8766,12 @@ package body Sem_Ch6 is
          Ovr_Alias : Entity_Id;
 
       begin
-         if Present (Ovr_E) then
+         if Present (Ovr_E)
+           and then Ekind (Ovr_E) = E_Enumeration_Literal
+         then
+            Ovr_E := Empty;
+
+         elsif Present (Ovr_E) then
             Ovr_Alias := Ultimate_Alias (Ovr_E);
 
             --  There is no real overridden subprogram if there is a mutual
@@ -8992,6 +8997,18 @@ package body Sem_Ch6 is
       --  for extra formals.
 
       if Present (Parent_Subp) then
+
+         --  Ensure that the parent subprogram has all its extra formals.
+         --  Required because its return type may have been a private or
+         --  an incomplete type, and the extra formals were not added. We
+         --  protect this call against the weird cases where the parent subp
+         --  renames this primitive (documented in the body of the local
+         --  function Parent_Subprogram).
+
+         if Ultimate_Alias (Parent_Subp) /= Ref_E then
+            Create_Extra_Formals (Parent_Subp);
+         end if;
+
          Parent_Formal := First_Formal (Parent_Subp);
 
          --  For concurrent types, the controlling argument of a dispatching
@@ -9140,13 +9157,13 @@ package body Sem_Ch6 is
       begin
          Ada_Version := Ada_2022;
 
-         if Needs_Result_Accessibility_Extra_Formal (Ref_E)
+         if Needs_Result_Accessibility_Level (Ref_E)
            or else
              (Present (Parent_Subp)
-                and then Needs_Result_Accessibility_Extra_Formal (Parent_Subp))
+                and then Needs_Result_Accessibility_Level (Parent_Subp))
            or else
              (Present (Alias_Subp)
-                and then Needs_Result_Accessibility_Extra_Formal (Alias_Subp))
+                and then Needs_Result_Accessibility_Level (Alias_Subp))
          then
             Set_Extra_Accessibility_Of_Result (E,
               Add_Extra_Formal (E, Standard_Natural, E, "L"));
@@ -9695,7 +9712,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_Extra_Formal (E)
+        and then Needs_Result_Accessibility_Level (E)
         and then No (Extra_Accessibility_Of_Result (E))
       then
          return False;