[Ada] Crash in tagged type constructor with task components
2020-06-17 Javier Miranda <miranda@adacore.com> gcc/ada/ * exp_ch6.adb (Has_BIP_Extra_Formal): New subprogram. (Needs_BIP_Task_Actuals): Add support for the subprogram type internally generated for dispatching calls. * exp_disp.adb (Expand_Dispatching_Call): Adding code to explicitly duplicate the extra formals of the target subprogram. * freeze.adb (Check_Extra_Formals): New subprogram. (Freeze_Subprogram): Fix decoration of Extra_Formals. * sem_ch3.adb (Derive_Subprogram): Fix decoration of Extra_Formals.
This commit is contained in:
Javier Miranda
Pierre-Marie de Rodat
parent
da901811dc
commit
765005dd67
4 changed files with 186 additions and 14 deletions
|
|
@ -272,6 +272,15 @@ package body Exp_Ch6 is
|
|||
-- Expand simple return from function. In the case where we are returning
|
||||
-- from a function body this is called by Expand_N_Simple_Return_Statement.
|
||||
|
||||
function Has_BIP_Extra_Formal
|
||||
(E : Entity_Id;
|
||||
Kind : BIP_Formal_Kind) return Boolean;
|
||||
-- Given a frozen subprogram, subprogram type, entry or entry family,
|
||||
-- return True if E has the BIP extra formal associated with Kind. It must
|
||||
-- be invoked with a frozen entity or a subprogram type of a dispatching
|
||||
-- call since we can only rely on the availability of the extra formals
|
||||
-- on these entities.
|
||||
|
||||
procedure Insert_Post_Call_Actions (N : Node_Id; Post_Call : List_Id);
|
||||
-- Insert the Post_Call list previously produced by routine Expand_Actuals
|
||||
-- or Expand_Call_Helper into the tree.
|
||||
|
|
@ -828,8 +837,8 @@ package body Exp_Ch6 is
|
|||
(Func : Entity_Id;
|
||||
Kind : BIP_Formal_Kind) return Entity_Id
|
||||
is
|
||||
Extra_Formal : Entity_Id := Extra_Formals (Func);
|
||||
Formal_Suffix : constant String := BIP_Formal_Suffix (Kind);
|
||||
Extra_Formal : Entity_Id := Extra_Formals (Func);
|
||||
|
||||
begin
|
||||
-- Maybe it would be better for each implicit formal of a build-in-place
|
||||
|
|
@ -8230,6 +8239,41 @@ package body Exp_Ch6 is
|
|||
end if;
|
||||
end Freeze_Subprogram;
|
||||
|
||||
--------------------------
|
||||
-- Has_BIP_Extra_Formal --
|
||||
--------------------------
|
||||
|
||||
function Has_BIP_Extra_Formal
|
||||
(E : Entity_Id;
|
||||
Kind : BIP_Formal_Kind) return Boolean
|
||||
is
|
||||
Extra_Formal : Entity_Id := Extra_Formals (E);
|
||||
|
||||
begin
|
||||
-- We can only rely on the availability of the extra formals in frozen
|
||||
-- entities or in subprogram types of dispatching calls (since their
|
||||
-- extra formals are added when the target subprogram is frozen; see
|
||||
-- Expand_Dispatching_Call).
|
||||
|
||||
pragma Assert (Is_Frozen (E)
|
||||
or else (Ekind (E) = E_Subprogram_Type
|
||||
and then Is_Dispatch_Table_Entity (E))
|
||||
or else (Is_Dispatching_Operation (E)
|
||||
and then Is_Frozen (Find_Dispatching_Type (E))));
|
||||
|
||||
while Present (Extra_Formal) loop
|
||||
if Is_Build_In_Place_Entity (Extra_Formal)
|
||||
and then BIP_Suffix_Kind (Extra_Formal) = Kind
|
||||
then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
Next_Formal_With_Extras (Extra_Formal);
|
||||
end loop;
|
||||
|
||||
return False;
|
||||
end Has_BIP_Extra_Formal;
|
||||
|
||||
------------------------------
|
||||
-- Insert_Post_Call_Actions --
|
||||
------------------------------
|
||||
|
|
@ -9871,6 +9915,10 @@ package body Exp_Ch6 is
|
|||
Func_Typ : Entity_Id;
|
||||
|
||||
begin
|
||||
if Global_No_Tasking or else No_Run_Time_Mode then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- For thunks we must rely on their target entity; otherwise, given that
|
||||
-- the profile of thunks for functions returning a limited interface
|
||||
-- type returns a class-wide type, we would erroneously add these extra
|
||||
|
|
@ -9887,8 +9935,34 @@ package body Exp_Ch6 is
|
|||
|
||||
Func_Typ := Underlying_Type (Etype (Subp_Id));
|
||||
|
||||
return not Global_No_Tasking
|
||||
and then (Has_Task (Func_Typ) or else Might_Have_Tasks (Func_Typ));
|
||||
-- At first sight, for all the following cases, we could add assertions
|
||||
-- to ensure that if Func_Id is frozen then the computed result matches
|
||||
-- with the availability of the task master extra formal; unfortunately
|
||||
-- this is not feasible because we may be precisely freezing this entity
|
||||
-- (ie. Is_Frozen has been set by Freeze_Entity but it has not completed
|
||||
-- its work).
|
||||
|
||||
if Has_Task (Func_Typ) then
|
||||
return True;
|
||||
|
||||
elsif Ekind (Func_Id) = E_Function then
|
||||
return Might_Have_Tasks (Func_Typ);
|
||||
|
||||
-- Handle subprogram type internally generated for dispatching call. We
|
||||
-- can not rely on the return type of the subprogram type of dispatching
|
||||
-- calls since it is always a class-wide type (cf. Expand_Dispatching_
|
||||
-- _Call).
|
||||
|
||||
elsif Ekind (Func_Id) = E_Subprogram_Type then
|
||||
if Is_Dispatch_Table_Entity (Func_Id) then
|
||||
return Has_BIP_Extra_Formal (Func_Id, BIP_Task_Master);
|
||||
else
|
||||
return Might_Have_Tasks (Func_Typ);
|
||||
end if;
|
||||
|
||||
else
|
||||
raise Program_Error;
|
||||
end if;
|
||||
end Needs_BIP_Task_Actuals;
|
||||
|
||||
-----------------------------------
|
||||
|
|
|
|||
|
|
@ -1023,9 +1023,9 @@ package body Exp_Disp is
|
|||
-- list including the creation of a new set of matching entities.
|
||||
|
||||
declare
|
||||
Old_Formal : Entity_Id := First_Formal (Subp);
|
||||
New_Formal : Entity_Id;
|
||||
Extra : Entity_Id := Empty;
|
||||
Old_Formal : Entity_Id := First_Formal (Subp);
|
||||
New_Formal : Entity_Id;
|
||||
Last_Formal : Entity_Id := Empty;
|
||||
|
||||
begin
|
||||
if Present (Old_Formal) then
|
||||
|
|
@ -1049,7 +1049,7 @@ package body Exp_Disp is
|
|||
-- errors when the itype is the completion of a type derived
|
||||
-- from a private type.
|
||||
|
||||
Extra := New_Formal;
|
||||
Last_Formal := New_Formal;
|
||||
Next_Formal (Old_Formal);
|
||||
exit when No (Old_Formal);
|
||||
|
||||
|
|
@ -1059,17 +1059,41 @@ package body Exp_Disp is
|
|||
end loop;
|
||||
|
||||
Unlink_Next_Entity (New_Formal);
|
||||
Set_Last_Entity (Subp_Typ, Extra);
|
||||
Set_Last_Entity (Subp_Typ, Last_Formal);
|
||||
end if;
|
||||
|
||||
-- Now that the explicit formals have been duplicated, any extra
|
||||
-- formals needed by the subprogram must be created.
|
||||
-- formals needed by the subprogram must be duplicated; we know
|
||||
-- that extra formals are available because they were added when
|
||||
-- the tagged type was frozen (see Expand_Freeze_Record_Type).
|
||||
|
||||
if Present (Extra) then
|
||||
Set_Extra_Formal (Extra, Empty);
|
||||
pragma Assert (Is_Frozen (Typ));
|
||||
|
||||
-- Warning: The addition of the extra formals cannot be performed
|
||||
-- here invoking Create_Extra_Formals since we must ensure that all
|
||||
-- the extra formals of the pointer type and the target subprogram
|
||||
-- match (and for functions that return a tagged type the profile of
|
||||
-- the built subprogram type always returns a class-wide type, which
|
||||
-- may affect the addition of some extra formals).
|
||||
|
||||
if Present (Last_Formal)
|
||||
and then Present (Extra_Formal (Last_Formal))
|
||||
then
|
||||
Old_Formal := Extra_Formal (Last_Formal);
|
||||
New_Formal := New_Copy (Old_Formal);
|
||||
|
||||
Set_Extra_Formal (Last_Formal, New_Formal);
|
||||
Set_Extra_Formals (Subp_Typ, New_Formal);
|
||||
|
||||
Old_Formal := Extra_Formal (Old_Formal);
|
||||
while Present (Old_Formal) loop
|
||||
Set_Extra_Formal (New_Formal, New_Copy (Old_Formal));
|
||||
New_Formal := Extra_Formal (New_Formal);
|
||||
Set_Scope (New_Formal, Subp_Typ);
|
||||
|
||||
Old_Formal := Extra_Formal (Old_Formal);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Create_Extra_Formals (Subp_Typ);
|
||||
end;
|
||||
|
||||
-- Complete description of pointer type, including size information, as
|
||||
|
|
|
|||
|
|
@ -8700,10 +8700,60 @@ package body Freeze is
|
|||
-----------------------
|
||||
|
||||
procedure Freeze_Subprogram (E : Entity_Id) is
|
||||
function Check_Extra_Formals (E : Entity_Id) return Boolean;
|
||||
-- Return True if the decoration of the attributes associated with extra
|
||||
-- formals are properly set.
|
||||
|
||||
procedure Set_Profile_Convention (Subp_Id : Entity_Id);
|
||||
-- Set the conventions of all anonymous access-to-subprogram formals and
|
||||
-- result subtype of subprogram Subp_Id to the convention of Subp_Id.
|
||||
|
||||
-------------------------
|
||||
-- Check_Extra_Formals --
|
||||
-------------------------
|
||||
|
||||
function Check_Extra_Formals (E : Entity_Id) return Boolean is
|
||||
Last_Formal : Entity_Id := Empty;
|
||||
Formal : Entity_Id;
|
||||
Has_Extra_Formals : Boolean := False;
|
||||
|
||||
begin
|
||||
-- Check attribute Extra_Formal: if available it must be set only
|
||||
-- in the last formal of E
|
||||
|
||||
Formal := First_Formal (E);
|
||||
while Present (Formal) loop
|
||||
if Present (Extra_Formal (Formal)) then
|
||||
if Has_Extra_Formals then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Has_Extra_Formals := True;
|
||||
end if;
|
||||
|
||||
Last_Formal := Formal;
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
-- Check attribute Extra_Formals: if E has extra formals then this
|
||||
-- attribute must must point to the first extra formal of E.
|
||||
|
||||
if Has_Extra_Formals then
|
||||
return Present (Extra_Formals (E))
|
||||
and then Present (Extra_Formal (Last_Formal))
|
||||
and then Extra_Formal (Last_Formal) = Extra_Formals (E);
|
||||
|
||||
-- When E has no formals the first extra formal is available through
|
||||
-- the Extra_Formals attribute.
|
||||
|
||||
elsif Present (Extra_Formals (E)) then
|
||||
return No (First_Formal (E));
|
||||
|
||||
else
|
||||
return True;
|
||||
end if;
|
||||
end Check_Extra_Formals;
|
||||
|
||||
----------------------------
|
||||
-- Set_Profile_Convention --
|
||||
----------------------------
|
||||
|
|
@ -8840,9 +8890,27 @@ package body Freeze is
|
|||
|
||||
if not Has_Foreign_Convention (E) then
|
||||
if No (Extra_Formals (E)) then
|
||||
Create_Extra_Formals (E);
|
||||
|
||||
-- Extra formals are shared by derived subprograms; therefore if
|
||||
-- the ultimate alias of E has been frozen before E then the extra
|
||||
-- formals have been added but the attribute Extra_Formals is
|
||||
-- still unset (and must be set now).
|
||||
|
||||
if Present (Alias (E))
|
||||
and then Present (Extra_Formals (Ultimate_Alias (E)))
|
||||
and then Last_Formal (Ultimate_Alias (E)) = Last_Formal (E)
|
||||
then
|
||||
pragma Assert (Is_Frozen (Ultimate_Alias (E)));
|
||||
pragma Assert (No (First_Formal (Ultimate_Alias (E)))
|
||||
or else
|
||||
Present (Extra_Formal (Last_Formal (Ultimate_Alias (E)))));
|
||||
Set_Extra_Formals (E, Extra_Formals (Ultimate_Alias (E)));
|
||||
else
|
||||
Create_Extra_Formals (E);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
pragma Assert (Check_Extra_Formals (E));
|
||||
Set_Mechanisms (E);
|
||||
|
||||
-- If this is convention Ada and a Valued_Procedure, that's odd
|
||||
|
|
|
|||
|
|
@ -15557,6 +15557,12 @@ package body Sem_Ch3 is
|
|||
Next_Formal (Formal);
|
||||
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.
|
||||
|
||||
Set_Extra_Formals (New_Subp, Extra_Formals (Parent_Subp));
|
||||
|
||||
-- If this derivation corresponds to a tagged generic actual, then
|
||||
-- primitive operations rename those of the actual. Otherwise the
|
||||
-- primitive operations rename those of the parent type, If the parent
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue