From b93d80bc8fc58c4ef746a8ddc699167c3ededfb9 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Thu, 23 Apr 2020 13:36:43 -0400 Subject: [PATCH] [Ada] Crash in tagged type constructor with task components 2020-06-18 Javier Miranda gcc/ada/ * exp_ch6.adb (BIP_Suffix_Kind, Is_Build_In_Place_Entity): Move declarations... * exp_ch6.ads: Here. * exp_util.adb (Is_Secondary_Stack_BIP_Func_Call): Do not rely on the name of the scope to locate the extra formal BIPalloc since they are copied when the pointer type associated with dispatching calls is built; rely on routines Is_Build_In_Place_Entity and BIP_Suffix_Kind. * exp_disp.adb (Expand_Dispatching_Call): Set the scope of the first extra formal of the internally built pointer type. * sem_ch3.adb (Derive_Subprogram): Do not inherit extra formals from a limited interface parent since limitedness is not inherited in such case (AI-419) and this affects the extra formals. * sprint.adb (Write_Itype): Output extra formals of subprogram types. --- gcc/ada/exp_ch6.adb | 6 ------ gcc/ada/exp_ch6.ads | 6 ++++++ gcc/ada/exp_disp.adb | 1 + gcc/ada/exp_util.adb | 15 ++------------- gcc/ada/sem_ch3.adb | 26 ++++++++++++++++++++------ gcc/ada/sprint.adb | 37 +++++++++++++++++++++++++++++++++++++ 6 files changed, 66 insertions(+), 25 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 00a0aef0631..3562193afc7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -156,9 +156,6 @@ package body Exp_Ch6 is -- level is known not to be statically deeper than the result type of the -- function. - function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind; - -- Ada 2005 (AI-318-02): Returns the kind of the given extra formal. - function Caller_Known_Size (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; @@ -285,9 +282,6 @@ package body Exp_Ch6 is -- Insert the Post_Call list previously produced by routine Expand_Actuals -- or Expand_Call_Helper into the tree. - function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity. - procedure Replace_Renaming_Declaration_Id (New_Decl : Node_Id; Orig_Decl : Node_Id); diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 1c30219cbad..69b19090102 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -102,6 +102,9 @@ package Exp_Ch6 is -- Ada 2005 (AI-318-02): Returns a string to be used as the suffix of names -- for build-in-place formal parameters of the given kind. + function BIP_Suffix_Kind (E : Entity_Id) return BIP_Formal_Kind; + -- Ada 2005 (AI-318-02): Returns the kind of the given BIP extra formal. + function Build_In_Place_Formal (Func : Entity_Id; Kind : BIP_Formal_Kind) return Entity_Id; @@ -117,6 +120,9 @@ package Exp_Ch6 is -- The returned node is the root of the procedure body which will replace -- the original function body, which is not needed for the C program. + function Is_Build_In_Place_Entity (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-318-02): Returns True if E is a BIP entity. + function Is_Build_In_Place_Result_Type (Typ : Entity_Id) return Boolean; -- Ada 2005 (AI-318-02): Returns True if functions returning the type use -- build-in-place protocols. For inherently limited types, this must be diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 65d5b2a37aa..89f206ed09f 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1081,6 +1081,7 @@ package body Exp_Disp is then Old_Formal := Extra_Formal (Last_Formal); New_Formal := New_Copy (Old_Formal); + Set_Scope (New_Formal, Subp_Typ); Set_Extra_Formal (Last_Formal, New_Formal); Set_Extra_Formals (Subp_Typ, New_Formal); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 537f0fc2490..d93788b8e5b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -8829,7 +8829,6 @@ package body Exp_Util is -------------------------------------- function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is - Alloc_Nam : Name_Id := No_Name; Actual : Node_Id; Call : Node_Id := Expr; Formal : Node_Id; @@ -8856,20 +8855,10 @@ package body Exp_Util is Formal := Selector_Name (Param); Actual := Explicit_Actual_Parameter (Param); - -- Construct the name of formal BIPalloc. It is much easier to - -- extract the name of the function using an arbitrary formal's - -- scope rather than the Name field of Call. - - if Alloc_Nam = No_Name and then Present (Entity (Formal)) then - Alloc_Nam := - New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Alloc_Form)); - end if; - -- A match for BIPalloc => 2 has been found - if Chars (Formal) = Alloc_Nam + if Is_Build_In_Place_Entity (Formal) + and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form and then Nkind (Actual) = N_Integer_Literal and then Intval (Actual) = Uint_2 then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 04060baa11e..8bb62c7a60a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15539,6 +15539,15 @@ package body Sem_Ch3 is while Present (Formal) loop New_Formal := New_Copy (Formal); + -- Extra formals are not inherited from a limited interface parent + -- since limitedness is not inherited in such case (AI-419) and this + -- affects the extra formals. + + if Is_Limited_Interface (Parent_Type) then + Set_Extra_Formal (New_Formal, Empty); + Set_Extra_Accessibility (New_Formal, Empty); + end if; + -- Normally we do not go copying parents, but in the case of -- formals, we need to link up to the declaration (which is the -- parameter specification), and it is fine to link up to the @@ -15558,14 +15567,19 @@ package body Sem_Ch3 is end loop; -- Extra formals are shared between the parent subprogram and the - -- derived subprogram (implicit in the above copy of formals), and - -- hence we must inherit also the reference to the first extra formal. + -- derived subprogram (implicit in the above copy of formals), unless + -- the parent type is a limited interface type; hence we must inherit + -- also the reference to the first extra formal. When the parent type is + -- an interface the extra formals will be added when the subprogram is + -- frozen (see Freeze.Freeze_Subprogram). - Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp)); + if not Is_Limited_Interface (Parent_Type) then + Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp)); - if Ekind (New_Subp) = E_Function then - Set_Extra_Accessibility_Of_Result (New_Subp, - Extra_Accessibility_Of_Result (Parent_Subp)); + if Ekind (New_Subp) = E_Function then + Set_Extra_Accessibility_Of_Result (New_Subp, + Extra_Accessibility_Of_Result (Parent_Subp)); + end if; end if; -- If this derivation corresponds to a tagged generic actual, then diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index f177981de70..7bfa5017019 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -4489,6 +4489,43 @@ package body Sprint is Write_Str (", "); end loop; + if Present (Extra_Formals (Typ)) then + Param := Extra_Formals (Typ); + + while Present (Param) loop + Write_Str (", "); + Write_Id (Param); + Write_Str (" : "); + Write_Id (Etype (Param)); + + Param := Extra_Formal (Param); + end loop; + end if; + + Write_Char (')'); + end; + + elsif Present (Extra_Formals (Typ)) then + declare + Param : Entity_Id; + + begin + Write_Str (" ("); + + Param := Extra_Formals (Typ); + + while Present (Param) loop + Write_Id (Param); + Write_Str (" : "); + Write_Id (Etype (Param)); + + if Present (Extra_Formal (Param)) then + Write_Str (", "); + end if; + + Param := Extra_Formal (Param); + end loop; + Write_Char (')'); end; end if;