-- 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.
(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
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 --
------------------------------
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
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;
-----------------------------------
-- 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
-- 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);
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);
- end if;
+ 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);
- Create_Extra_Formals (Subp_Typ);
+ 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;
end;
-- Complete description of pointer type, including size information, as
-----------------------
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 --
----------------------------
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
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
projects / gcc.git / commitdiff