with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
-- or upper bounds at compile time and compare them.
else
- Cresult := Compile_Time_Compare (Left_Lo, Right_Lo);
+ Cresult :=
+ Compile_Time_Compare
+ (Left_Lo, Right_Lo, Assume_Valid => True);
if Cresult = Unknown then
- Cresult := Compile_Time_Compare (Left_Hi, Right_Hi);
+ Cresult :=
+ Compile_Time_Compare
+ (Left_Hi, Right_Hi, Assume_Valid => True);
end if;
case Cresult is
end if;
end if;
- -- If after that analysis, Forwards_OK is still True, and
- -- Loop_Required is False, meaning that we have not discovered some
- -- non-overlap reason for requiring a loop, then we can still let
- -- gigi handle it.
+ -- If after that analysis Loop_Required is False, meaning that we
+ -- have not discovered some non-overlap reason for requiring a loop,
+ -- then the outcome depends on the capabilities of the back end.
if not Loop_Required then
- -- Assume gigi can handle it if Forwards_OK is set
+ -- The GCC back end can deal with all cases of overlap by falling
+ -- back to memmove if it cannot use a more efficient approach.
- if Forwards_OK (N) then
+ if VM_Target = No_VM and not AAMP_On_Target then
+ return;
+
+ -- Assume other back ends can handle it if Forwards_OK is set
+
+ elsif Forwards_OK (N) then
return;
-- If Forwards_OK is not set, the back end will need something
-- Cases where either Forwards_OK or Backwards_OK is true
if Forwards_OK (N) or else Backwards_OK (N) then
- if Controlled_Type (Component_Type (L_Type))
+ if Needs_Finalization (Component_Type (L_Type))
and then Base_Type (L_Type) = Base_Type (R_Type)
and then Ndim = 1
and then not No_Ctrl_Actions (N)
then
declare
- Proc : constant Entity_Id :=
- TSS (Base_Type (L_Type), TSS_Slice_Assign);
+ Proc : constant Entity_Id :=
+ TSS (Base_Type (L_Type), TSS_Slice_Assign);
Actuals : List_Id;
begin
-- conversions ???
else
- -- Copy the bounds and reset the Analyzed flag, because the
- -- bounds of the index type itself may be universal, and must
- -- must be reaanalyzed to acquire the proper type for Gigi.
+ -- Copy the bounds
Cleft_Lo := New_Copy_Tree (Left_Lo);
Cright_Lo := New_Copy_Tree (Right_Lo);
+
+ -- If the types do not match we add an implicit conversion
+ -- here to ensure proper match
+
+ if Etype (Left_Lo) /= Etype (Right_Lo) then
+ Cright_Lo :=
+ Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo);
+ end if;
+
+ -- Reset the Analyzed flag, because the bounds of the index
+ -- type itself may be universal, and must must be reaanalyzed
+ -- to acquire the proper type for the back end.
+
Set_Analyzed (Cleft_Lo, False);
Set_Analyzed (Cright_Lo, False);
Right_Opnd => Cright_Lo);
end if;
- if Controlled_Type (Component_Type (L_Type))
+ if Needs_Finalization (Component_Type (L_Type))
and then Base_Type (L_Type) = Base_Type (R_Type)
and then Ndim = 1
and then not No_Ctrl_Actions (N)
-- explicit bounds of right and left hand sides.
declare
- Proc : constant Node_Id :=
+ Proc : constant Entity_Id :=
TSS (Base_Type (L_Type), TSS_Slice_Assign);
Actuals : List_Id;
return;
elsif Is_Tagged_Type (Typ)
- or else (Controlled_Type (Typ) and then not Is_Array_Type (Typ))
+ or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ))
then
Tagged_Case : declare
L : List_Id := No_List;
-- If no restrictions on aborts, protect the whole assignment
-- for controlled objects as per 9.8(11).
- if Controlled_Type (Typ)
+ if Needs_Finalization (Typ)
and then Expand_Ctrl_Actions
and then Abort_Allowed
then
Parent (Return_Object_Entity);
Parent_Function : constant Entity_Id :=
Return_Applies_To (Return_Statement_Entity (N));
+ Parent_Function_Typ : constant Entity_Id := Etype (Parent_Function);
Is_Build_In_Place : constant Boolean :=
Is_Build_In_Place_Function (Parent_Function);
Result : Node_Id;
Exp : Node_Id;
+ function Has_Controlled_Parts (Typ : Entity_Id) return Boolean;
+ -- Determine whether type Typ is controlled or contains a controlled
+ -- subcomponent.
+
function Move_Activation_Chain return Node_Id;
-- Construct a call to System.Tasking.Stages.Move_Activation_Chain
-- with parameters:
-- From finalization list of the return statement
-- To finalization list passed in by the caller
+ --------------------------
+ -- Has_Controlled_Parts --
+ --------------------------
+
+ function Has_Controlled_Parts (Typ : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Controlled (Typ)
+ or else Has_Controlled_Component (Typ);
+ end Has_Controlled_Parts;
+
---------------------------
-- Move_Activation_Chain --
---------------------------
-- in the rather obscure case of a select-then-abort statement whose
-- abortable part contains the return statement.
- -- We test the type of the expression as well as the return type
- -- of the function, because the latter may be a class-wide type
- -- which is always treated as controlled, while the expression itself
- -- has to have a definite type. The expression may be absent if a
- -- constrained aggregate has been expanded into component assignments
- -- so we have to check for this as well.
+ -- Check the type of the function to determine whether to move the
+ -- finalization list. A special case arises when processing a simple
+ -- return statement which has been rewritten as an extended return.
+ -- In that case check the type of the returned object or the original
+ -- expression.
if Is_Build_In_Place
- and then Controlled_Type (Etype (Parent_Function))
+ and then
+ (Has_Controlled_Parts (Parent_Function_Typ)
+ or else (Is_Class_Wide_Type (Parent_Function_Typ)
+ and then
+ Has_Controlled_Parts (Root_Type (Parent_Function_Typ)))
+ or else Has_Controlled_Parts (Etype (Return_Object_Entity))
+ or else (Present (Exp)
+ and then Has_Controlled_Parts (Etype (Exp))))
then
- if not Is_Class_Wide_Type (Etype (Parent_Function))
- or else
- (Present (Exp)
- and then Controlled_Type (Etype (Exp)))
- then
- Append_To (Statements, Move_Final_List);
- end if;
+ Append_To (Statements, Move_Final_List);
end if;
-- Similarly to the above Move_Final_List, if the result type
Expression =>
New_Copy_Tree (Return_Obj_Expr)));
- SS_Allocator := New_Copy_Tree (Heap_Allocator);
-
else
-- If the function returns a class-wide type we cannot
-- use the return type for the allocator. Instead we
if Is_Class_Wide_Type (Return_Obj_Typ) then
Heap_Allocator :=
Make_Allocator (Loc,
- New_Reference_To
- (Etype (Return_Obj_Expr), Loc));
+ Expression =>
+ New_Reference_To
+ (Etype (Return_Obj_Expr), Loc));
else
Heap_Allocator :=
Make_Allocator (Loc,
- New_Reference_To (Return_Obj_Typ, Loc));
+ Expression =>
+ New_Reference_To (Return_Obj_Typ, Loc));
end if;
-- If the object requires default initialization then
-- then the object will be default initialized twice.
Set_No_Initialization (Heap_Allocator);
-
- SS_Allocator := New_Copy_Tree (Heap_Allocator);
end if;
-- If the No_Allocators restriction is active, then only
-- an allocator for secondary stack allocation is needed.
+ -- It's OK for such allocators to have Comes_From_Source
+ -- set to False, because gigi knows not to flag them as
+ -- being a violation of No_Implicit_Heap_Allocations.
if Restriction_Active (No_Allocators) then
SS_Allocator := Heap_Allocator;
Heap_Allocator := Make_Null (Loc);
- -- Otherwise the heap allocator may be needed, so we
- -- make another allocator for secondary stack allocation.
+ -- Otherwise the heap allocator may be needed, so we make
+ -- another allocator for secondary stack allocation.
else
SS_Allocator := New_Copy_Tree (Heap_Allocator);
-- allocator (that is, it will only be executed on
-- behalf of callers that call the function as
-- initialization for such an allocator). This
- -- prevents errors when No_Implicit_Heap_Allocation
+ -- prevents errors when No_Implicit_Heap_Allocations
-- is in force.
Set_Comes_From_Source (Heap_Allocator, True);
-- Expand_N_Loop_Statement --
-----------------------------
- -- 1. Deal with while condition for C/Fortran boolean
- -- 2. Deal with loops with a non-standard enumeration type range
- -- 3. Deal with while loops where Condition_Actions is set
- -- 4. Insert polling call if required
+ -- 1. Remove null loop entirely
+ -- 2. Deal with while condition for C/Fortran boolean
+ -- 3. Deal with loops with a non-standard enumeration type range
+ -- 4. Deal with while loops where Condition_Actions is set
+ -- 5. Insert polling call if required
procedure Expand_N_Loop_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Isc : constant Node_Id := Iteration_Scheme (N);
begin
+ -- Delete null loop
+
+ if Is_Null_Loop (N) then
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end if;
+
+ -- Deal with condition for C/Fortran Boolean
+
if Present (Isc) then
Adjust_Condition (Condition (Isc));
end if;
+ -- Generate polling call
+
if Is_Non_Empty_List (Statements (N)) then
Generate_Poll_Call (First (Statements (N)));
end if;
Lab_Node : Node_Id;
begin
- -- Call postconditions procedure if procedure with active postconditions
+ -- Call _Postconditions procedure if procedure with active
+ -- postconditions. Here, we use the Postcondition_Proc attribute, which
+ -- is needed for implicitly-generated returns. Functions never
+ -- have implicitly-generated returns, and there's no room for
+ -- Postcondition_Proc in E_Function, so we look up the identifier
+ -- Name_uPostconditions for function returns (see
+ -- Expand_Simple_Function_Return).
if Ekind (Scope_Id) = E_Procedure
and then Has_Postconditions (Scope_Id)
then
+ pragma Assert (Present (Postcondition_Proc (Scope_Id)));
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
- Name => Make_Identifier (Loc, Name_uPostconditions)));
+ Name => New_Reference_To (Postcondition_Proc (Scope_Id), Loc)));
end if;
-- If it is a return from a procedure do no extra steps
Call :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Complete_Rendezvous), Loc));
+ Name => New_Reference_To (RTE (RE_Complete_Rendezvous), Loc));
Insert_Before (N, Call);
-- why not insert actions here???
Analyze (Call);
Exptyp : constant Entity_Id := Etype (Exp);
-- The type of the expression (not necessarily the same as R_Type)
+ Subtype_Ind : Node_Id;
+ -- If the result type of the function is class-wide and the
+ -- expression has a specific type, then we use the expression's
+ -- type as the type of the return object. In cases where the
+ -- expression is an aggregate that is built in place, this avoids
+ -- the need for an expensive conversion of the return object to
+ -- the specific type on assignments to the individual components.
+
begin
+ if Is_Class_Wide_Type (R_Type)
+ and then not Is_Class_Wide_Type (Etype (Exp))
+ then
+ Subtype_Ind := New_Occurrence_Of (Etype (Exp), Loc);
+ else
+ Subtype_Ind := New_Occurrence_Of (R_Type, Loc);
+ end if;
+
-- For the case of a simple return that does not come from an extended
-- return, in the case of Ada 2005 where we are returning a limited
-- type, we rewrite "return <expression>;" to be:
-- inherently limited). We might prefer to do this translation in all
-- cases (except perhaps for the case of Ada 95 inherently limited),
-- in order to fully exercise the Expand_N_Extended_Return_Statement
- -- code. This would also allow us to to the build-in-place optimization
+ -- code. This would also allow us to do the build-in-place optimization
-- for efficiency even in cases where it is semantically not required.
-- As before, we check the type of the return expression rather than the
Return_Object_Entity : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('R'));
-
- Subtype_Ind : constant Node_Id := New_Occurrence_Of (R_Type, Loc);
-
Obj_Decl : constant Node_Id :=
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Object_Entity,
Ext : constant Node_Id := Make_Extended_Return_Statement (Loc,
Return_Object_Declarations => New_List (Obj_Decl));
+ -- Do not perform this high-level optimization if the result type
+ -- is an interface because the "this" pointer must be displaced.
begin
Rewrite (N, Ext);
and then
(not Is_Array_Type (Exptyp)
or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
- or else CW_Or_Controlled_Type (Utyp))
+ or else CW_Or_Has_Controlled_Part (Utyp))
and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
-- controlled (by the virtue of restriction No_Finalization) because
-- gigi is not able to properly allocate class-wide types.
- elsif CW_Or_Controlled_Type (Utyp) then
+ elsif CW_Or_Has_Controlled_Part (Utyp) then
declare
Loc : constant Source_Ptr := Sloc (N);
Temp : constant Entity_Id :=
Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
+ -- This is an allocator for the secondary stack, and it's fine
+ -- to have Comes_From_Source set False on it, as gigi knows not
+ -- to flag it as a violation of No_Implicit_Heap_Allocations.
+
Alloc_Node :=
Make_Allocator (Loc,
Expression =>
Subtype_Mark => New_Reference_To (Etype (Exp), Loc),
Expression => Relocate_Node (Exp)));
+ -- We do not want discriminant checks on the declaration,
+ -- given that it gets its value from the allocator.
+
+ Set_No_Initialization (Alloc_Node);
+
Insert_List_Before_And_Analyze (N, New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Reference_To (R_Type, Loc))),
+ Subtype_Indication => Subtype_Ind)),
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
-- secondary stack.
else
+ Check_Restriction (No_Secondary_Stack, N);
Set_Storage_Pool (N, RTE (RE_SS_Pool));
-- If we are generating code for the VM do not use
end;
end if;
+ -- If we are returning an object that may not be bit-aligned, then
+ -- copy the value into a temporary first. This copy may need to expand
+ -- to a loop of component operations..
+
+ if Is_Possibly_Unaligned_Slice (Exp)
+ or else Is_Possibly_Unaligned_Object (Exp)
+ then
+ declare
+ Tnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ begin
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (R_Type, Loc),
+ Expression => Relocate_Node (Exp)),
+ Suppress => All_Checks);
+ Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
+ end;
+ end if;
+
-- Generate call to postcondition checks if they are present
if Ekind (Scope_Id) = E_Function
else
declare
Tnn : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T'));
+ Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
begin
-- For a complex expression of an elementary type, capture
Name => Make_Identifier (Loc, Name_uPostconditions),
Parameter_Associations => New_List (Duplicate_Subexpr (Exp))));
end if;
+
+ -- Ada 2005 (AI-251): If this return statement corresponds with an
+ -- simple return statement associated with an extended return statement
+ -- and the type of the returned object is an interface then generate an
+ -- implicit conversion to force displacement of the "this" pointer.
+
+ if Ada_Version >= Ada_05
+ and then Comes_From_Extended_Return_Statement (N)
+ and then Nkind (Expression (N)) = N_Identifier
+ and then Is_Interface (Utyp)
+ and then Utyp /= Underlying_Type (Exptyp)
+ then
+ Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
+ Analyze_And_Resolve (Exp);
+ end if;
end Expand_Simple_Function_Return;
------------------------------
L : constant Node_Id := Name (N);
T : constant Entity_Id := Underlying_Type (Etype (L));
- Ctrl_Act : constant Boolean := Controlled_Type (T)
+ Ctrl_Act : constant Boolean := Needs_Finalization (T)
and then not No_Ctrl_Actions (N);
Save_Tag : constant Boolean := Is_Tagged_Type (T)
if not Ctrl_Act then
null;
- -- The left hand side is an uninitialized temporary
+ -- The left hand side is an uninitialized temporary object
elsif Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L))
+ and then Nkind (Parent (Entity (Expression (L))))
+ = N_Object_Declaration
and then No_Initialization (Parent (Entity (Expression (L))))
then
null;
+
else
Append_List_To (Res,
Make_Final_Call (
OSDN Git Service
