[COMMITTED] ada: Crash on creation of extra formals on type extension
Checks
Commit Message
From: Javier Miranda <miranda@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 54 ++-------------------------------------
gcc/ada/accessibility.ads | 9 -------
gcc/ada/sem_ch6.adb | 27 ++++++++++++++++----
3 files changed, 24 insertions(+), 66 deletions(-)
@@ -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 --
@@ -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
@@ -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;