-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
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),
begin
loop
Set_Analyzed (Pfx, False);
- exit when Nkind (Pfx) /= N_Selected_Component
- and then Nkind (Pfx) /= N_Indexed_Component;
+ exit when
+ not Nkind_In (Pfx, N_Selected_Component, N_Indexed_Component);
Pfx := Prefix (Pfx);
end loop;
end Reset_Packed_Prefix;
-- 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))
P : constant Node_Id := Parent (N);
begin
- pragma Assert (Nkind (P) = N_Triggering_Alternative
- or else Nkind (P) = N_Entry_Call_Alternative);
+ pragma Assert (Nkind_In (P, N_Triggering_Alternative,
+ N_Entry_Call_Alternative));
if Is_Non_Empty_List (Statements (P)) then
Insert_List_Before_And_Analyze
-- 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 (Actual) = N_Function_Call
- or else
- Nkind (Actual) = 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.
-- as out parameter actuals on calls to stream procedures.
Act_Prev := Prev;
- while Nkind (Act_Prev) = N_Type_Conversion
- or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
+ while Nkind_In (Act_Prev, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
loop
Act_Prev := Expression (Act_Prev);
end 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;
then
null;
- elsif Nkind (Prev) = N_Allocator
- or else Nkind (Prev) = N_Attribute_Reference
- then
+ elsif Nkind_In (Prev, N_Allocator, N_Attribute_Reference) then
null;
-- Suppress null checks when passing to access parameters of Java
begin
Nod := Actual;
- while Nkind (Nod) = N_Indexed_Component
- or else
- Nkind (Nod) = N_Selected_Component
+ while Nkind_In (Nod, N_Indexed_Component,
+ N_Selected_Component)
loop
Set_Analyzed (Nod, False);
Nod := Prefix (Nod);
Sav : Node_Id;
begin
- -- For an OUT parameter that is an assignable entity, we do not
- -- want to clobber the Last_Assignment field, since if it is
- -- set, it was precisely because it is indeed an OUT parameter!
-
- if Ekind (Formal) = E_Out_Parameter
+ -- For an OUT or IN OUT parameter that is an assignable entity,
+ -- we do not want to clobber the Last_Assignment field, since
+ -- if it is set, it was precisely because it is indeed an OUT
+ -- or IN OUT parameter!
+
+ if (Ekind (Formal) = E_Out_Parameter
+ or else
+ Ekind (Formal) = E_In_Out_Parameter)
and then Is_Assignable (Ent)
then
Sav := Last_Assignment (Ent);
-- Ada 2005 (AI-251): If some formal is a class-wide interface, expand
-- it to point to the correct secondary virtual table
- if (Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement)
+ if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
and then CW_Interface_Formals_Present
then
Expand_Interface_Actuals (N);
-- the VM back-ends directly handle the generation of dispatching
-- calls and would have to undo any expansion to an indirect call.
- if (Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement)
+ 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 rewritting to occur in expanded code.
+ -- 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
- -- 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.
+ Convert (Actual, Parent_Typ);
+ Enable_Range_Check (Actual);
+
+ -- For access types, the parent formal type and actual type
+ -- differ.
- Rewrite (Actual,
- Unchecked_Convert_To (Etype (Parent_Formal),
- Relocate_Node (Actual)));
+ elsif Is_Access_Type (Formal_Typ)
+ and then Base_Type (Parent_Typ) /= Base_Type (Actual_Typ)
+ then
+ if Ekind (Formal) /= E_In_Parameter then
+ Convert (Actual, Parent_Typ);
- Analyze (Actual);
- Resolve (Actual, Etype (Parent_Formal));
+ 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;
+
+ -- 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 (In_Extended_Main_Code_Unit (N)
or else In_Extended_Main_Code_Unit (Parent (N))
- or else Is_Always_Inlined (Subp))
+ or else Has_Pragma_Inline_Always (Subp))
and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
or else
Earlier_In_Extended_Unit (Sloc (Bod), Loc))
-- 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
-- If no arguments, delete entire list, this is the easy case
if No (Last_Keep_Arg) then
- while Is_Non_Empty_List (Parameter_Associations (N)) loop
- Delete_Tree (Remove_Head (Parameter_Associations (N)));
- end loop;
-
Set_Parameter_Associations (N, No_List);
Set_First_Named_Actual (N, Empty);
elsif Is_List_Member (Last_Keep_Arg) then
while Present (Next (Last_Keep_Arg)) loop
- Delete_Tree (Remove_Next (Last_Keep_Arg));
+ Discard_Node (Remove_Next (Last_Keep_Arg));
end loop;
Set_First_Named_Actual (N, Empty);
exit when No (Temp);
Set_Next_Named_Actual
(Passoc, Next_Named_Actual (Parent (Temp)));
- Delete_Tree (Temp);
end loop;
end;
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;
--------------------------
-- Because of the presence of private types, the views of the
-- expression and the context may be different, so place an
-- unchecked conversion to the context type to avoid spurious
- -- errors, eg. when the expression is a numeric literal and
+ -- errors, e.g. when the expression is a numeric literal and
-- the context is private. If the expression is an aggregate,
-- use a qualified expression, because an aggregate is not a
-- legal argument of a conversion.
- if Nkind (Expression (N)) = N_Aggregate
- or else Nkind (Expression (N)) = N_Null
- then
+ if Nkind_In (Expression (N), N_Aggregate, N_Null) then
Ret :=
Make_Qualified_Expression (Sloc (N),
Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
-- not be posting warnings on the inlined body so it is unneeded.
elsif Nkind (N) = N_Pragma
- and then Chars (N) = Name_Unreferenced
+ and then Pragma_Name (N) = Name_Unreferenced
then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return OK;
and then Formal_Is_Used_Once (F))
or else
- ((Nkind (A) = N_Real_Literal or else
- Nkind (A) = N_Integer_Literal or else
- Nkind (A) = N_Character_Literal)
- and then not Address_Taken (F))
+ (Nkind_In (A, N_Real_Literal,
+ N_Integer_Literal,
+ N_Character_Literal)
+ and then not Address_Taken (F))
then
if Etype (F) /= Etype (A) then
Set_Renamed_Object
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
- Typ : constant Entity_Id := Etype (N);
-
- function Returned_By_Reference return Boolean;
- -- If the return type is returned through the secondary stack; that is
- -- by reference, we don't want to create a temp to force stack checking.
- -- ???"sec stack" is not right -- Ada 95 return-by-reference object are
- -- returned wherever they are.
- -- Shouldn't this function be moved to exp_util???
-
- function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean;
- -- If the call is the right side of an assignment or the expression in
- -- an object declaration, we don't need to create a temp as the left
- -- side will already trigger stack checking if necessary.
- --
- -- If the call is a component in an extension aggregate, it will be
- -- expanded into assignments as well, so no temporary is needed. This
- -- also solves the problem of functions returning types with unknown
- -- discriminants, where it is not possible to declare an object of the
- -- type altogether.
-
- ---------------------------
- -- Returned_By_Reference --
- ---------------------------
-
- function Returned_By_Reference return Boolean is
- S : Entity_Id;
-
- begin
- if Is_Inherently_Limited_Type (Typ) then
- return True;
-
- elsif Nkind (Parent (N)) /= N_Simple_Return_Statement then
- return False;
-
- elsif Requires_Transient_Scope (Typ) then
-
- -- Verify that the return type of the enclosing function has the
- -- same constrained status as that of the expression.
-
- S := Current_Scope;
- while Ekind (S) /= E_Function loop
- S := Scope (S);
- end loop;
-
- return Is_Constrained (Typ) = Is_Constrained (Etype (S));
- else
- return False;
- end if;
- end Returned_By_Reference;
-
- ---------------------------
- -- Rhs_Of_Assign_Or_Decl --
- ---------------------------
-
- function Rhs_Of_Assign_Or_Decl (N : Node_Id) return Boolean is
- begin
- if (Nkind (Parent (N)) = N_Assignment_Statement
- and then Expression (Parent (N)) = N)
- or else
- (Nkind (Parent (N)) = N_Qualified_Expression
- and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
- and then Expression (Parent (Parent (N))) = Parent (N))
- or else
- (Nkind (Parent (N)) = N_Object_Declaration
- and then Expression (Parent (N)) = N)
- or else
- (Nkind (Parent (N)) = N_Component_Association
- and then Expression (Parent (N)) = N
- and then Nkind (Parent (Parent (N))) = N_Aggregate
- and then Rhs_Of_Assign_Or_Decl (Parent (Parent (N))))
- or else
- (Nkind (Parent (N)) = N_Extension_Aggregate
- and then Is_Private_Type (Etype (Typ)))
- then
- return True;
- else
- return False;
- end if;
- end Rhs_Of_Assign_Or_Decl;
-
- -- Start of processing for Expand_N_Function_Call
-
begin
- -- A special check. If stack checking is enabled, and the return type
- -- might generate a large temporary, and the call is not the right side
- -- of an assignment, then generate an explicit temporary. We do this
- -- because otherwise gigi may generate a large temporary on the fly and
- -- this can cause trouble with stack checking.
-
- -- This is unnecessary if the call is the expression in an object
- -- declaration, or if it appears outside of any library unit. This can
- -- only happen if it appears as an actual in a library-level instance,
- -- in which case a temporary will be generated for it once the instance
- -- itself is installed.
-
- if May_Generate_Large_Temp (Typ)
- and then not Rhs_Of_Assign_Or_Decl (N)
- and then not Returned_By_Reference
- and then Current_Scope /= Standard_Standard
- then
- if Stack_Checking_Enabled then
-
- -- Note: it might be thought that it would be OK to use a call to
- -- Force_Evaluation here, but that's not good enough, because
- -- that can results in a 'Reference construct that may still need
- -- a temporary.
-
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Temp_Obj : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('F'));
- Temp_Typ : Entity_Id := Typ;
- Decl : Node_Id;
- A : Node_Id;
- F : Entity_Id;
- Proc : Entity_Id;
-
- begin
- if Is_Tagged_Type (Typ)
- and then Present (Controlling_Argument (N))
- then
- if Nkind (Parent (N)) /= N_Procedure_Call_Statement
- and then Nkind (Parent (N)) /= N_Function_Call
- then
- -- If this is a tag-indeterminate call, the object must
- -- be classwide.
-
- if Is_Tag_Indeterminate (N) then
- Temp_Typ := Class_Wide_Type (Typ);
- end if;
-
- else
- -- If this is a dispatching call that is itself the
- -- controlling argument of an enclosing call, the
- -- nominal subtype of the object that replaces it must
- -- be classwide, so that dispatching will take place
- -- properly. If it is not a controlling argument, the
- -- object is not classwide.
-
- Proc := Entity (Name (Parent (N)));
-
- F := First_Formal (Proc);
- A := First_Actual (Parent (N));
- while A /= N loop
- Next_Formal (F);
- Next_Actual (A);
- end loop;
-
- if Is_Controlling_Formal (F) then
- Temp_Typ := Class_Wide_Type (Typ);
- end if;
- end if;
- end if;
-
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Obj,
- Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
- Constant_Present => True,
- Expression => Relocate_Node (N));
- Set_Assignment_OK (Decl);
-
- Insert_Actions (N, New_List (Decl));
- Rewrite (N, New_Occurrence_Of (Temp_Obj, Loc));
- end;
-
- else
- -- If stack-checking is not enabled, increment serial number
- -- for internal names, so that subsequent symbols are consistent
- -- with and without stack-checking.
-
- Synchronize_Serial_Number;
-
- -- Now we can expand the call with consistent symbol names
-
- Expand_Call (N);
- end if;
-
- -- Normal case, expand the call
+ Expand_Call (N);
- else
- 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.
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
- if Nkind (Exp_Node) = N_Qualified_Expression
- or else Nkind (Exp_Node) = N_Unchecked_Type_Conversion
+ if Nkind_In
+ (Exp_Node, N_Qualified_Expression, N_Unchecked_Type_Conversion)
then
Exp_Node := Expression (N);
end if;
function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is
begin
- if Nkind (N) = N_Simple_Return_Statement
- or else Nkind (N) = N_Extended_Return_Statement
+ if Nkind_In (N, N_Simple_Return_Statement,
+ N_Extended_Return_Statement)
then
return Is_Build_In_Place_Function
(Return_Applies_To (Return_Statement_Entity (N)));
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
return;
end if;
- -- Skip the first access-to-dispatch-table pointer since it leads
- -- to the primary dispatch table. We are only concerned with the
- -- secondary dispatch table pointers. Note that the access-to-
- -- dispatch-table pointer corresponds to the first implemented
- -- interface retrieved below.
+ -- Skip the first two access-to-dispatch-table pointers since they
+ -- leads to the primary dispatch table (predefined DT and user
+ -- defined DT). We are only concerned with the secondary dispatch
+ -- table pointers. Note that the access-to- dispatch-table pointer
+ -- corresponds to the first implemented interface retrieved below.
Iface_DT_Ptr :=
- Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)));
+ Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ))));
while Present (Iface_DT_Ptr)
and then Ekind (Node (Iface_DT_Ptr)) = E_Constant
loop
+ pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Code) then
- Insert_Actions (N, New_List (
+ Insert_Actions_After (N, New_List (
Thunk_Code,
Build_Set_Predefined_Prim_Op_Address (Loc,
- Tag_Node => New_Reference_To (Node (Iface_DT_Ptr), Loc),
+ Tag_Node =>
+ New_Reference_To (Node (Next_Elmt (Iface_DT_Ptr)), Loc),
Position => DT_Position (Prim),
Address_Node =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Thunk_Id, Loc),
- Attribute_Name => Name_Address))));
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Thunk_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access))),
+
+ Build_Set_Predefined_Prim_Op_Address (Loc,
+ Tag_Node =>
+ New_Reference_To
+ (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))),
+ Loc),
+ Position => DT_Position (Prim),
+ Address_Node =>
+ Unchecked_Convert_To (RTE (RE_Prim_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Prim, Loc),
+ Attribute_Name => Name_Unrestricted_Access)))));
end if;
+ -- Skip the tag of the predefined primitives dispatch table
+
+ Next_Elmt (Iface_DT_Ptr);
+ pragma Assert (Has_Thunks (Node (Iface_DT_Ptr)));
+
+ -- Skip the tag of the no-thunks dispatch table
+
+ Next_Elmt (Iface_DT_Ptr);
+ pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
+
+ -- Skip the tag of the predefined primitives no-thunks dispatch
+ -- table
+
+ Next_Elmt (Iface_DT_Ptr);
+ pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr)));
+
Next_Elmt (Iface_DT_Ptr);
end loop;
end Register_Predefined_DT_Entry;
Subp : constant Entity_Id := Entity (N);
+ -- Start of processing for Freeze_Subprogram
+
begin
-- We suppress the initialization of the dispatch table entry when
-- VM_Target because the dispatching mechanism is handled internally
Typ : constant Entity_Id := Scope (DTC_Entity (Subp));
begin
- -- Handle private overriden primitives
+ -- Handle private overridden primitives
if not Is_CPP_Class (Typ) then
Check_Overriding_Operation (Subp);
-- 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;
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
- if Nkind (Func_Call) = N_Qualified_Expression
- or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ if Nkind_In (Func_Call,
+ N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
then
Func_Call := Expression (Func_Call);
end if;
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
- if Nkind (Func_Call) = N_Qualified_Expression
- or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ if Nkind_In (Func_Call, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
then
Func_Call := Expression (Func_Call);
end if;
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;
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
- if Nkind (Func_Call) = N_Qualified_Expression
- or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ if Nkind_In (Func_Call, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
then
Func_Call := Expression (Func_Call);
end if;
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));
-- Step past qualification or unchecked conversion (the latter can occur
-- in cases of calls to 'Input).
- if Nkind (Func_Call) = N_Qualified_Expression
- or else Nkind (Func_Call) = N_Unchecked_Type_Conversion
+ if Nkind_In (Func_Call, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
then
Func_Call := Expression (Func_Call);
end if;
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
-- If the object entity has a class-wide Etype, then we need to change
-- it to the result subtype of the function call, because otherwise the
- -- object will be class-wide without an explicit intialization and won't
- -- be allocated properly by the back end. It seems unclean to make such
- -- a revision to the type at this point, and we should try to improve
- -- this treatment when build-in-place functions with class-wide results
- -- are implemented. ???
+ -- object will be class-wide without an explicit initialization and
+ -- won't be allocated properly by the back end. It seems unclean to make
+ -- such a revision to the type at this point, and we should try to
+ -- improve this treatment when build-in-place functions with class-wide
+ -- results are implemented. ???
if Is_Class_Wide_Type (Etype (Defining_Identifier (Object_Decl))) then
Set_Etype (Defining_Identifier (Object_Decl), Result_Subt);
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
