-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 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;
-- N is an assignment of a non-tagged record value. This routine handles
-- the case where the assignment must be made component by component,
-- either because the target is not byte aligned, or there is a change
- -- of representation.
+ -- of representation, or when we have a tagged type with a representation
+ -- clause (this last case is required because holes in the tagged type
+ -- might be filled with components from child types).
procedure Expand_Non_Function_Return (N : Node_Id);
-- Called by Expand_N_Simple_Return_Statement in case we're returning from
-- statements.
procedure Expand_Simple_Function_Return (N : Node_Id);
- -- Expand simple return from function. Called by
- -- Expand_N_Simple_Return_Statement in case we're returning from a function
- -- body.
+ -- 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 Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
- -- Generate the necessary code for controlled and tagged assignment,
- -- that is to say, finalization of the target before, adjustement of
- -- the target after and save and restore of the tag and finalization
- -- pointers which are not 'part of the value' and must not be changed
- -- upon assignment. N is the original Assignment node.
+ -- Generate the necessary code for controlled and tagged assignment, that
+ -- is to say, finalization of the target before, adjustment of the target
+ -- after and save and restore of the tag and finalization pointers which
+ -- are not 'part of the value' and must not be changed upon assignment. N
+ -- is the original Assignment node.
------------------------------
-- Change_Of_Representation --
-- can be performed directly.
end if;
+ -- If either operand has an address clause clear Backwards_OK and
+ -- Forwards_OK, since we cannot tell if the operands overlap. We
+ -- exclude this treatment when Rhs is an aggregate, since we know
+ -- that overlap can't occur.
+
+ if (Has_Address_Clause (Lhs) and then Nkind (Rhs) /= N_Aggregate)
+ or else Has_Address_Clause (Rhs)
+ then
+ Set_Forwards_OK (N, False);
+ Set_Backwards_OK (N, False);
+ end if;
+
-- We certainly must use a loop for change of representation and also
-- we use the operand of the conversion on the right hand side as the
-- effective right hand side (the component types must match in this
-- do this, we get the wrong length computed for the array to be
-- moved. The two cases we need to worry about are:
- -- Explicit deference of an unconstrained packed array type as in the
- -- following example:
+ -- Explicit dereference of an unconstrained packed array type as in
+ -- the following example:
-- procedure C52 is
-- type BITS is array(INTEGER range <>) of BOOLEAN;
if Nkind (Rhs) = N_String_Literal then
declare
- Temp : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs);
Decl : Node_Id;
begin
-- 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
Ensure_Defined (R_Type, N);
-- We normally compare addresses to find out which way round to
- -- do the loop, since this is realiable, and handles the cases of
+ -- do the loop, since this is reliable, and handles the cases of
-- parameters, conversions etc. But we can't do that in the bit
-- packed case or the VM case, because addresses don't work there.
-- 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)
then
- -- Call TSS procedure for array assignment, passing the the
+ -- Call TSS procedure for array assignment, passing the
-- 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;
F_Or_L : Name_Id;
S_Or_P : Name_Id;
+ function Build_Step (J : Nat) return Node_Id;
+ -- The increment step for the index of the right-hand side is written
+ -- as an attribute reference (Succ or Pred). This function returns
+ -- the corresponding node, which is placed at the end of the loop body.
+
+ ----------------
+ -- Build_Step --
+ ----------------
+
+ function Build_Step (J : Nat) return Node_Id is
+ Step : Node_Id;
+ Lim : Name_Id;
+
+ begin
+ if Rev then
+ Lim := Name_First;
+ else
+ Lim := Name_Last;
+ end if;
+
+ Step :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Rnn (J), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (R_Index_Type (J), Loc),
+ Attribute_Name => S_Or_P,
+ Expressions => New_List (
+ New_Occurrence_Of (Rnn (J), Loc))));
+
+ -- Note that on the last iteration of the loop, the index is increased
+ -- (or decreased) past the corresponding bound. This is consistent with
+ -- the C semantics of the back-end, where such an off-by-one value on a
+ -- dead index variable is OK. However, in CodePeer mode this leads to
+ -- spurious warnings, and thus we place a guard around the attribute
+ -- reference. For obvious reasons we only do this for CodePeer.
+
+ if CodePeer_Mode then
+ Step :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn (J), Loc),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (L_Index_Type (J), Loc),
+ Attribute_Name => Lim)),
+ Then_Statements => New_List (Step));
+ end if;
+
+ return Step;
+ end Build_Step;
+
begin
if Rev then
F_Or_L := Name_Last;
R_Index := First_Index (R_Type);
for J in 1 .. Ndim loop
- Lnn (J) :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
-
- Rnn (J) :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
+ Lnn (J) := Make_Temporary (Loc, 'L');
+ Rnn (J) := Make_Temporary (Loc, 'R');
L_Index_Type (J) := Etype (L_Index);
R_Index_Type (J) := Etype (R_Index);
Discrete_Subtype_Definition =>
New_Reference_To (L_Index_Type (J), Loc))),
- Statements => New_List (
- Assign,
-
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Rnn (J), Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (R_Index_Type (J), Loc),
- Attribute_Name => S_Or_P,
- Expressions => New_List (
- New_Occurrence_Of (Rnn (J), Loc)))))))));
+ Statements => New_List (Assign, Build_Step (J))))));
end loop;
return Assign;
-- Expand_Assign_Record --
--------------------------
- -- The only processing required is in the change of representation case,
- -- where we must expand the assignment to a series of field by field
- -- assignments.
-
procedure Expand_Assign_Record (N : Node_Id) is
- Lhs : constant Node_Id := Name (N);
- Rhs : Node_Id := Expression (N);
+ Lhs : constant Node_Id := Name (N);
+ Rhs : Node_Id := Expression (N);
+ L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
begin
-- If change of representation, then extract the real right hand side
then
null;
+ -- If we have a tagged type that has a complete record representation
+ -- clause, we must do we must do component-wise assignments, since child
+ -- types may have used gaps for their components, and we might be
+ -- dealing with a view conversion.
+
+ elsif Is_Fully_Repped_Tagged_Type (L_Typ) then
+ null;
+
-- If neither condition met, then nothing special to do, the back end
-- can handle assignment of the entire component as a single entity.
declare
Loc : constant Source_Ptr := Sloc (N);
R_Typ : constant Entity_Id := Base_Type (Etype (Rhs));
- L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
Decl : constant Node_Id := Declaration_Node (R_Typ);
RDef : Node_Id;
F : Entity_Id;
-- declaration for Typ. We need to use the actual entity because the
-- type may be private and resolution by identifier alone would fail.
+ function Make_Field_Expr
+ (Comp_Ent : Entity_Id;
+ U_U : Boolean) return Node_Id;
+ -- Common processing for one component for Make_Component_List_Assign
+ -- and Make_Field_Assign. Return the expression to be assigned for
+ -- component Comp_Ent.
+
function Make_Component_List_Assign
(CL : Node_Id;
U_U : Boolean := False) return List_Id;
-- part expression as the switch for the generated case statement.
function Make_Field_Assign
- (C : Entity_Id;
+ (C : Entity_Id;
U_U : Boolean := False) return Node_Id;
-- Given C, the entity for a discriminant or component, build an
-- assignment for the corresponding field values. The flag U_U
begin
C := First_Entity (Utyp);
-
while Present (C) loop
if Chars (C) = Chars (Comp) then
return C;
end if;
+
Next_Entity (C);
end loop;
Alts : List_Id;
DC : Node_Id;
DCH : List_Id;
- Expr : Node_Id;
Result : List_Id;
V : Node_Id;
Result := Make_Field_Assigns (CI);
if Present (VP) then
-
V := First_Non_Pragma (Variants (VP));
Alts := New_List;
while Present (V) loop
-
DCH := New_List;
DC := First (Discrete_Choices (V));
while Present (DC) loop
Next_Non_Pragma (V);
end loop;
- -- If we have an Unchecked_Union, use the value of the inferred
- -- discriminant of the variant part expression as the switch
- -- for the case statement. The case statement may later be
- -- folded.
-
- if U_U then
- Expr :=
- New_Copy (Get_Discriminant_Value (
- Entity (Name (VP)),
- Etype (Rhs),
- Discriminant_Constraint (Etype (Rhs))));
- else
- Expr :=
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Name (VP))));
- end if;
-
Append_To (Result,
Make_Case_Statement (Loc,
- Expression => Expr,
+ Expression => Make_Field_Expr (Entity (Name (VP)), U_U),
Alternatives => Alts));
end if;
-----------------------
function Make_Field_Assign
- (C : Entity_Id;
+ (C : Entity_Id;
U_U : Boolean := False) return Node_Id
is
A : Node_Id;
- Expr : Node_Id;
begin
-- In the case of an Unchecked_Union, use the discriminant
-- constraint value as on the right hand side of the assignment.
- if U_U then
- Expr :=
- New_Copy (Get_Discriminant_Value (C,
- Etype (Rhs),
- Discriminant_Constraint (Etype (Rhs))));
- else
- Expr :=
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name => New_Occurrence_Of (C, Loc));
- end if;
-
A :=
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Lhs),
+ Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
- Expression => Expr);
+ Expression => Make_Field_Expr (C, U_U));
-- Set Assignment_OK, so discriminants can be assigned
Set_Assignment_OK (Name (A), True);
+
+ if Componentwise_Assignment (N)
+ and then Nkind (Name (A)) = N_Selected_Component
+ and then Chars (Selector_Name (Name (A))) = Name_uParent
+ then
+ Set_Componentwise_Assignment (A);
+ end if;
+
return A;
end Make_Field_Assign;
Result : List_Id;
begin
- Item := First (CI);
Result := New_List;
+ Item := First (CI);
while Present (Item) loop
- if Nkind (Item) = N_Component_Declaration then
+
+ -- Look for components, but exclude _tag field assignment if
+ -- the special Componentwise_Assignment flag is set.
+
+ if Nkind (Item) = N_Component_Declaration
+ and then not (Is_Tag (Defining_Identifier (Item))
+ and then Componentwise_Assignment (N))
+ then
Append_To
(Result, Make_Field_Assign (Defining_Identifier (Item)));
end if;
return Result;
end Make_Field_Assigns;
+ ---------------------
+ -- Make_Field_Expr --
+ ---------------------
+
+ function Make_Field_Expr
+ (Comp_Ent : Entity_Id;
+ U_U : Boolean) return Node_Id
+ is
+ begin
+ -- If we have an Unchecked_Union, use the value of the inferred
+ -- discriminant of the variant part expression.
+
+ if U_U then
+ return
+ New_Copy (Get_Discriminant_Value
+ (Comp_Ent,
+ Etype (Rhs),
+ Discriminant_Constraint (Etype (Rhs))));
+ else
+ return
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name => New_Occurrence_Of (Comp_Ent, Loc));
+ end if;
+ end Make_Field_Expr;
+
-- Start of processing for Expand_Assign_Record
begin
F := First_Discriminant (R_Typ);
while Present (F) loop
- if Is_Unchecked_Union (Base_Type (R_Typ)) then
- Insert_Action (N, Make_Field_Assign (F, True));
- else
- Insert_Action (N, Make_Field_Assign (F));
- end if;
+ -- If we are expanding the initialization of a derived record
+ -- that constrains or renames discriminants of the parent, we
+ -- must use the corresponding discriminant in the parent.
+
+ declare
+ CF : Entity_Id;
+
+ begin
+ if Inside_Init_Proc
+ and then Present (Corresponding_Discriminant (F))
+ then
+ CF := Corresponding_Discriminant (F);
+ else
+ CF := F;
+ end if;
- Next_Discriminant (F);
+ if Is_Unchecked_Union (Base_Type (R_Typ)) then
+ Insert_Action (N, Make_Field_Assign (CF, True));
+ else
+ Insert_Action (N, Make_Field_Assign (CF));
+ end if;
+
+ Next_Discriminant (F);
+ end;
end loop;
end if;
-- We know the underlying type is a record, but its current view
-- may be private. We must retrieve the usable record declaration.
- if Nkind (Decl) = N_Private_Type_Declaration
+ if Nkind_In (Decl, N_Private_Type_Declaration,
+ N_Private_Extension_Declaration)
and then Present (Full_View (R_Typ))
then
RDef := Type_Definition (Declaration_Node (Full_View (R_Typ)));
RDef := Type_Definition (Decl);
end if;
+ if Nkind (RDef) = N_Derived_Type_Definition then
+ RDef := Record_Extension_Part (RDef);
+ end if;
+
if Nkind (RDef) = N_Record_Definition
and then Present (Component_List (RDef))
then
-
if Is_Unchecked_Union (R_Typ) then
Insert_Actions (N,
Make_Component_List_Assign (Component_List (RDef), True));
Rewrite (N, Make_Null_Statement (Loc));
end if;
-
end;
end Expand_Assign_Record;
Exp : Node_Id;
begin
+ -- Special case to check right away, if the Componentwise_Assignment
+ -- flag is set, this is a reanalysis from the expansion of the primitive
+ -- assignment procedure for a tagged type, and all we need to do is to
+ -- expand to assignment of components, because otherwise, we would get
+ -- infinite recursion (since this looks like a tagged assignment which
+ -- would normally try to *call* the primitive assignment procedure).
+
+ if Componentwise_Assignment (N) then
+ Expand_Assign_Record (N);
+ return;
+ end if;
+
+ -- Defend against invalid subscripts on left side if we are in standard
+ -- validity checking mode. No need to do this if we are checking all
+ -- subscripts.
+
+ -- Note that we do this right away, because there are some early return
+ -- paths in this procedure, and this is required on all paths.
+
+ if Validity_Checks_On
+ and then Validity_Check_Default
+ and then not Validity_Check_Subscripts
+ then
+ Check_Valid_Lvalue_Subscripts (Lhs);
+ end if;
+
-- Ada 2005 (AI-327): Handle assignment to priority of protected object
-- Rewrite an assignment to X'Priority into a run-time call
end;
end if;
- -- First deal with generation of range check if required. For now we do
- -- this only for discrete types.
+ -- First deal with generation of range check if required
- if Do_Range_Check (Rhs)
- and then Is_Discrete_Type (Typ)
- then
+ if Do_Range_Check (Rhs) then
Set_Do_Range_Check (Rhs, False);
Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
end if;
BPAR_Expr : constant Node_Id := Relocate_Node (Prefix (Lhs));
BPAR_Typ : constant Entity_Id := Etype (BPAR_Expr);
Tnn : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ Make_Temporary (Loc, 'T', BPAR_Expr);
begin
-- Insert the post assignment first, because we want to copy the
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;
Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N);
begin
- -- In the controlled case, we need to make sure that function
- -- calls are evaluated before finalizing the target. In all cases,
- -- it makes the expansion easier if the side-effects are removed
- -- first.
+ -- In the controlled case, we ensure that function calls are
+ -- evaluated before finalizing the target. In all cases, it makes
+ -- the expansion easier if the side-effects are removed first.
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
-- discriminant checks are locally suppressed (as in extension
-- aggregate expansions) because otherwise the discriminant
-- check will be performed within the _assign call. It is also
- -- suppressed for assignmments created by the expander that
+ -- suppressed for assignments created by the expander that
-- correspond to initializations, where we do want to copy the
- -- tag (No_Ctrl_Actions flag set True). by the expander and we
+ -- tag (No_Ctrl_Actions flag set True) by the expander and we
-- do not need to mess with tags ever (Expand_Ctrl_Actions flag
-- is set True in this case).
or else (Is_Tagged_Type (Typ)
- and then not Is_Value_Type (Etype (Lhs))
- and then Chars (Current_Scope) /= Name_uAssign
- and then Expand_Ctrl_Actions
- and then not Discriminant_Checks_Suppressed (Empty))
+ and then not Is_Value_Type (Etype (Lhs))
+ and then Chars (Current_Scope) /= Name_uAssign
+ and then Expand_Ctrl_Actions
+ and then not Discriminant_Checks_Suppressed (Empty))
then
-- Fetch the primitive op _assign and proper type to call it.
- -- Because of possible conflits between private and full view
- -- the proper type is fetched directly from the operation
- -- profile.
+ -- Because of possible conflicts between private and full view,
+ -- fetch the proper type directly from the operation profile.
declare
Op : constant Entity_Id :=
if Is_Class_Wide_Type (Typ)
and then Is_Tagged_Type (Typ)
and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
+
+ -- Do not generate a tag check when the target object is
+ -- an interface since the expression of the right hand
+ -- side must only cover the interface.
+
+ and then not Is_Interface (Typ)
then
Append_To (L,
Make_Raise_Constraint_Error (Loc,
-- <code for controlled and/or tagged assignment>
-- end if;
+ -- Skip this if Restriction (No_Finalization) is active
+
if not Statically_Different (Lhs, Rhs)
and then Expand_Ctrl_Actions
+ and then not Restriction_Active (No_Finalization)
then
L := New_List (
Make_Implicit_If_Statement (N,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => L)));
- -- If no restrictions on aborts, protect the whole assignement
+ -- 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
-- Here the right side is valid, so it is fine. The case to deal
-- with is when the left side is a local variable reference whose
-- value is not currently known to be valid. If this is the case,
- -- and the assignment appears in an unconditional context, then we
- -- can mark the left side as now being valid.
+ -- and the assignment appears in an unconditional context, then
+ -- we can mark the left side as now being valid if one of these
+ -- conditions holds:
+
+ -- The expression of the right side has Do_Range_Check set so
+ -- that we know a range check will be performed. Note that it
+ -- can be the case that a range check is omitted because we
+ -- make the assumption that we can assume validity for operands
+ -- appearing in the right side in determining whether a range
+ -- check is required
+
+ -- The subtype of the right side matches the subtype of the
+ -- left side. In this case, even though we have not checked
+ -- the range of the right side, we know it is in range of its
+ -- subtype if the expression is valid.
if Is_Local_Variable_Reference (Lhs)
and then not Is_Known_Valid (Entity (Lhs))
and then In_Unconditional_Context (N)
then
- Set_Is_Known_Valid (Entity (Lhs), True);
+ if Do_Range_Check (Rhs)
+ or else Etype (Lhs) = Etype (Rhs)
+ then
+ Set_Is_Known_Valid (Entity (Lhs), True);
+ end if;
end if;
-- Case where right side may be invalid in the sense of the RM
end if;
end if;
- -- Defend against invalid subscripts on left side if we are in standard
- -- validity checking mode. No need to do this if we are checking all
- -- subscripts.
-
- if Validity_Checks_On
- and then Validity_Check_Default
- and then not Validity_Check_Subscripts
- then
- Check_Valid_Lvalue_Subscripts (Lhs);
- end if;
-
exception
when RE_Not_Available =>
return;
-- An optimization. If there are only two alternatives, and only
-- a single choice, then rewrite the whole case statement as an
- -- if statement, since this can result in susbequent optimizations.
+ -- if statement, since this can result in subsequent optimizations.
-- This helps not only with case statements in the source of a
-- simple form, but also with generated code (discriminant check
-- functions in particular)
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
and then
Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration
then
+ pragma Assert (Nkind (Original_Node (Return_Object_Decl)) =
+ N_Object_Declaration
+ and then Is_Build_In_Place_Function_Call
+ (Expression (Original_Node (Return_Object_Decl))));
+
Set_By_Ref (Return_Stm); -- Return build-in-place results by ref
elsif Is_Build_In_Place then
-- and the declaration isn't marked as No_Initialization, then
-- we need to generate an assignment to the object and insert
-- it after the declaration before rewriting it as a renaming
- -- (otherwise we'll lose the initialization).
+ -- (otherwise we'll lose the initialization). The case where
+ -- the result type is an interface (or class-wide interface)
+ -- is also excluded because the context of the function call
+ -- must be unconstrained, so the initialization will always
+ -- be done as part of an allocator evaluation (storage pool
+ -- or secondary stack), never to a constrained target object
+ -- passed in by the caller. Besides the assignment being
+ -- unneeded in this case, it avoids problems with trying to
+ -- generate a dispatching assignment when the return expression
+ -- is a nonlimited descendant of a limited interface (the
+ -- interface has no assignment operation).
if Present (Return_Obj_Expr)
and then not No_Initialization (Return_Object_Decl)
+ and then not Is_Interface (Return_Obj_Typ)
then
Init_Assignment :=
Make_Assignment_Statement (Loc,
-- Create an access type designating the function's
-- result subtype.
- Ref_Type :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Ref_Type := Make_Temporary (Loc, 'A');
Ptr_Type_Decl :=
Make_Full_Type_Declaration (Loc,
-- from an implicit access value passed in by the caller
-- or from the result of an allocator.
- Alloc_Obj_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
+ Alloc_Obj_Id := Make_Temporary (Loc, 'R');
Set_Etype (Alloc_Obj_Id, Ref_Type);
Alloc_Obj_Decl :=
if Present (Return_Obj_Expr)
and then not No_Initialization (Return_Object_Decl)
then
+ -- Always use the type of the expression for the
+ -- qualified expression, rather than the result type.
+ -- In general we cannot always use the result type
+ -- for the allocator, because the expression might be
+ -- of a specific type, such as in the case of an
+ -- aggregate or even a nonlimited object when the
+ -- result type is a limited class-wide interface type.
+
Heap_Allocator :=
Make_Allocator (Loc,
Expression =>
Make_Qualified_Expression (Loc,
Subtype_Mark =>
- New_Reference_To (Return_Obj_Typ, Loc),
+ New_Reference_To
+ (Etype (Return_Obj_Expr), Loc),
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);
+ 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.
+
+ else
SS_Allocator := New_Copy_Tree (Heap_Allocator);
+
+ -- The heap allocator is marked Comes_From_Source
+ -- since it corresponds to an explicit user-written
+ -- 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_Allocations
+ -- is in force.
+
+ Set_Comes_From_Source (Heap_Allocator, True);
end if;
-- The allocator is returned on the secondary stack. We
-- implicit access formal to the access object, to ensure
-- that the return object is initialized in that case.
-- In this situation, the target of the assignment must
- -- be rewritten to denote a derference of the access to
+ -- be rewritten to denote a dereference of the access to
-- the return object passed in by the caller.
if Present (Init_Assignment) then
-- Second, we deal with the obvious rewriting for the cases where the
-- condition of the IF is known at compile time to be True or False.
- -- Third, we remove elsif parts which have non-empty Condition_Actions
- -- and rewrite as independent if statements. For example:
+ -- Third, we remove elsif parts which have non-empty Condition_Actions and
+ -- rewrite as independent if statements. For example:
-- if x then xs
-- elsif y then ys
-- return not (expression);
- if Nkind (N) = N_If_Statement
- and then No (Elsif_Parts (N))
- and then Present (Else_Statements (N))
- and then List_Length (Then_Statements (N)) = 1
- and then List_Length (Else_Statements (N)) = 1
+ -- Only do these optimizations if we are at least at -O1 level and
+ -- do not do them if control flow optimizations are suppressed.
+
+ if Optimization_Level > 0
+ and then not Opt.Suppress_Control_Flow_Optimizations
then
- declare
- Then_Stm : constant Node_Id := First (Then_Statements (N));
- Else_Stm : constant Node_Id := First (Else_Statements (N));
+ if Nkind (N) = N_If_Statement
+ and then No (Elsif_Parts (N))
+ and then Present (Else_Statements (N))
+ and then List_Length (Then_Statements (N)) = 1
+ and then List_Length (Else_Statements (N)) = 1
+ then
+ declare
+ Then_Stm : constant Node_Id := First (Then_Statements (N));
+ Else_Stm : constant Node_Id := First (Else_Statements (N));
- begin
- if Nkind (Then_Stm) = N_Simple_Return_Statement
- and then
- Nkind (Else_Stm) = N_Simple_Return_Statement
- then
- declare
- Then_Expr : constant Node_Id := Expression (Then_Stm);
- Else_Expr : constant Node_Id := Expression (Else_Stm);
+ begin
+ if Nkind (Then_Stm) = N_Simple_Return_Statement
+ and then
+ Nkind (Else_Stm) = N_Simple_Return_Statement
+ then
+ declare
+ Then_Expr : constant Node_Id := Expression (Then_Stm);
+ Else_Expr : constant Node_Id := Expression (Else_Stm);
- begin
- if Nkind (Then_Expr) = N_Identifier
- and then
- Nkind (Else_Expr) = N_Identifier
- then
- if Entity (Then_Expr) = Standard_True
- and then Entity (Else_Expr) = Standard_False
- then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression => Relocate_Node (Condition (N))));
- Analyze (N);
- return;
-
- elsif Entity (Then_Expr) = Standard_False
- and then Entity (Else_Expr) = Standard_True
+ begin
+ if Nkind (Then_Expr) = N_Identifier
+ and then
+ Nkind (Else_Expr) = N_Identifier
then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Op_Not (Loc,
- Right_Opnd => Relocate_Node (Condition (N)))));
- Analyze (N);
- return;
+ if Entity (Then_Expr) = Standard_True
+ and then Entity (Else_Expr) = Standard_False
+ then
+ Rewrite (N,
+ Make_Simple_Return_Statement (Loc,
+ Expression => Relocate_Node (Condition (N))));
+ Analyze (N);
+ return;
+
+ elsif Entity (Then_Expr) = Standard_False
+ and then Entity (Else_Expr) = Standard_True
+ then
+ Rewrite (N,
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Relocate_Node (Condition (N)))));
+ Analyze (N);
+ return;
+ end if;
end if;
- end if;
- end;
- end if;
- end;
+ end;
+ end if;
+ end;
+ end if;
end if;
end Expand_N_If_Statement;
-- 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;
return;
end if;
- -- Note: we do not have to worry about validity chekcing of the for loop
+ -- Note: we do not have to worry about validity checking of the for loop
-- range bounds here, since they were frozen with constant declarations
-- and it is during that process that the validity checking is done.
procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
begin
+ -- Defend against previous errors (i.e. the return statement calls a
+ -- function that is not available in configurable runtime).
+
+ if Present (Expression (N))
+ and then Nkind (Expression (N)) = N_Empty
+ then
+ return;
+ end if;
+
-- Distinguish the function and non-function cases:
case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
Lab_Node : Node_Id;
begin
+ -- 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 => New_Reference_To (Postcondition_Proc (Scope_Id), Loc)));
+ end if;
+
-- If it is a return from a procedure do no extra steps
if Kind = E_Procedure or else Kind = E_Generic_Procedure then
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);
elsif Is_Protected_Type (Scope_Id) then
Call :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Complete_Entry_Body), Loc),
- Parameter_Associations => New_List
- (Make_Attribute_Reference (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Complete_Entry_Body), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To
- (Object_Ref
- (Corresponding_Body (Parent (Scope_Id))),
- Loc),
- Attribute_Name => Name_Unchecked_Access)));
+ (Find_Protection_Object (Current_Scope), Loc),
+ Attribute_Name =>
+ Name_Unchecked_Access)));
Insert_Before (N, Call);
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
- -- We rewrite "return <expression>;" to be:
+ 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:
-- return _anon_ : <return_subtype> := <expression>
-- The expansion produced by Expand_N_Extended_Return_Statement will
-- contain simple return statements (for example, a block containing
-- simple return of the return object), which brings us back here with
- -- Comes_From_Extended_Return_Statement set. To avoid infinite
- -- recursion, we do not transform into an extended return if
- -- Comes_From_Extended_Return_Statement is True.
+ -- Comes_From_Extended_Return_Statement set. The reason for the barrier
+ -- checking for a simple return that does not come from an extended
+ -- return is to avoid this infinite recursion.
-- The reason for this design is that for Ada 2005 limited returns, we
-- need to reify the return object, so we can build it "in place", and
-- we need a block statement to hang finalization and tasking stuff.
-- ??? In order to avoid disruption, we avoid translating to extended
- -- return except in the cases where we really need to (Ada 2005
- -- inherently limited). We would prefer eventually to do this
- -- translation in all cases except perhaps for the case of Ada 95
- -- inherently limited, in order to fully exercise the code in
- -- Expand_N_Extended_Return_Statement, and in order to do
- -- build-in-place for efficiency when it is not required.
+ -- return except in the cases where we really need to (Ada 2005 for
+ -- 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 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 type of the function, because the latter may be a limited
if not Comes_From_Extended_Return_Statement (N)
and then Is_Inherently_Limited_Type (Etype (Expression (N)))
- and then Ada_Version >= Ada_05 -- ???
+ and then Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L
then
declare
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);
-
+ Make_Temporary (Loc, 'R', Exp);
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);
if Is_Scalar_Type (Exptyp) then
Rewrite (Exp, Convert_To (R_Type, Exp));
- Analyze (Exp);
+
+ -- The expression is resolved to ensure that the conversion gets
+ -- expanded to generate a possible constraint check.
+
+ Analyze_And_Resolve (Exp, R_Type);
end if;
-- Deal with returning variable length objects and controlled types
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 :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
- Acc_Typ : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Acc_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
Alloc_Node : Node_Id;
+ Temp : Entity_Id;
begin
Set_Ekind (Acc_Typ, E_Access_Type);
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 =>
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Reference_To (Etype (Exp), Loc),
- Expression => Relocate_Node (Exp)));
+ 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);
+
+ Temp := Make_Temporary (Loc, 'R', 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
- Set_Storage_Pool (N, RTE (RE_SS_Pool));
+ 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
-- SS_Allocate since everything is heap-allocated anyway.
else
declare
+ ExpR : constant Node_Id := Relocate_Node (Exp);
Result_Id : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
- Result_Exp : constant Node_Id :=
+ Make_Temporary (Loc, 'R', ExpR);
+ Result_Exp : constant Node_Id :=
New_Reference_To (Result_Id, Loc);
- Result_Obj : constant Node_Id :=
+ Result_Obj : constant Node_Id :=
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Id,
Object_Definition =>
New_Reference_To (R_Type, Loc),
Constant_Present => True,
- Expression => Relocate_Node (Exp));
+ Expression => ExpR);
begin
Set_Assignment_OK (Result_Obj);
-- does not seem to be any practical way to implement this check.
elsif Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then Is_Class_Wide_Type (R_Type)
and then not Scope_Suppress (Accessibility_Check)
and then
Reason => PE_Accessibility_Check_Failed));
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
+ ExpR : constant Node_Id := Relocate_Node (Exp);
+ Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
+ begin
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (R_Type, Loc),
+ Expression => ExpR),
+ 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
+ and then Has_Postconditions (Scope_Id)
+ then
+ -- We are going to reference the returned value twice in this case,
+ -- once in the call to _Postconditions, and once in the actual return
+ -- statement, but we can't have side effects happening twice, and in
+ -- any case for efficiency we don't want to do the computation twice.
+
+ -- If the returned expression is an entity name, we don't need to
+ -- worry since it is efficient and safe to reference it twice, that's
+ -- also true for literals other than string literals, and for the
+ -- case of X.all where X is an entity name.
+
+ if Is_Entity_Name (Exp)
+ or else Nkind_In (Exp, N_Character_Literal,
+ N_Integer_Literal,
+ N_Real_Literal)
+ or else (Nkind (Exp) = N_Explicit_Dereference
+ and then Is_Entity_Name (Prefix (Exp)))
+ then
+ null;
+
+ -- Otherwise we are going to need a temporary to capture the value
+
+ else
+ declare
+ ExpR : constant Node_Id := Relocate_Node (Exp);
+ Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', ExpR);
+
+ begin
+ -- For a complex expression of an elementary type, capture
+ -- value in the temporary and use it as the reference.
+
+ if Is_Elementary_Type (R_Type) then
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (R_Type, Loc),
+ Expression => ExpR),
+ Suppress => All_Checks);
+
+ Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
+
+ -- If we have something we can rename, generate a renaming of
+ -- the object and replace the expression with a reference
+
+ elsif Is_Object_Reference (Exp) then
+ Insert_Action (Exp,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Subtype_Mark => New_Occurrence_Of (R_Type, Loc),
+ Name => ExpR),
+ Suppress => All_Checks);
+
+ Rewrite (Exp, New_Occurrence_Of (Tnn, Loc));
+
+ -- Otherwise we have something like a string literal or an
+ -- aggregate. We could copy the value, but that would be
+ -- inefficient. Instead we make a reference to the value and
+ -- capture this reference with a renaming, the expression is
+ -- then replaced by a dereference of this renaming.
+
+ else
+ -- For now, copy the value, since the code below does not
+ -- seem to work correctly ???
+
+ 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));
+
+ -- Insert_Action (Exp,
+ -- Make_Object_Renaming_Declaration (Loc,
+ -- Defining_Identifier => Tnn,
+ -- Access_Definition =>
+ -- Make_Access_Definition (Loc,
+ -- All_Present => True,
+ -- Subtype_Mark => New_Occurrence_Of (R_Type, Loc)),
+ -- Name =>
+ -- Make_Reference (Loc,
+ -- Prefix => Relocate_Node (Exp))),
+ -- Suppress => All_Checks);
+
+ -- Rewrite (Exp,
+ -- Make_Explicit_Dereference (Loc,
+ -- Prefix => New_Occurrence_Of (Tnn, Loc)));
+ end if;
+ end;
+ end if;
+
+ -- Generate call to _postconditions
+
+ Insert_Action (Exp,
+ Make_Procedure_Call_Statement (Loc,
+ 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);
+ Component_Assign : constant Boolean :=
+ Is_Fully_Repped_Tagged_Type (T);
+
Save_Tag : constant Boolean := Is_Tagged_Type (T)
+ and then not Component_Assign
and then not No_Ctrl_Actions (N)
- and then VM_Target = No_VM;
+ and then Tagged_Type_Expansion;
-- Tags are not saved and restored when VM_Target because VM tags are
-- represented implicitly in objects.
begin
Res := New_List;
- -- Finalize the target of the assignment when controlled.
+ -- Finalize the target of the assignment when controlled
+
-- We have two exceptions here:
- -- 1. If we are in an init proc since it is an initialization
- -- more than an assignment
+ -- 1. If we are in an init proc since it is an initialization more
+ -- than an assignment.
-- 2. If the left-hand side is a temporary that was not initialized
-- (or the parent part of a temporary since it is the case in
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 (
- Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L),
- With_Detach => New_Reference_To (Standard_False, Loc)));
+ Make_Final_Call
+ (Ref => Duplicate_Subexpr_No_Checks (L),
+ Typ => Etype (L),
+ With_Detach => New_Reference_To (Standard_False, Loc)));
end if;
-- Save the Tag in a local variable Tag_Tmp
if Save_Tag then
- Tag_Tmp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Tag_Tmp := Make_Temporary (Loc, 'A');
Append_To (Res,
Make_Object_Declaration (Loc,
New_Reference_To (Controller_Component (T), Loc));
end if;
- Prev_Tmp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+ Prev_Tmp := Make_Temporary (Loc, 'B');
Append_To (Res,
Make_Object_Declaration (Loc,
Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref),
Selector_Name => Make_Identifier (Loc, Name_Prev))));
- Next_Tmp :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('C'));
+ Next_Tmp := Make_Temporary (Loc, 'C');
Append_To (Res,
Make_Object_Declaration (Loc,
Make_Integer_Literal (Loc,
Intval => System_Storage_Unit));
- Range_Type :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('G'));
+ Range_Type := Make_Temporary (Loc, 'G');
Append_To (Res,
Make_Subtype_Declaration (Loc,
Append_To (Res,
Make_Subtype_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('S')),
+ Defining_Identifier => Make_Temporary (Loc, 'S'),
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
-- type A is access S
- Opaque_Type :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ Opaque_Type := Make_Temporary (Loc, 'A');
Append_To (Res,
Make_Full_Type_Declaration (Loc,
First_After_Root := Make_Integer_Literal (Loc, 1);
- -- For the case of a controlled object, skip the
- -- Root_Controlled part.
+ -- For controlled object, skip Root_Controlled part
if Is_Controlled (T) then
First_After_Root :=
end if;
-- For the case of a record with controlled components, skip
- -- the Prev and Next components of the record controller.
- -- These components constitute a 'hole' in the middle of the
- -- data to be copied.
+ -- record controller Prev/Next components. These components
+ -- constitute a 'hole' in the middle of the data to be copied.
if Has_Controlled_Component (T) then
Prev_Ref :=
New_Reference_To (Controller_Component (T), Loc)),
Selector_Name => Make_Identifier (Loc, Name_Prev));
- -- Last index before hole: determined by position of
- -- the _Controller.Prev component.
+ -- Last index before hole: determined by position of the
+ -- _Controller.Prev component.
- Last_Before_Hole :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('L'));
+ Last_Before_Hole := Make_Temporary (Loc, 'L');
Append_To (Res,
Make_Object_Declaration (Loc,
Object_Definition => New_Occurrence_Of (
RTE (RE_Storage_Offset), Loc),
Constant_Present => True,
- Expression => Make_Op_Add (Loc,
+ Expression =>
+ Make_Op_Add (Loc,
Make_Attribute_Reference (Loc,
Prefix => Prev_Ref,
Attribute_Name => Name_Position),
-- First index after hole
- First_After_Hole :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('F'));
+ First_After_Hole := Make_Temporary (Loc, 'F');
Append_To (Res,
Make_Object_Declaration (Loc,
end Controlled_Actions;
end if;
+ -- Not controlled case
+
else
- Append_To (Res, Relocate_Node (N));
+ declare
+ Asn : constant Node_Id := Relocate_Node (N);
+
+ begin
+ -- If this is the case of a tagged type with a full rep clause,
+ -- we must expand it into component assignments, so we mark the
+ -- node as unanalyzed, to get it reanalyzed, but flag it has
+ -- requiring component-wise assignment so we don't get infinite
+ -- recursion.
+
+ if Component_Assign then
+ Set_Analyzed (Asn, False);
+ Set_Componentwise_Assignment (Asn, True);
+ end if;
+
+ Append_To (Res, Asn);
+ end;
end if;
-- Restore the tag
OSDN Git Service
