with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Exp_VFpt; use Exp_VFpt;
with Fname; use Fname;
with Freeze; use Freeze;
with Inline; use Inline;
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
- Acc_Type : Entity_Id);
+ Acc_Type : Entity_Id;
+ Sel_Comp : Node_Id := Empty);
-- Ada 2005 (AI-318-02): For a build-in-place call, if the result type has
-- controlled parts, add an actual parameter that is a pointer to
-- appropriate finalization list. The finalization list is that of the
-- current scope, except for "new Acc'(F(...))" in which case it's the
-- finalization list of the access type returned by the allocator. Acc_Type
- -- is that type in the allocator case; Empty otherwise.
+ -- is that type in the allocator case; Empty otherwise. If Sel_Comp is
+ -- not Empty, then it denotes a selected component and the finalization
+ -- list is obtained from the _controller list of the prefix object.
procedure Add_Task_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
procedure Add_Final_List_Actual_To_Build_In_Place_Call
(Function_Call : Node_Id;
Function_Id : Entity_Id;
- Acc_Type : Entity_Id)
+ Acc_Type : Entity_Id;
+ Sel_Comp : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (Function_Call);
Final_List : Node_Id;
Final_List_Actual : Node_Id;
Final_List_Formal : Node_Id;
+ Is_Ctrl_Result : constant Boolean :=
+ Needs_Finalization
+ (Underlying_Type (Etype (Function_Id)));
begin
-- No such extra parameter is needed if there are no controlled parts.
- -- The test for Controlled_Type accounts for class-wide results (which
- -- potentially have controlled parts, even if the root type doesn't),
- -- and the test for a tagged result type is needed because calls to
- -- such a function can in general occur in dispatching contexts, which
- -- must be treated the same as a call to class-wide functions. Both of
- -- these situations require that a finalization list be passed.
-
- if not Controlled_Type (Underlying_Type (Etype (Function_Id)))
- and then not Is_Tagged_Type (Underlying_Type (Etype (Function_Id)))
- then
+ -- The test for Needs_Finalization accounts for class-wide results
+ -- (which potentially have controlled parts, even if the root type
+ -- doesn't), and the test for a tagged result type is needed because
+ -- calls to such a function can in general occur in dispatching
+ -- contexts, which must be treated the same as a call to class-wide
+ -- functions. Both of these situations require that a finalization list
+ -- be passed.
+
+ if not Needs_BIP_Final_List (Function_Id) then
return;
end if;
Present (Associated_Final_Chain (Base_Type (Acc_Type))))
then
Final_List := Find_Final_List (Acc_Type);
+
+ -- If Sel_Comp is present and the function result is controlled, then
+ -- the finalization list will be obtained from the _controller list of
+ -- the selected component's prefix object.
+
+ elsif Present (Sel_Comp) and then Is_Ctrl_Result then
+ Final_List := Find_Final_List (Current_Scope, Sel_Comp);
+
else
Final_List := Find_Final_List (Current_Scope);
end if;
Low_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
- Attribute_name => Name_First),
+ Attribute_Name => Name_First),
High_Bound =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var, Loc),
-- formal subtype are not the same, requiring a check.
-- It is necessary to exclude tagged types because of "downward
- -- conversion" errors and a strange assertion error in namet
- -- from gnatf in bug 1215-001 ???
+ -- conversion" errors.
elsif Is_Access_Type (E_Formal)
and then not Same_Type (E_Formal, Etype (Actual))
-- This procedure handles expansion of function calls and procedure call
-- statements (i.e. it serves as the body for Expand_N_Function_Call and
- -- Expand_N_Procedure_Call_Statement. Processing for calls includes:
+ -- Expand_N_Procedure_Call_Statement). Processing for calls includes:
- -- Replace call to Raise_Exception by Raise_Exception always if possible
+ -- Replace call to Raise_Exception by Raise_Exception_Always if possible
-- Provide values of actuals for all formals in Extra_Formals list
-- Replace "call" to enumeration literal function by literal itself
-- Rewrite call to predefined operator as operator
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from a non-tagged formal derived
- -- type inherits from the original parent, not from the actual. This is
- -- tested in 4723-003. The current derivation mechanism has the derived
- -- type inherit from the actual, which is only correct outside of the
- -- instance. If the subprogram is inherited, we test for this particular
- -- case through a convoluted tree traversal before setting the proper
- -- subprogram to be called.
+ -- type inherits from the original parent, not from the actual. The
+ -- current derivation mechanism has the derived type inherit from the
+ -- actual, which is only correct outside of the instance. If the
+ -- subprogram is inherited, we test for this particular case through a
+ -- convoluted tree traversal before setting the proper subprogram to be
+ -- called.
--------------------------
-- Add_Actual_Parameter --
-- Replace call to Raise_Exception by call to Raise_Exception_Always
-- if we can tell that the first parameter cannot possibly be null.
- -- This helps optimization and also generation of warnings.
+ -- This improves efficiency by avoiding a run-time test.
-- We do not do this if Raise_Exception_Always does not exist, which
-- can happen in configurable run time profiles which provide only a
- -- Raise_Exception, which is in fact an unconditional raise anyway.
+ -- Raise_Exception.
if Is_RTE (Subp, RE_Raise_Exception)
and then RTE_Available (RE_Raise_Exception_Always)
Prev := Actual;
Prev_Orig := Original_Node (Prev);
- -- The original actual may have been a call written in prefix
- -- form, and rewritten before analysis.
-
- if not Analyzed (Prev_Orig)
- and then Nkind_In (Actual, N_Function_Call, N_Identifier)
- then
- Prev_Orig := Prev;
- end if;
-
-- Ada 2005 (AI-251): Check if any formal is a class-wide interface
-- to expand it in a further round.
if Ekind (Etype (Prev)) in Private_Kind
and then not Has_Discriminants (Base_Type (Etype (Prev)))
then
- Add_Extra_Actual (
- New_Occurrence_Of (Standard_False, Loc),
- Extra_Constrained (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_False, Loc),
+ Extra_Constrained (Formal));
elsif Is_Constrained (Etype (Formal))
or else not Has_Discriminants (Etype (Prev))
then
- Add_Extra_Actual (
- New_Occurrence_Of (Standard_True, Loc),
- Extra_Constrained (Formal));
+ Add_Extra_Actual
+ (New_Occurrence_Of (Standard_True, Loc),
+ Extra_Constrained (Formal));
-- Do not produce extra actuals for Unchecked_Union parameters.
-- Jump directly to the end of the loop.
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
+ Intval => Scope_Depth (Standard_Standard)),
Extra_Accessibility (Formal));
end if;
end;
else
Add_Extra_Actual
(Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
+ Intval => Type_Access_Level (Etype (Prev_Orig))),
Extra_Accessibility (Formal));
end if;
- -- All cases other than thunks
+ -- If the actual is an access discriminant, then pass the level
+ -- of the enclosing object (RM05-3.10.2(12.4/2)).
+
+ elsif Nkind (Prev_Orig) = N_Selected_Component
+ and then Ekind (Entity (Selector_Name (Prev_Orig))) =
+ E_Discriminant
+ and then Ekind (Etype (Entity (Selector_Name (Prev_Orig)))) =
+ E_Anonymous_Access_Type
+ then
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Object_Access_Level (Prefix (Prev_Orig))),
+ Extra_Accessibility (Formal));
+
+ -- All other cases
else
case Nkind (Prev_Orig) is
-- For X'Access, pass on the level of the prefix X
when Attribute_Access =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval =>
- Object_Access_Level (Prefix (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval =>
+ Object_Access_Level (Prefix (Prev_Orig))),
+ Extra_Accessibility (Formal));
-- Treat the unchecked attributes as library-level
when Attribute_Unchecked_Access |
Attribute_Unrestricted_Access =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Scope_Depth (Standard_Standard)),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Standard_Standard)),
+ Extra_Accessibility (Formal));
-- No other cases of attributes returning access
-- values that can be passed to access parameters
-- current scope level.
when N_Allocator =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Scope_Depth (Current_Scope) + 1),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Current_Scope) + 1),
+ Extra_Accessibility (Formal));
- -- For other cases we simply pass the level of the
- -- actual's access type.
+ -- For other cases we simply pass the level of the actual's
+ -- access type. The type is retrieved from Prev rather than
+ -- Prev_Orig, because in some cases Prev_Orig denotes an
+ -- original expression that has not been analyzed.
when others =>
- Add_Extra_Actual (
- Make_Integer_Literal (Loc,
- Intval => Type_Access_Level (Etype (Prev_Orig))),
- Extra_Accessibility (Formal));
+ Add_Extra_Actual
+ (Make_Integer_Literal (Loc,
+ Intval => Type_Access_Level (Etype (Prev))),
+ Extra_Accessibility (Formal));
end case;
end if;
if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
and then Present (Controlling_Argument (N))
- and then VM_Target = No_VM
then
- Expand_Dispatching_Call (N);
+ if VM_Target = No_VM then
+ Expand_Dispatching_Call (N);
- -- The following return is worrisome. Is it really OK to
- -- skip all remaining processing in this procedure ???
+ -- The following return is worrisome. Is it really OK to
+ -- skip all remaining processing in this procedure ???
- return;
+ return;
+
+ -- Expansion of a dispatching call results in an indirect call, which
+ -- in turn causes current values to be killed (see Resolve_Call), so
+ -- on VM targets we do the call here to ensure consistent warnings
+ -- between VM and non-VM targets.
+
+ else
+ Kill_Current_Values;
+ end if;
+ end if;
-- Similarly, expand calls to RCI subprograms on which pragma
-- All_Calls_Remote applies. The rewriting will be reanalyzed
-- later. Do this only when the call comes from source since we do
-- not want such a rewriting to occur in expanded code.
- elsif Is_All_Remote_Call (N) then
+ if Is_All_Remote_Call (N) then
Expand_All_Calls_Remote_Subprogram_Call (N);
-- Similarly, do not add extra actuals for an entry call whose entity
("cannot call abstract subprogram &!", Name (N), Parent_Subp);
end if;
- -- Add an explicit conversion for parameter of the derived type.
- -- This is only done for scalar and access in-parameters. Others
- -- have been expanded in expand_actuals.
+ -- Inspect all formals of derived subprogram Subp. Compare parameter
+ -- types with the parent subprogram and check whether an actual may
+ -- need a type conversion to the corresponding formal of the parent
+ -- subprogram.
- Formal := First_Formal (Subp);
- Parent_Formal := First_Formal (Parent_Subp);
- Actual := First_Actual (N);
-
- -- It is not clear that conversion is needed for intrinsic
- -- subprograms, but it certainly is for those that are user-
- -- defined, and that can be inherited on derivation, namely
- -- unchecked conversion and deallocation.
- -- General case needs study ???
+ -- Not clear whether intrinsic subprograms need such conversions. ???
if not Is_Intrinsic_Subprogram (Parent_Subp)
or else Is_Generic_Instance (Parent_Subp)
then
- while Present (Formal) loop
- if Etype (Formal) /= Etype (Parent_Formal)
- and then Is_Scalar_Type (Etype (Formal))
- and then Ekind (Formal) = E_In_Parameter
- and then
- not Subtypes_Statically_Match
- (Etype (Parent_Formal), Etype (Actual))
- and then not Raises_Constraint_Error (Actual)
- then
- Rewrite (Actual,
- OK_Convert_To (Etype (Parent_Formal),
- Relocate_Node (Actual)));
+ declare
+ procedure Convert (Act : Node_Id; Typ : Entity_Id);
+ -- Rewrite node Act as a type conversion of Act to Typ. Analyze
+ -- and resolve the newly generated construct.
- Analyze (Actual);
- Resolve (Actual, Etype (Parent_Formal));
- Enable_Range_Check (Actual);
+ -------------
+ -- Convert --
+ -------------
- elsif Is_Access_Type (Etype (Formal))
- and then Base_Type (Etype (Parent_Formal)) /=
- Base_Type (Etype (Actual))
- then
- if Ekind (Formal) /= E_In_Parameter then
- Rewrite (Actual,
- Convert_To (Etype (Parent_Formal),
- Relocate_Node (Actual)));
-
- Analyze (Actual);
- Resolve (Actual, Etype (Parent_Formal));
-
- elsif
- Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type
- and then Designated_Type (Etype (Parent_Formal))
- /=
- Designated_Type (Etype (Actual))
- and then not Is_Controlling_Formal (Formal)
+ procedure Convert (Act : Node_Id; Typ : Entity_Id) is
+ begin
+ Rewrite (Act, OK_Convert_To (Typ, Relocate_Node (Act)));
+ Analyze (Act);
+ Resolve (Act, Typ);
+ end Convert;
+
+ -- Local variables
+
+ Actual_Typ : Entity_Id;
+ Formal_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+
+ begin
+ Actual := First_Actual (N);
+ Formal := First_Formal (Subp);
+ Parent_Formal := First_Formal (Parent_Subp);
+ while Present (Formal) loop
+ Actual_Typ := Etype (Actual);
+ Formal_Typ := Etype (Formal);
+ Parent_Typ := Etype (Parent_Formal);
+
+ -- For an IN parameter of a scalar type, the parent formal
+ -- type and derived formal type differ or the parent formal
+ -- type and actual type do not match statically.
+
+ if Is_Scalar_Type (Formal_Typ)
+ and then Ekind (Formal) = E_In_Parameter
+ and then Formal_Typ /= Parent_Typ
+ and then
+ not Subtypes_Statically_Match (Parent_Typ, Actual_Typ)
+ and then not Raises_Constraint_Error (Actual)
+ then
+ Convert (Actual, Parent_Typ);
+ Enable_Range_Check (Actual);
+
+ -- For access types, the parent formal type and actual type
+ -- differ.
+
+ elsif Is_Access_Type (Formal_Typ)
+ and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
then
- -- This unchecked conversion is not necessary unless
- -- inlining is enabled, because in that case the type
- -- mismatch may become visible in the body about to be
- -- inlined.
+ if Ekind (Formal) /= E_In_Parameter then
+ Convert (Actual, Parent_Typ);
- Rewrite (Actual,
- Unchecked_Convert_To (Etype (Parent_Formal),
- Relocate_Node (Actual)));
+ elsif Ekind (Parent_Typ) = E_Anonymous_Access_Type
+ and then Designated_Type (Parent_Typ) /=
+ Designated_Type (Actual_Typ)
+ and then not Is_Controlling_Formal (Formal)
+ then
+ -- This unchecked conversion is not necessary unless
+ -- inlining is enabled, because in that case the type
+ -- mismatch may become visible in the body about to be
+ -- inlined.
+
+ Rewrite (Actual,
+ Unchecked_Convert_To (Parent_Typ,
+ Relocate_Node (Actual)));
+
+ Analyze (Actual);
+ Resolve (Actual, Parent_Typ);
+ end if;
- Analyze (Actual);
- Resolve (Actual, Etype (Parent_Formal));
+ -- For array and record types, the parent formal type and
+ -- derived formal type have different sizes or pragma Pack
+ -- status.
+
+ elsif ((Is_Array_Type (Formal_Typ)
+ and then Is_Array_Type (Parent_Typ))
+ or else
+ (Is_Record_Type (Formal_Typ)
+ and then Is_Record_Type (Parent_Typ)))
+ and then
+ (Esize (Formal_Typ) /= Esize (Parent_Typ)
+ or else Has_Pragma_Pack (Formal_Typ) /=
+ Has_Pragma_Pack (Parent_Typ))
+ then
+ Convert (Actual, Parent_Typ);
end if;
- end if;
- Next_Formal (Formal);
- Next_Formal (Parent_Formal);
- Next_Actual (Actual);
- end loop;
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ Next_Formal (Parent_Formal);
+ end loop;
+ end;
end if;
Orig_Subp := Subp;
-- Handle case of access to protected subprogram type
if Is_Access_Protected_Subprogram_Type
- (Base_Type (Etype (Prefix (Name (N)))))
+ (Base_Type (Etype (Prefix (Name (N)))))
then
-- If this is a call through an access to protected operation,
-- the prefix has the form (object'address, operation'access).
-- If the return type is limited the context is an initialization
-- and different processing applies.
- if Controlled_Type (Etype (Subp))
+ if Needs_Finalization (Etype (Subp))
and then not Is_Inherently_Limited_Type (Etype (Subp))
and then not Is_Limited_Interface (Etype (Subp))
then
end if;
end;
end if;
-
- -- Special processing for Ada 2005 AI-329, which requires a call to
- -- Raise_Exception to raise Constraint_Error if the Exception_Id is
- -- null. Note that we never need to do this in GNAT mode, or if the
- -- parameter to Raise_Exception is a use of Identity, since in these
- -- cases we know that the parameter is never null.
-
- -- Note: We must check that the node has not been inlined. This is
- -- required because under zfp the Raise_Exception subprogram has the
- -- pragma inline_always (and hence the call has been expanded above
- -- into a block containing the code of the subprogram).
-
- if Ada_Version >= Ada_05
- and then not GNAT_Mode
- and then Is_RTE (Subp, RE_Raise_Exception)
- and then Nkind (N) = N_Procedure_Call_Statement
- and then (Nkind (First_Actual (N)) /= N_Attribute_Reference
- or else Attribute_Name (First_Actual (N)) /= Name_Identity)
- then
- declare
- RCE : constant Node_Id :=
- Make_Raise_Constraint_Error (Loc,
- Reason => CE_Null_Exception_Id);
- begin
- Insert_After (N, RCE);
- Analyze (RCE);
- end;
- end if;
end Expand_Call;
--------------------------
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Set_Is_Internal (Temp);
- -- For the unconstrained case. the generated temporary has the
+ -- For the unconstrained case, the generated temporary has the
-- same constrained declaration as the result variable.
-- It may eventually be possible to remove that temporary and
-- use the result variable directly.
procedure Expand_N_Function_Call (N : Node_Id) is
begin
Expand_Call (N);
+
+ -- If the return value of a foreign compiled function is
+ -- VAX Float then expand the return (adjusts the location
+ -- of the return value on Alpha/VMS, noop everywhere else).
+ -- Comes_From_Source intercepts recursive expansion.
+
+ if Vax_Float (Etype (N))
+ and then Nkind (N) = N_Function_Call
+ and then Present (Name (N))
+ and then Present (Entity (Name (N)))
+ and then Has_Foreign_Convention (Entity (Name (N)))
+ and then Comes_From_Source (Parent (N))
+ then
+ Expand_Vax_Foreign_Return (N);
+ end if;
end Expand_N_Function_Call;
---------------------------------------
Loc : constant Source_Ptr := Sloc (N);
H : constant Node_Id := Handled_Statement_Sequence (N);
Body_Id : Entity_Id;
- Spec_Id : Entity_Id;
Except_H : Node_Id;
- Scop : Entity_Id;
- Dec : Node_Id;
- Next_Op : Node_Id;
L : List_Id;
+ Spec_Id : Entity_Id;
procedure Add_Return (S : List_Id);
-- Append a return statement to the statement sequence S if the last
if Is_Scalar_Type (Etype (F))
and then Ekind (F) = E_Out_Parameter
then
+ Check_Restriction (No_Default_Initialization, F);
+
-- Insert the initialization. We turn off validity checks
-- for this assignment, since we do not want any check on
-- the initial value itself (which may well be invalid).
Insert_Before_And_Analyze (First (L),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (F, Loc),
- Expression => Get_Simple_Init_Val (Etype (F), Loc)),
+ Expression => Get_Simple_Init_Val (Etype (F), N)),
Suppress => Validity_Check);
end if;
end;
end if;
- Scop := Scope (Spec_Id);
-
- -- Add discriminal renamings to protected subprograms. Install new
- -- discriminals for expansion of the next subprogram of this protected
- -- type, if any.
-
- if Is_List_Member (N)
- and then Present (Parent (List_Containing (N)))
- and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
- then
- Add_Discriminal_Declarations
- (Declarations (N), Scop, Name_uObject, Loc);
- Add_Private_Declarations
- (Declarations (N), Scop, Name_uObject, Loc);
-
- -- Associate privals and discriminals with the next protected
- -- operation body to be expanded. These are used to expand references
- -- to private data objects and discriminants, respectively.
-
- Next_Op := Next_Protected_Operation (N);
-
- if Present (Next_Op) then
- Dec := Parent (Base_Type (Scop));
- Set_Privals (Dec, Next_Op, Loc);
- Set_Discriminals (Dec);
- end if;
- end if;
-
-- Clear out statement list for stubbed procedure
if Present (Corresponding_Spec (N)) then
end if;
end if;
+ -- Create a set of discriminals for the next protected subprogram body
+
+ if Is_List_Member (N)
+ and then Present (Parent (List_Containing (N)))
+ and then Nkind (Parent (List_Containing (N))) = N_Protected_Body
+ and then Present (Next_Protected_Operation (N))
+ then
+ Set_Discriminals (Parent (Base_Type (Scope (Spec_Id))));
+ end if;
+
-- Returns_By_Ref flag is normally set when the subprogram is frozen
-- but subprograms with no specs are not frozen.
elsif Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Spec_Id);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Spec_Id);
end if;
end;
Detect_Infinite_Recursion (N, Spec_Id);
end if;
- -- Finally, if we are in Normalize_Scalars mode, then any scalar out
- -- parameters must be initialized to the appropriate default value.
-
- if Ekind (Spec_Id) = E_Procedure and then Normalize_Scalars then
- declare
- Floc : Source_Ptr;
- Formal : Entity_Id;
- Stm : Node_Id;
-
- begin
- Formal := First_Formal (Spec_Id);
- while Present (Formal) loop
- Floc := Sloc (Formal);
-
- if Ekind (Formal) = E_Out_Parameter
- and then Is_Scalar_Type (Etype (Formal))
- then
- Stm :=
- Make_Assignment_Statement (Floc,
- Name => New_Occurrence_Of (Formal, Floc),
- Expression =>
- Get_Simple_Init_Val (Etype (Formal), Floc));
- Prepend (Stm, Declarations (N));
- Analyze (Stm);
- end if;
-
- Next_Formal (Formal);
- end loop;
- end;
- end if;
-
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
-- which denotes the enclosing protected object. If the enclosing
-- operation is an entry, we are immediately within the protected body,
-- and we can retrieve the object from the service entries procedure. A
- -- barrier function has has the same signature as an entry. A barrier
+ -- barrier function has the same signature as an entry. A barrier
-- function is compiled within the protected object, but unlike
-- protected operations its never needs locks, so that its protected
-- body subprogram points to itself.
Tagged_Typ := Find_Dispatching_Type (Prim);
if No (Access_Disp_Table (Tagged_Typ))
- or else not Has_Abstract_Interfaces (Tagged_Typ)
+ or else not Has_Interfaces (Tagged_Typ)
or else not RTE_Available (RE_Interface_Tag)
or else Restriction_Active (No_Dispatching_Calls)
then
New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
Position => DT_Position (Prim),
Address_Node =>
- Unchecked_Convert_To (RTE (RE_Address),
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Thunk_Id, Loc),
Attribute_Name => Name_Unrestricted_Access))),
Loc),
Position => DT_Position (Prim),
Address_Node =>
- Unchecked_Convert_To (RTE (RE_Address),
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access)))));
-- table slot.
if not Is_Interface (Typ)
- or else Present (Abstract_Interface_Alias (Subp))
+ or else Present (Interface_Alias (Subp))
then
if Is_Predefined_Dispatching_Operation (Subp) then
Register_Predefined_DT_Entry (Subp);
begin
if Is_Inherently_Limited_Type (Typ) then
Set_Returns_By_Ref (Subp);
- elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then
+ elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Subp);
end if;
end;
end if;
end Make_Build_In_Place_Call_In_Anonymous_Context;
- ---------------------------------------------------
+ --------------------------------------------
-- Make_Build_In_Place_Call_In_Assignment --
- ---------------------------------------------------
+ --------------------------------------------
procedure Make_Build_In_Place_Call_In_Assignment
(Assign : Node_Id;
Add_Alloc_Form_Actual_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- Add_Final_List_Actual_To_Build_In_Place_Call
- (Func_Call, Function_Id, Acc_Type => Empty);
+ -- If Lhs is a selected component, then pass it along so that its prefix
+ -- object will be used as the source of the finalization list.
+
+ if Nkind (Lhs) = N_Selected_Component then
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty, Sel_Comp => Lhs);
+ else
+ Add_Final_List_Actual_To_Build_In_Place_Call
+ (Func_Call, Function_Id, Acc_Type => Empty);
+ end if;
Add_Task_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster));
if Is_Constrained (Underlying_Type (Result_Subt)) then
Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
else
- Insert_Before_And_Analyze (Object_Decl, Ptr_Typ_Decl);
+ Insert_Action (Object_Decl, Ptr_Typ_Decl);
end if;
-- Finally, create an access object initialized to a reference to the
end if;
end Make_Build_In_Place_Call_In_Object_Declaration;
+ --------------------------
+ -- Needs_BIP_Final_List --
+ --------------------------
+
+ function Needs_BIP_Final_List (E : Entity_Id) return Boolean is
+ pragma Assert (Is_Build_In_Place_Function (E));
+ Result_Subt : constant Entity_Id := Underlying_Type (Etype (E));
+
+ begin
+ -- We need the BIP_Final_List if the result type needs finalization. We
+ -- also need it for tagged types, even if not class-wide, because some
+ -- type extension might need finalization, and all overriding functions
+ -- must have the same calling conventions. However, if there is a
+ -- pragma Restrictions (No_Finalization), we never need this parameter.
+
+ return (Needs_Finalization (Result_Subt)
+ or else Is_Tagged_Type (Underlying_Type (Result_Subt)))
+ and then not Restriction_Active (No_Finalization);
+ end Needs_BIP_Final_List;
+
end Exp_Ch6;
OSDN Git Service
