diff options
author | Javier Miranda <miranda@adacore.com> | 2023-08-19 16:50:42 +0000 |
---|---|---|
committer | Marc Poulhiès <poulhies@adacore.com> | 2023-09-05 13:05:14 +0200 |
commit | 2aa1a9205e3e9581e771c7d02e35fd03bff9fce3 (patch) | |
tree | b34408f5cd0c3b950d13d74a61346d492eb74c37 /gcc/ada | |
parent | fd208ccbfcb8562b4302b618b3fc1d2601af17d5 (diff) | |
download | gcc-2aa1a9205e3e9581e771c7d02e35fd03bff9fce3.zip gcc-2aa1a9205e3e9581e771c7d02e35fd03bff9fce3.tar.gz gcc-2aa1a9205e3e9581e771c7d02e35fd03bff9fce3.tar.bz2 |
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.
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/accessibility.adb | 54 | ||||
-rw-r--r-- | gcc/ada/accessibility.ads | 12 | ||||
-rw-r--r-- | 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 bc897d1..6b4ec5b 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 e30c90a..731fea1 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 53011f4..297371a 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; |