[Ada] Crash in tagged type constructor with task components
2020-06-18 Javier Miranda <miranda@adacore.com> 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.
This commit is contained in:
Javier Miranda
Pierre-Marie de Rodat
parent
4f4fd8ae2c
commit
b93d80bc8f
@ -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);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user