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