-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
-with Elists; use Elists;
-with Exp_Atag; use Exp_Atag;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
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
- -- a procedure body, entry body, accept statement, or extended return
- -- statement. Note that all non-function returns are simple return
- -- statements.
+ procedure Expand_Iterator_Loop (N : Node_Id);
+ -- Expand loop over arrays and containers that uses the form "for X of C"
+ -- with an optional subtype mark, or "for Y in C".
- 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.
+ procedure Expand_Predicated_Loop (N : Node_Id);
+ -- Expand for loop over predicated subtype
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
-- cannot assign to elements of the array without this extra
-- unchecked conversion.
+ -- Note: We propagate Parent to the conversion nodes to generate
+ -- a well-formed subtree.
+
if Nkind (Act_Lhs) = N_Slice then
Larray := Prefix (Act_Lhs);
else
Larray := Act_Lhs;
if Is_Private_Type (Etype (Larray)) then
- Larray :=
- Unchecked_Convert_To
- (Underlying_Type (Etype (Larray)), Larray);
+ declare
+ Par : constant Node_Id := Parent (Larray);
+ begin
+ Larray :=
+ Unchecked_Convert_To
+ (Underlying_Type (Etype (Larray)), Larray);
+ Set_Parent (Larray, Par);
+ end;
end if;
end if;
Rarray := Act_Rhs;
if Is_Private_Type (Etype (Rarray)) then
- Rarray :=
- Unchecked_Convert_To
- (Underlying_Type (Etype (Rarray)), Rarray);
+ declare
+ Par : constant Node_Id := Parent (Rarray);
+ begin
+ Rarray :=
+ Unchecked_Convert_To
+ (Underlying_Type (Etype (Rarray)), Rarray);
+ Set_Parent (Rarray, Par);
+ end;
end if;
end if;
-- 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 VM_Target = No_VM and not AAMP_On_Target then
+ return;
+
+ -- Assume other back ends can handle it if Forwards_OK is set
- if Forwards_OK (N) then
+ 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 reanalyzed
+ -- 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;
+
+ -- Start of processing for Expand_Assign_Array_Loop
+
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;
-- 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;
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
else
Expr :=
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
+ Prefix => Duplicate_Subexpr (Rhs),
Selector_Name =>
Make_Identifier (Loc, Chars (Name (VP))));
end if;
-----------------------
function Make_Field_Assign
- (C : Entity_Id;
+ (C : Entity_Id;
U_U : Boolean := False) return Node_Id
is
A : Node_Id;
else
Expr :=
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
+ Prefix => Duplicate_Subexpr (Rhs),
Selector_Name => New_Occurrence_Of (C, Loc));
end if;
Make_Assignment_Statement (Loc,
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);
-- 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;
begin
Item := First (CI);
Result := New_List;
+
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;
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;
+
+ 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);
+ 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
-- about complications that would other arise from X'Priority'Access,
-- which is illegal, because of the lack of aliasing.
- if Ada_Version >= Ada_05 then
+ if Ada_Version >= Ada_2005 then
declare
Call : Node_Id;
Conctyp : Entity_Id;
end;
end if;
- -- First deal with generation of range check if required. For now we do
- -- this only for discrete types.
+ -- Deal with assignment checks unless suppressed
- if Do_Range_Check (Rhs)
- and then Is_Discrete_Type (Typ)
- then
- Set_Do_Range_Check (Rhs, False);
- Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
+ if not Suppress_Assignment_Checks (N) then
+
+ -- First deal with generation of range check if required
+
+ if Do_Range_Check (Rhs) then
+ Set_Do_Range_Check (Rhs, False);
+ Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
+ end if;
+
+ -- Then generate predicate check if required
+
+ Apply_Predicate_Check (Rhs, Typ);
end if;
-- Check for a special case where a high level transformation is
-- Since P is going to be evaluated more than once, any subscripts
-- in P must have their evaluation forced.
- if (Nkind (Lhs) = N_Indexed_Component
- or else
- Nkind (Lhs) = N_Selected_Component)
+ if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component)
and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs))
then
declare
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
loop
Set_Analyzed (Exp, False);
- if Nkind (Exp) = N_Selected_Component
- or else
- Nkind (Exp) = N_Indexed_Component
+ if Nkind_In
+ (Exp, N_Selected_Component, N_Indexed_Component)
then
Exp := Prefix (Exp);
else
-- has discriminants (necessarily with defaults) a check may still be
-- necessary if the Lhs is aliased. The private determinants must be
-- visible to build the discriminant constraints.
+ -- What is a "determinant"???
-- Only an explicit dereference that comes from source indicates
-- aliasing. Access to formals of protected operations and entries
-- build-in-place for user-written assignment statements (the assignment
-- here came from an aggregate.)
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Is_Build_In_Place_Function_Call (Rhs)
then
Make_Build_In_Place_Call_In_Assignment (N, Rhs);
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);
-- If the type is tagged, we may as well use the predefined
-- primitive assignment. This avoids inlining a lot of code
- -- and in the class-wide case, the assignment is replaced by
- -- dispatch call to _assign. Note that this cannot be done when
- -- 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
- -- correspond to initializations, where we do want to copy the
- -- 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).
+ -- and in the class-wide case, the assignment is replaced
+ -- by a dispatching call to _assign. It is suppressed in the
+ -- case of assignments created by the expander that correspond
+ -- to initializations, where we do want to copy the tag
+ -- (Expand_Ctrl_Actions flag is set True in this case). It is
+ -- also suppressed if restriction No_Dispatching_Calls is in
+ -- force because in that case predefined primitives are not
+ -- generated.
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 Restriction_Active (No_Dispatching_Calls))
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 :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
- Make_Identifier (Loc,
- Chars => Name_uTag)),
+ Make_Identifier (Loc, Name_uTag)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name =>
- Make_Identifier (Loc,
- Chars => Name_uTag))),
+ Make_Identifier (Loc, Name_uTag))),
Reason => CE_Tag_Check_Failed));
end if;
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (Op, Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (F_Typ,
- Duplicate_Subexpr (Lhs)),
- Unchecked_Convert_To (F_Typ,
- Duplicate_Subexpr (Rhs)))));
+ declare
+ Left_N : Node_Id := Duplicate_Subexpr (Lhs);
+ Right_N : Node_Id := Duplicate_Subexpr (Rhs);
+
+ begin
+ -- In order to dispatch the call to _assign the type of
+ -- the actuals must match. Add conversion (if required).
+
+ if Etype (Lhs) /= F_Typ then
+ Left_N := Unchecked_Convert_To (F_Typ, Left_N);
+ end if;
+
+ if Etype (Rhs) /= F_Typ then
+ Right_N := Unchecked_Convert_To (F_Typ, Right_N);
+ end if;
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (Op, Loc),
+ Parameter_Associations => New_List (
+ Node1 => Left_N,
+ Node2 => Right_N)));
+ end;
end;
else
-- <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
Actual_Rhs : Node_Id := Rhs;
begin
- while Nkind (Actual_Rhs) = N_Type_Conversion
- or else
- Nkind (Actual_Rhs) = N_Qualified_Expression
+ while Nkind_In (Actual_Rhs, N_Type_Conversion,
+ N_Qualified_Expression)
loop
Actual_Rhs := Expression (Actual_Rhs);
end loop;
-- 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
-- Skip this if left hand side is an array or record component
-- and elementary component validity checks are suppressed.
- if (Nkind (Lhs) = N_Selected_Component
- or else
- Nkind (Lhs) = N_Indexed_Component)
+ if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component)
and then not Validity_Check_Components
then
null;
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)
Adjust_Condition (Condition (N));
end Expand_N_Exit_Statement;
- ----------------------------------------
- -- Expand_N_Extended_Return_Statement --
- ----------------------------------------
-
- -- If there is a Handled_Statement_Sequence, we rewrite this:
-
- -- return Result : T := <expression> do
- -- <handled_seq_of_stms>
- -- end return;
-
- -- to be:
-
- -- declare
- -- Result : T := <expression>;
- -- begin
- -- <handled_seq_of_stms>
- -- return Result;
- -- end;
-
- -- Otherwise (no Handled_Statement_Sequence), we rewrite this:
-
- -- return Result : T := <expression>;
-
- -- to be:
-
- -- return <expression>;
-
- -- unless it's build-in-place or there's no <expression>, in which case
- -- we generate:
-
- -- declare
- -- Result : T := <expression>;
- -- begin
- -- return Result;
- -- end;
-
- -- Note that this case could have been written by the user as an extended
- -- return statement, or could have been transformed to this from a simple
- -- return statement.
-
- -- That is, we need to have a reified return object if there are statements
- -- (which might refer to it) or if we're doing build-in-place (so we can
- -- set its address to the final resting place or if there is no expression
- -- (in which case default initial values might need to be set).
-
- procedure Expand_N_Extended_Return_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- Return_Object_Entity : constant Entity_Id :=
- First_Entity (Return_Statement_Entity (N));
- Return_Object_Decl : constant Node_Id :=
- Parent (Return_Object_Entity);
- Parent_Function : constant Entity_Id :=
- Return_Applies_To (Return_Statement_Entity (N));
- Is_Build_In_Place : constant Boolean :=
- Is_Build_In_Place_Function (Parent_Function);
-
- Return_Stm : Node_Id;
- Statements : List_Id;
- Handled_Stm_Seq : Node_Id;
- Result : Node_Id;
- Exp : Node_Id;
-
- function Move_Activation_Chain return Node_Id;
- -- Construct a call to System.Tasking.Stages.Move_Activation_Chain
- -- with parameters:
- -- From current activation chain
- -- To activation chain passed in by the caller
- -- New_Master master passed in by the caller
-
- function Move_Final_List return Node_Id;
- -- Construct call to System.Finalization_Implementation.Move_Final_List
- -- with parameters:
- --
- -- From finalization list of the return statement
- -- To finalization list passed in by the caller
-
- ---------------------------
- -- Move_Activation_Chain --
- ---------------------------
-
- function Move_Activation_Chain return Node_Id is
- Activation_Chain_Formal : constant Entity_Id :=
- Build_In_Place_Formal
- (Parent_Function, BIP_Activation_Chain);
- To : constant Node_Id :=
- New_Reference_To
- (Activation_Chain_Formal, Loc);
- Master_Formal : constant Entity_Id :=
- Build_In_Place_Formal
- (Parent_Function, BIP_Master);
- New_Master : constant Node_Id :=
- New_Reference_To (Master_Formal, Loc);
-
- Chain_Entity : Entity_Id;
- From : Node_Id;
-
- begin
- Chain_Entity := First_Entity (Return_Statement_Entity (N));
- while Chars (Chain_Entity) /= Name_uChain loop
- Chain_Entity := Next_Entity (Chain_Entity);
- end loop;
-
- From :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Chain_Entity, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- -- ??? Not clear why "Make_Identifier (Loc, Name_uChain)" doesn't
- -- work, instead of "New_Reference_To (Chain_Entity, Loc)" above.
-
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Move_Activation_Chain), Loc),
- Parameter_Associations => New_List (From, To, New_Master));
- end Move_Activation_Chain;
-
- ---------------------
- -- Move_Final_List --
- ---------------------
-
- function Move_Final_List return Node_Id is
- Flist : constant Entity_Id :=
- Finalization_Chain_Entity (Return_Statement_Entity (N));
-
- From : constant Node_Id := New_Reference_To (Flist, Loc);
-
- Caller_Final_List : constant Entity_Id :=
- Build_In_Place_Formal
- (Parent_Function, BIP_Final_List);
-
- To : constant Node_Id := New_Reference_To (Caller_Final_List, Loc);
-
- begin
- -- Catch cases where a finalization chain entity has not been
- -- associated with the return statement entity.
-
- pragma Assert (Present (Flist));
-
- -- Build required call
-
- return
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Copy (From),
- Right_Opnd => New_Node (N_Null, Loc)),
- Then_Statements =>
- New_List (
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Move_Final_List), Loc),
- Parameter_Associations => New_List (From, To))));
- end Move_Final_List;
-
- -- Start of processing for Expand_N_Extended_Return_Statement
-
- begin
- if Nkind (Return_Object_Decl) = N_Object_Declaration then
- Exp := Expression (Return_Object_Decl);
- else
- Exp := Empty;
- end if;
-
- Handled_Stm_Seq := Handled_Statement_Sequence (N);
-
- -- Build a simple_return_statement that returns the return object when
- -- there is a statement sequence, or no expression, or the result will
- -- be built in place. Note however that we currently do this for all
- -- composite cases, even though nonlimited composite results are not yet
- -- built in place (though we plan to do so eventually).
-
- if Present (Handled_Stm_Seq)
- or else Is_Composite_Type (Etype (Parent_Function))
- or else No (Exp)
- then
- if No (Handled_Stm_Seq) then
- Statements := New_List;
-
- -- If the extended return has a handled statement sequence, then wrap
- -- it in a block and use the block as the first statement.
-
- else
- Statements :=
- New_List (Make_Block_Statement (Loc,
- Declarations => New_List,
- Handled_Statement_Sequence => Handled_Stm_Seq));
- end if;
-
- -- If control gets past the above Statements, we have successfully
- -- completed the return statement. If the result type has controlled
- -- parts and the return is for a build-in-place function, then we
- -- call Move_Final_List to transfer responsibility for finalization
- -- of the return object to the caller. An alternative would be to
- -- declare a Success flag in the function, initialize it to False,
- -- and set it to True here. Then move the Move_Final_List call into
- -- the cleanup code, and check Success. If Success then make a call
- -- to Move_Final_List else do finalization. Then we can remove the
- -- abort-deferral and the nulling-out of the From parameter from
- -- Move_Final_List. Note that the current method is not quite correct
- -- 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.
-
- if Is_Build_In_Place
- and then Controlled_Type (Etype (Parent_Function))
- 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;
- end if;
-
- -- Similarly to the above Move_Final_List, if the result type
- -- contains tasks, we call Move_Activation_Chain. Later, the cleanup
- -- code will call Complete_Master, which will terminate any
- -- unactivated tasks belonging to the return statement master. But
- -- Move_Activation_Chain updates their master to be that of the
- -- caller, so they will not be terminated unless the return statement
- -- completes unsuccessfully due to exception, abort, goto, or exit.
- -- As a formality, we test whether the function requires the result
- -- to be built in place, though that's necessarily true for the case
- -- of result types with task parts.
-
- if Is_Build_In_Place and Has_Task (Etype (Parent_Function)) then
- Append_To (Statements, Move_Activation_Chain);
- end if;
-
- -- Build a simple_return_statement that returns the return object
-
- Return_Stm :=
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Return_Object_Entity, Loc));
- Append_To (Statements, Return_Stm);
-
- Handled_Stm_Seq :=
- Make_Handled_Sequence_Of_Statements (Loc, Statements);
- end if;
-
- -- Case where we build a block
-
- if Present (Handled_Stm_Seq) then
- Result :=
- Make_Block_Statement (Loc,
- Declarations => Return_Object_Declarations (N),
- Handled_Statement_Sequence => Handled_Stm_Seq);
-
- -- We set the entity of the new block statement to be that of the
- -- return statement. This is necessary so that various fields, such
- -- as Finalization_Chain_Entity carry over from the return statement
- -- to the block. Note that this block is unusual, in that its entity
- -- is an E_Return_Statement rather than an E_Block.
-
- Set_Identifier
- (Result, New_Occurrence_Of (Return_Statement_Entity (N), Loc));
-
- -- If the object decl was already rewritten as a renaming, then
- -- we don't want to do the object allocation and transformation of
- -- of the return object declaration to a renaming. This case occurs
- -- when the return object is initialized by a call to another
- -- build-in-place function, and that function is responsible for the
- -- allocation of the return object.
-
- if Is_Build_In_Place
- and then
- Nkind (Return_Object_Decl) = N_Object_Renaming_Declaration
- then
- Set_By_Ref (Return_Stm); -- Return build-in-place results by ref
-
- elsif Is_Build_In_Place then
-
- -- Locate the implicit access parameter associated with the
- -- caller-supplied return object and convert the return
- -- statement's return object declaration to a renaming of a
- -- dereference of the access parameter. If the return object's
- -- declaration includes an expression that has not already been
- -- expanded as separate assignments, then add an assignment
- -- statement to ensure the return object gets initialized.
-
- -- declare
- -- Result : T [:= <expression>];
- -- begin
- -- ...
-
- -- is converted to
-
- -- declare
- -- Result : T renames FuncRA.all;
- -- [Result := <expression;]
- -- begin
- -- ...
-
- declare
- Return_Obj_Id : constant Entity_Id :=
- Defining_Identifier (Return_Object_Decl);
- Return_Obj_Typ : constant Entity_Id := Etype (Return_Obj_Id);
- Return_Obj_Expr : constant Node_Id :=
- Expression (Return_Object_Decl);
- Result_Subt : constant Entity_Id :=
- Etype (Parent_Function);
- Constr_Result : constant Boolean :=
- Is_Constrained (Result_Subt);
- Obj_Alloc_Formal : Entity_Id;
- Object_Access : Entity_Id;
- Obj_Acc_Deref : Node_Id;
- Init_Assignment : Node_Id := Empty;
-
- begin
- -- Build-in-place results must be returned by reference
-
- Set_By_Ref (Return_Stm);
-
- -- Retrieve the implicit access parameter passed by the caller
-
- Object_Access :=
- Build_In_Place_Formal (Parent_Function, BIP_Object_Access);
-
- -- If the return object's declaration includes an expression
- -- 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).
-
- if Present (Return_Obj_Expr)
- and then not No_Initialization (Return_Object_Decl)
- then
- Init_Assignment :=
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Return_Obj_Id, Loc),
- Expression => Relocate_Node (Return_Obj_Expr));
- Set_Etype (Name (Init_Assignment), Etype (Return_Obj_Id));
- Set_Assignment_OK (Name (Init_Assignment));
- Set_No_Ctrl_Actions (Init_Assignment);
-
- Set_Parent (Name (Init_Assignment), Init_Assignment);
- Set_Parent (Expression (Init_Assignment), Init_Assignment);
-
- Set_Expression (Return_Object_Decl, Empty);
-
- if Is_Class_Wide_Type (Etype (Return_Obj_Id))
- and then not Is_Class_Wide_Type
- (Etype (Expression (Init_Assignment)))
- then
- Rewrite (Expression (Init_Assignment),
- Make_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (Etype (Return_Obj_Id), Loc),
- Expression =>
- Relocate_Node (Expression (Init_Assignment))));
- end if;
-
- -- In the case of functions where the calling context can
- -- determine the form of allocation needed, initialization
- -- is done with each part of the if statement that handles
- -- the different forms of allocation (this is true for
- -- unconstrained and tagged result subtypes).
-
- if Constr_Result
- and then not Is_Tagged_Type (Underlying_Type (Result_Subt))
- then
- Insert_After (Return_Object_Decl, Init_Assignment);
- end if;
- end if;
-
- -- When the function's subtype is unconstrained, a run-time
- -- test is needed to determine the form of allocation to use
- -- for the return object. The function has an implicit formal
- -- parameter indicating this. If the BIP_Alloc_Form formal has
- -- the value one, then the caller has passed access to an
- -- existing object for use as the return object. If the value
- -- is two, then the return object must be allocated on the
- -- secondary stack. Otherwise, the object must be allocated in
- -- a storage pool (currently only supported for the global
- -- heap, user-defined storage pools TBD ???). We generate an
- -- if statement to test the implicit allocation formal and
- -- initialize a local access value appropriately, creating
- -- allocators in the secondary stack and global heap cases.
- -- The special formal also exists and must be tested when the
- -- function has a tagged result, even when the result subtype
- -- is constrained, because in general such functions can be
- -- called in dispatching contexts and must be handled similarly
- -- to functions with a class-wide result.
-
- if not Constr_Result
- or else Is_Tagged_Type (Underlying_Type (Result_Subt))
- then
- Obj_Alloc_Formal :=
- Build_In_Place_Formal (Parent_Function, BIP_Alloc_Form);
-
- declare
- Ref_Type : Entity_Id;
- Ptr_Type_Decl : Node_Id;
- Alloc_Obj_Id : Entity_Id;
- Alloc_Obj_Decl : Node_Id;
- Alloc_If_Stmt : Node_Id;
- SS_Allocator : Node_Id;
- Heap_Allocator : Node_Id;
-
- begin
- -- Reuse the itype created for the function's implicit
- -- access formal. This avoids the need to create a new
- -- access type here, plus it allows assigning the access
- -- formal directly without applying a conversion.
-
- -- Ref_Type := Etype (Object_Access);
-
- -- Create an access type designating the function's
- -- result subtype.
-
- Ref_Type :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
-
- Ptr_Type_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Reference_To (Return_Obj_Typ, Loc)));
-
- Insert_Before (Return_Object_Decl, Ptr_Type_Decl);
-
- -- Create an access object that will be initialized to an
- -- access value denoting the return object, either coming
- -- 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'));
- Set_Etype (Alloc_Obj_Id, Ref_Type);
-
- Alloc_Obj_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Alloc_Obj_Id,
- Object_Definition => New_Reference_To
- (Ref_Type, Loc));
-
- Insert_Before (Return_Object_Decl, Alloc_Obj_Decl);
-
- -- Create allocators for both the secondary stack and
- -- global heap. If there's an initialization expression,
- -- then create these as initialized allocators.
-
- if Present (Return_Obj_Expr)
- and then not No_Initialization (Return_Object_Decl)
- then
- Heap_Allocator :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Reference_To (Return_Obj_Typ, 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
- -- use the type of the expression, which must be an
- -- aggregate of a definite type.
-
- if Is_Class_Wide_Type (Return_Obj_Typ) then
- Heap_Allocator :=
- Make_Allocator (Loc,
- New_Reference_To
- (Etype (Return_Obj_Expr), Loc));
- else
- Heap_Allocator :=
- Make_Allocator (Loc,
- New_Reference_To (Return_Obj_Typ, Loc));
- end if;
-
- -- If the object requires default initialization then
- -- that will happen later following the elaboration of
- -- the object renaming. If we don't turn it off here
- -- then the object will be default initialized twice.
-
- Set_No_Initialization (Heap_Allocator);
-
- SS_Allocator := New_Copy_Tree (Heap_Allocator);
- end if;
-
- Set_Storage_Pool
- (SS_Allocator, RTE (RE_SS_Pool));
- Set_Procedure_To_Call
- (SS_Allocator, RTE (RE_SS_Allocate));
-
- -- The allocator is returned on the secondary stack,
- -- so indicate that the function return, as well as
- -- the block that encloses the allocator, must not
- -- release it. The flags must be set now because the
- -- decision to use the secondary stack is done very
- -- late in the course of expanding the return statement,
- -- past the point where these flags are normally set.
-
- Set_Sec_Stack_Needed_For_Return (Parent_Function);
- Set_Sec_Stack_Needed_For_Return
- (Return_Statement_Entity (N));
- Set_Uses_Sec_Stack (Parent_Function);
- Set_Uses_Sec_Stack (Return_Statement_Entity (N));
-
- -- Create an if statement to test the BIP_Alloc_Form
- -- formal and initialize the access object to either the
- -- BIP_Object_Access formal (BIP_Alloc_Form = 0), the
- -- result of allocating the object in the secondary stack
- -- (BIP_Alloc_Form = 1), or else an allocator to create
- -- the return object in the heap (BIP_Alloc_Form = 2).
-
- -- ??? An unchecked type conversion must be made in the
- -- case of assigning the access object formal to the
- -- local access object, because a normal conversion would
- -- be illegal in some cases (such as converting access-
- -- to-unconstrained to access-to-constrained), but the
- -- the unchecked conversion will presumably fail to work
- -- right in just such cases. It's not clear at all how to
- -- handle this. ???
-
- Alloc_If_Stmt :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Reference_To (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (BIP_Allocation_Form'Pos
- (Caller_Allocation)))),
- Then_Statements =>
- New_List (Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To
- (Alloc_Obj_Id, Loc),
- Expression =>
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Reference_To (Ref_Type, Loc),
- Expression =>
- New_Reference_To
- (Object_Access, Loc)))),
- Elsif_Parts =>
- New_List (Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Reference_To
- (Obj_Alloc_Formal, Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- UI_From_Int (
- BIP_Allocation_Form'Pos
- (Secondary_Stack)))),
- Then_Statements =>
- New_List
- (Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To
- (Alloc_Obj_Id, Loc),
- Expression =>
- SS_Allocator)))),
- Else_Statements =>
- New_List (Make_Assignment_Statement (Loc,
- Name =>
- New_Reference_To
- (Alloc_Obj_Id, Loc),
- Expression =>
- Heap_Allocator)));
-
- -- If a separate initialization assignment was created
- -- earlier, append that following the assignment of the
- -- 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
- -- the return object passed in by the caller.
-
- if Present (Init_Assignment) then
- Rewrite (Name (Init_Assignment),
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Alloc_Obj_Id, Loc)));
- Set_Etype
- (Name (Init_Assignment), Etype (Return_Obj_Id));
-
- Append_To
- (Then_Statements (Alloc_If_Stmt),
- Init_Assignment);
- end if;
-
- Insert_Before (Return_Object_Decl, Alloc_If_Stmt);
-
- -- Remember the local access object for use in the
- -- dereference of the renaming created below.
-
- Object_Access := Alloc_Obj_Id;
- end;
- end if;
-
- -- Replace the return object declaration with a renaming of a
- -- dereference of the access value designating the return
- -- object.
-
- Obj_Acc_Deref :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Object_Access, Loc));
-
- Rewrite (Return_Object_Decl,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Return_Obj_Id,
- Access_Definition => Empty,
- Subtype_Mark => New_Occurrence_Of
- (Return_Obj_Typ, Loc),
- Name => Obj_Acc_Deref));
-
- Set_Renamed_Object (Return_Obj_Id, Obj_Acc_Deref);
- end;
- end if;
-
- -- Case where we do not build a block
-
- else
- -- We're about to drop Return_Object_Declarations on the floor, so
- -- we need to insert it, in case it got expanded into useful code.
-
- Insert_List_Before (N, Return_Object_Declarations (N));
-
- -- Build simple_return_statement that returns the expression directly
-
- Return_Stm := Make_Simple_Return_Statement (Loc, Expression => Exp);
-
- Result := Return_Stm;
- end if;
-
- -- Set the flag to prevent infinite recursion
-
- Set_Comes_From_Extended_Return_Statement (Return_Stm);
-
- Rewrite (N, Result);
- Analyze (N);
- end Expand_N_Extended_Return_Statement;
-
-----------------------------
-- Expand_N_Goto_Statement --
-----------------------------
-- 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
+ 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_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
+ 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;
+ end if;
+ end;
+ end if;
+ end if;
+ end Expand_N_If_Statement;
+
+ --------------------------
+ -- Expand_Iterator_Loop --
+ --------------------------
+
+ procedure Expand_Iterator_Loop (N : Node_Id) is
+ Isc : constant Node_Id := Iteration_Scheme (N);
+ I_Spec : constant Node_Id := Iterator_Specification (Isc);
+ Id : constant Entity_Id := Defining_Identifier (I_Spec);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Container : constant Node_Id := Name (I_Spec);
+ Container_Typ : constant Entity_Id := Etype (Container);
+ Cursor : Entity_Id;
+ New_Loop : Node_Id;
+ Stats : List_Id := Statements (N);
+
+ begin
+ -- Processing for arrays
+
+ if Is_Array_Type (Container_Typ) then
+
+ -- for Element of Array loop
+ --
+ -- This case requires an internally generated cursor to iterate over
+ -- the array.
+
+ if Of_Present (I_Spec) then
+ Cursor := Make_Temporary (Loc, 'C');
+
+ -- Generate:
+ -- Element : Component_Type renames Container (Cursor);
+
+ Prepend_To (Stats,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark =>
+ New_Reference_To (Component_Type (Container_Typ), Loc),
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => Relocate_Node (Container),
+ Expressions => New_List (
+ New_Reference_To (Cursor, Loc)))));
+
+ -- for Index in Array loop
+ --
+ -- This case utilizes the already given cursor name
+
+ else
+ Cursor := Id;
+ end if;
+
+ -- Generate:
+ -- for Cursor in [reverse] Container'Range loop
+ -- Element : Component_Type renames Container (Cursor);
+ -- -- for the "of" form
+ --
+ -- <original loop statements>
+ -- end loop;
+
+ New_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Cursor,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Container),
+ Attribute_Name => Name_Range),
+ Reverse_Present => Reverse_Present (I_Spec))),
+ Statements => Stats,
+ End_Label => Empty);
+
+ -- Processing for containers
+
+ else
+ -- The for loop is expanded into a while loop which uses a container
+ -- specific cursor to examine each element.
+
+ -- Cursor : Pack.Cursor := Container.First;
+ -- while Cursor /= Pack.No_Element loop
+ -- declare
+ -- -- the block is added when Element_Type is controlled
+
+ -- Obj : Pack.Element_Type := Element (Cursor);
+ -- -- for the "of" loop form
+ -- begin
+ -- <original loop statements>
+ -- end;
+
+ -- Pack.Next (Cursor);
+ -- end loop;
+
+ -- If "reverse" is present, then the initialization of the cursor
+ -- uses Last and the step becomes Prev. Pack is the name of the
+ -- package which instantiates the container.
+
declare
- Then_Stm : constant Node_Id := First (Then_Statements (N));
- Else_Stm : constant Node_Id := First (Else_Statements (N));
+ Element_Type : constant Entity_Id := Etype (Id);
+ Pack : constant Entity_Id :=
+ Scope (Base_Type (Container_Typ));
+ Decl : Node_Id;
+ Cntr : Node_Id;
+ Name_Init : Name_Id;
+ Name_Step : Name_Id;
begin
- if Nkind (Then_Stm) = N_Simple_Return_Statement
- and then
- Nkind (Else_Stm) = N_Simple_Return_Statement
- then
+ -- The "of" case uses an internally generated cursor
+
+ if Of_Present (I_Spec) then
+ Cursor := Make_Temporary (Loc, 'C');
+ else
+ Cursor := Id;
+ end if;
+
+ -- The code below only handles containers where Element is not a
+ -- primitive operation of the container. This excludes for now the
+ -- Hi-Lite formal containers.
+
+ if Of_Present (I_Spec) then
+
+ -- Generate:
+ -- Id : Element_Type := Pack.Element (Cursor);
+
+ Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark =>
+ New_Reference_To (Element_Type, Loc),
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars => Name_Element)),
+ Expressions => New_List (
+ New_Reference_To (Cursor, Loc))));
+
+ -- When the container holds controlled objects, wrap the loop
+ -- statements and element renaming declaration with a block.
+ -- This ensures that the transient result of Element (Cursor)
+ -- is cleaned up after each iteration of the loop.
+
+ if Needs_Finalization (Element_Type) then
+
+ -- Generate:
+ -- declare
+ -- Id : Element_Type := Pack.Element (Cursor);
+ -- begin
+ -- <original loop statments>
+ -- end;
+
+ Stats := New_List (
+ Make_Block_Statement (Loc,
+ Declarations => New_List (Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stats)));
+ else
+ Prepend_To (Stats, Decl);
+ end if;
+ end if;
+
+ -- Determine the advancement and initialization steps for the
+ -- cursor.
+
+ -- Must verify that the container has a reverse iterator ???
+
+ if Reverse_Present (I_Spec) then
+ Name_Init := Name_Last;
+ Name_Step := Name_Previous;
+ else
+ Name_Init := Name_First;
+ Name_Step := Name_Next;
+ end if;
+
+ -- For both iterator forms, add a call to the step operation to
+ -- advance the cursor. Generate:
+ --
+ -- Pack.[Next | Prev] (Cursor);
+
+ Append_To (Stats,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Step)),
+
+ Parameter_Associations => New_List (
+ New_Reference_To (Cursor, Loc))));
+
+ -- Generate:
+ -- while Cursor /= Pack.No_Element loop
+ -- <Stats>
+ -- end loop;
+
+ New_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ New_Reference_To (Cursor, Loc),
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_No_Element)))),
+ Statements => Stats,
+ End_Label => Empty);
+
+ Cntr := Relocate_Node (Container);
+
+ -- When the container is provided by a function call, create an
+ -- explicit renaming of the function result. Generate:
+ --
+ -- Cnn : Container_Typ renames Func_Call (...);
+ --
+ -- The renaming avoids the generation of a transient scope when
+ -- initializing the cursor and the premature finalization of the
+ -- container.
+
+ if Nkind (Cntr) = N_Function_Call then
declare
- Then_Expr : constant Node_Id := Expression (Then_Stm);
- Else_Expr : constant Node_Id := Expression (Else_Stm);
+ Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'C');
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
- 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;
+ Insert_Action (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Ren_Id,
+ Subtype_Mark =>
+ New_Reference_To (Container_Typ, Loc),
+ Name => Cntr));
+
+ Cntr := New_Reference_To (Ren_Id, Loc);
end;
end if;
+
+ -- Create the declaration of the cursor and insert it before the
+ -- source loop. Generate:
+ --
+ -- C : Pack.Cursor_Type := Container.[First | Last];
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cursor,
+ Object_Definition =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Cursor)),
+
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => Cntr,
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Init))));
+
+ -- If the range of iteration is given by a function call that
+ -- returns a container, the finalization actions have been saved
+ -- in the Condition_Actions of the iterator. Insert them now at
+ -- the head of the loop.
+
+ if Present (Condition_Actions (Isc)) then
+ Insert_List_Before (N, Condition_Actions (Isc));
+ end if;
end;
end if;
- end Expand_N_If_Statement;
+
+ Rewrite (N, New_Loop);
+ Analyze (N);
+ end Expand_Iterator_Loop;
-----------------------------
-- 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. Deal with loops over predicated subtypes
+ -- 6. Deal with loops with iterators over arrays and containers
+ -- 7. 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;
-- Nothing more to do for plain loop with no iteration scheme
if No (Isc) then
- return;
- end if;
+ null;
- -- Note: we do not have to worry about validity chekcing of the for loop
+ -- Case of for loop (Loop_Parameter_Specification present)
+
+ -- 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.
- -- Handle the case where we have a for loop with the range type being an
- -- enumeration type with non-standard representation. In this case we
- -- expand:
-
- -- for x in [reverse] a .. b loop
- -- ...
- -- end loop;
-
- -- to
-
- -- for xP in [reverse] integer
- -- range etype'Pos (a) .. etype'Pos (b) loop
- -- declare
- -- x : constant etype := Pos_To_Rep (xP);
- -- begin
- -- ...
- -- end;
- -- end loop;
-
- if Present (Loop_Parameter_Specification (Isc)) then
+ elsif Present (Loop_Parameter_Specification (Isc)) then
declare
LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
New_Id : Entity_Id;
begin
- if not Is_Enumeration_Type (Btype)
- or else No (Enum_Pos_To_Rep (Btype))
+ -- Deal with loop over predicates
+
+ if Is_Discrete_Type (Ltype)
+ and then Present (Predicate_Function (Ltype))
then
- return;
- end if;
+ Expand_Predicated_Loop (N);
+
+ -- Handle the case where we have a for loop with the range type
+ -- being an enumeration type with non-standard representation.
+ -- In this case we expand:
+
+ -- for x in [reverse] a .. b loop
+ -- ...
+ -- end loop;
+
+ -- to
+
+ -- for xP in [reverse] integer
+ -- range etype'Pos (a) .. etype'Pos (b)
+ -- loop
+ -- declare
+ -- x : constant etype := Pos_To_Rep (xP);
+ -- begin
+ -- ...
+ -- end;
+ -- end loop;
+
+ elsif Is_Enumeration_Type (Btype)
+ and then Present (Enum_Pos_To_Rep (Btype))
+ then
+ New_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Loop_Id), 'P'));
- New_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Loop_Id), 'P'));
+ -- If the type has a contiguous representation, successive
+ -- values can be generated as offsets from the first literal.
- -- If the type has a contiguous representation, successive values
- -- can be generated as offsets from the first literal.
+ if Has_Contiguous_Rep (Btype) then
+ Expr :=
+ Unchecked_Convert_To (Btype,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Btype))),
+ Right_Opnd => New_Reference_To (New_Id, Loc)));
+ else
+ -- Use the constructed array Enum_Pos_To_Rep
- if Has_Contiguous_Rep (Btype) then
- Expr :=
- Unchecked_Convert_To (Btype,
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Integer_Literal (Loc,
- Enumeration_Rep (First_Literal (Btype))),
- Right_Opnd => New_Reference_To (New_Id, Loc)));
- else
- -- Use the constructed array Enum_Pos_To_Rep
+ Expr :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
+ Expressions =>
+ New_List (New_Reference_To (New_Id, Loc)));
+ end if;
- Expr :=
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
- Expressions => New_List (New_Reference_To (New_Id, Loc)));
- end if;
+ Rewrite (N,
+ Make_Loop_Statement (Loc,
+ Identifier => Identifier (N),
- Rewrite (N,
- Make_Loop_Statement (Loc,
- Identifier => Identifier (N),
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => New_Id,
+ Reverse_Present => Reverse_Present (LPS),
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => New_Id,
- Reverse_Present => Reverse_Present (LPS),
+ Discrete_Subtype_Definition =>
+ Make_Subtype_Indication (Loc,
- Discrete_Subtype_Definition =>
- Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Reference_To (Standard_Natural, Loc),
- Subtype_Mark =>
- New_Reference_To (Standard_Natural, Loc),
+ Constraint =>
+ Make_Range_Constraint (Loc,
+ Range_Expression =>
+ Make_Range (Loc,
- Constraint =>
- Make_Range_Constraint (Loc,
- Range_Expression =>
- Make_Range (Loc,
+ Low_Bound =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Btype, Loc),
- Low_Bound =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (Btype, Loc),
+ Attribute_Name => Name_Pos,
- Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Relocate_Node
+ (Type_Low_Bound (Ltype)))),
- Expressions => New_List (
- Relocate_Node
- (Type_Low_Bound (Ltype)))),
+ High_Bound =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Btype, Loc),
- High_Bound =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To (Btype, Loc),
+ Attribute_Name => Name_Pos,
- Attribute_Name => Name_Pos,
+ Expressions => New_List (
+ Relocate_Node
+ (Type_High_Bound
+ (Ltype))))))))),
- Expressions => New_List (
- Relocate_Node
- (Type_High_Bound (Ltype))))))))),
+ Statements => New_List (
+ Make_Block_Statement (Loc,
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Loop_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Ltype, Loc),
+ Expression => Expr)),
- Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Loop_Id,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Ltype, Loc),
- Expression => Expr)),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Statements (N)))),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements (N)))),
+ End_Label => End_Label (N)));
+ Analyze (N);
- End_Label => End_Label (N)));
- Analyze (N);
+ -- Nothing to do with other cases of for loops
+
+ else
+ null;
+ end if;
end;
-- Second case, if we have a while loop with Condition_Actions set, then
elsif Present (Isc)
and then Present (Condition_Actions (Isc))
+ and then Present (Condition (Isc))
then
declare
ES : Node_Id;
Analyze (N);
end;
- end if;
- end Expand_N_Loop_Statement;
-
- --------------------------------------
- -- Expand_N_Simple_Return_Statement --
- --------------------------------------
-
- procedure Expand_N_Simple_Return_Statement (N : Node_Id) is
- begin
- -- Distinguish the function and non-function cases:
-
- case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
-
- when E_Function |
- E_Generic_Function =>
- Expand_Simple_Function_Return (N);
- when E_Procedure |
- E_Generic_Procedure |
- E_Entry |
- E_Entry_Family |
- E_Return_Statement =>
- Expand_Non_Function_Return (N);
-
- when others =>
- raise Program_Error;
- end case;
+ -- Here to deal with iterator case
- exception
- when RE_Not_Available =>
- return;
- end Expand_N_Simple_Return_Statement;
-
- --------------------------------
- -- Expand_Non_Function_Return --
- --------------------------------
-
- procedure Expand_Non_Function_Return (N : Node_Id) is
- pragma Assert (No (Expression (N)));
-
- Loc : constant Source_Ptr := Sloc (N);
- Scope_Id : Entity_Id :=
- Return_Applies_To (Return_Statement_Entity (N));
- Kind : constant Entity_Kind := Ekind (Scope_Id);
- Call : Node_Id;
- Acc_Stat : Node_Id;
- Goto_Stat : Node_Id;
- Lab_Node : Node_Id;
-
- begin
- -- If it is a return from a procedure do no extra steps
-
- if Kind = E_Procedure or else Kind = E_Generic_Procedure then
- return;
-
- -- If it is a nested return within an extended one, replace it with a
- -- return of the previously declared return object.
-
- elsif Kind = E_Return_Statement then
- Rewrite (N,
- Make_Simple_Return_Statement (Loc,
- Expression =>
- New_Occurrence_Of (First_Entity (Scope_Id), Loc)));
- Set_Comes_From_Extended_Return_Statement (N);
- Set_Return_Statement_Entity (N, Scope_Id);
- Expand_Simple_Function_Return (N);
- return;
- end if;
-
- pragma Assert (Is_Entry (Scope_Id));
-
- -- Look at the enclosing block to see whether the return is from an
- -- accept statement or an entry body.
-
- for J in reverse 0 .. Scope_Stack.Last loop
- Scope_Id := Scope_Stack.Table (J).Entity;
- exit when Is_Concurrent_Type (Scope_Id);
- end loop;
-
- -- If it is a return from accept statement it is expanded as call to
- -- RTS Complete_Rendezvous and a goto to the end of the accept body.
-
- -- (cf : Expand_N_Accept_Statement, Expand_N_Selective_Accept,
- -- Expand_N_Accept_Alternative in exp_ch9.adb)
-
- if Is_Task_Type (Scope_Id) then
-
- Call :=
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Complete_Rendezvous), Loc));
- Insert_Before (N, Call);
- -- why not insert actions here???
- Analyze (Call);
-
- Acc_Stat := Parent (N);
- while Nkind (Acc_Stat) /= N_Accept_Statement loop
- Acc_Stat := Parent (Acc_Stat);
- end loop;
-
- Lab_Node := Last (Statements
- (Handled_Statement_Sequence (Acc_Stat)));
-
- Goto_Stat := Make_Goto_Statement (Loc,
- Name => New_Occurrence_Of
- (Entity (Identifier (Lab_Node)), Loc));
-
- Set_Analyzed (Goto_Stat);
-
- Rewrite (N, Goto_Stat);
- Analyze (N);
-
- -- If it is a return from an entry body, put a Complete_Entry_Body call
- -- in front of the return.
-
- 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,
- Prefix =>
- New_Reference_To
- (Object_Ref
- (Corresponding_Body (Parent (Scope_Id))),
- Loc),
- Attribute_Name => Name_Unchecked_Access)));
-
- Insert_Before (N, Call);
- Analyze (Call);
- end if;
- end Expand_Non_Function_Return;
-
- -----------------------------------
- -- Expand_Simple_Function_Return --
- -----------------------------------
-
- -- The "simple" comes from the syntax rule simple_return_statement.
- -- The semantics are not at all simple!
-
- procedure Expand_Simple_Function_Return (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
-
- Scope_Id : constant Entity_Id :=
- Return_Applies_To (Return_Statement_Entity (N));
- -- The function we are returning from
-
- R_Type : constant Entity_Id := Etype (Scope_Id);
- -- The result type of the function
-
- Utyp : constant Entity_Id := Underlying_Type (R_Type);
-
- Exp : constant Node_Id := Expression (N);
- pragma Assert (Present (Exp));
-
- Exptyp : constant Entity_Id := Etype (Exp);
- -- The type of the expression (not necessarily the same as R_Type)
-
- begin
- -- 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.
-
- -- 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.
-
- -- 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
- -- class-wide interface type, which is not a limited type, even though
- -- the type of the expression may be.
-
- 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 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);
-
- Obj_Decl : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Return_Object_Entity,
- Object_Definition => Subtype_Ind,
- Expression => Exp);
-
- Ext : constant Node_Id := Make_Extended_Return_Statement (Loc,
- Return_Object_Declarations => New_List (Obj_Decl));
-
- begin
- Rewrite (N, Ext);
- Analyze (N);
- return;
- end;
- end if;
-
- -- Here we have a simple return statement that is part of the expansion
- -- of an extended return statement (either written by the user, or
- -- generated by the above code).
-
- -- Always normalize C/Fortran boolean result. This is not always needed,
- -- but it seems a good idea to minimize the passing around of non-
- -- normalized values, and in any case this handles the processing of
- -- barrier functions for protected types, which turn the condition into
- -- a return statement.
-
- if Is_Boolean_Type (Exptyp)
- and then Nonzero_Is_True (Exptyp)
- then
- Adjust_Condition (Exp);
- Adjust_Result_Type (Exp, Exptyp);
- end if;
-
- -- Do validity check if enabled for returns
-
- if Validity_Checks_On
- and then Validity_Check_Returns
+ elsif Present (Isc)
+ and then Present (Iterator_Specification (Isc))
then
- Ensure_Valid (Exp);
+ Expand_Iterator_Loop (N);
end if;
+ end Expand_N_Loop_Statement;
- -- Check the result expression of a scalar function against the subtype
- -- of the function by inserting a conversion. This conversion must
- -- eventually be performed for other classes of types, but for now it's
- -- only done for scalars.
- -- ???
-
- if Is_Scalar_Type (Exptyp) then
- Rewrite (Exp, Convert_To (R_Type, Exp));
- Analyze (Exp);
- end if;
+ ----------------------------
+ -- Expand_Predicated_Loop --
+ ----------------------------
- -- Deal with returning variable length objects and controlled types
+ -- Note: the expander can handle generation of loops over predicated
+ -- subtypes for both the dynamic and static cases. Depending on what
+ -- we decide is allowed in Ada 2012 mode and/or extensions allowed
+ -- mode, the semantic analyzer may disallow one or both forms.
- -- Nothing to do if we are returning by reference, or this is not a
- -- type that requires special processing (indicated by the fact that
- -- it requires a cleanup scope for the secondary stack case).
+ procedure Expand_Predicated_Loop (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Isc : constant Node_Id := Iteration_Scheme (N);
+ LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
+ Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
+ Ltype : constant Entity_Id := Etype (Loop_Id);
+ Stat : constant List_Id := Static_Predicate (Ltype);
+ Stmts : constant List_Id := Statements (N);
- if Is_Inherently_Limited_Type (Exptyp)
- or else Is_Limited_Interface (Exptyp)
- then
- null;
+ begin
+ -- Case of iteration over non-static predicate, should not be possible
+ -- since this is not allowed by the semantics and should have been
+ -- caught during analysis of the loop statement.
- elsif not Requires_Transient_Scope (R_Type) then
+ if No (Stat) then
+ raise Program_Error;
- -- Mutable records with no variable length components are not
- -- returned on the sec-stack, so we need to make sure that the
- -- backend will only copy back the size of the actual value, and not
- -- the maximum size. We create an actual subtype for this purpose.
+ -- If the predicate list is empty, that corresponds to a predicate of
+ -- False, in which case the loop won't run at all, and we rewrite the
+ -- entire loop as a null statement.
- declare
- Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
- Decl : Node_Id;
- Ent : Entity_Id;
- begin
- if Has_Discriminants (Ubt)
- and then not Is_Constrained (Ubt)
- and then not Has_Unchecked_Union (Ubt)
- then
- Decl := Build_Actual_Subtype (Ubt, Exp);
- Ent := Defining_Identifier (Decl);
- Insert_Action (Exp, Decl);
- Rewrite (Exp, Unchecked_Convert_To (Ent, Exp));
- Analyze_And_Resolve (Exp);
- end if;
- end;
+ elsif Is_Empty_List (Stat) then
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
- -- Here if secondary stack is used
+ -- For expansion over a static predicate we generate the following
+
+ -- declare
+ -- J : Ltype := min-val;
+ -- begin
+ -- loop
+ -- body
+ -- case J is
+ -- when endpoint => J := startpoint;
+ -- when endpoint => J := startpoint;
+ -- ...
+ -- when max-val => exit;
+ -- when others => J := Lval'Succ (J);
+ -- end case;
+ -- end loop;
+ -- end;
+
+ -- To make this a little clearer, let's take a specific example:
+
+ -- type Int is range 1 .. 10;
+ -- subtype L is Int with
+ -- predicate => L in 3 | 10 | 5 .. 7;
+ -- ...
+ -- for L in StaticP loop
+ -- Put_Line ("static:" & J'Img);
+ -- end loop;
+
+ -- In this case, the loop is transformed into
+
+ -- begin
+ -- J : L := 3;
+ -- loop
+ -- body
+ -- case J is
+ -- when 3 => J := 5;
+ -- when 7 => J := 10;
+ -- when 10 => exit;
+ -- when others => J := L'Succ (J);
+ -- end case;
+ -- end loop;
+ -- end;
else
- -- Make sure that no surrounding block will reclaim the secondary
- -- stack on which we are going to put the result. Not only may this
- -- introduce secondary stack leaks but worse, if the reclamation is
- -- done too early, then the result we are returning may get
- -- clobbered.
-
- declare
- S : Entity_Id;
- begin
- S := Current_Scope;
- while Ekind (S) = E_Block or else Ekind (S) = E_Loop loop
- Set_Sec_Stack_Needed_For_Return (S, True);
- S := Enclosing_Dynamic_Scope (S);
- end loop;
- end;
-
- -- Optimize the case where the result is a function call. In this
- -- case either the result is already on the secondary stack, or is
- -- already being returned with the stack pointer depressed and no
- -- further processing is required except to set the By_Ref flag to
- -- ensure that gigi does not attempt an extra unnecessary copy.
- -- (actually not just unnecessary but harmfully wrong in the case
- -- of a controlled type, where gigi does not know how to do a copy).
- -- To make up for a gcc 2.8.1 deficiency (???), we perform
- -- the copy for array types if the constrained status of the
- -- target type is different from that of the expression.
-
- if Requires_Transient_Scope (Exptyp)
- and then
- (not Is_Array_Type (Exptyp)
- or else Is_Constrained (Exptyp) = Is_Constrained (R_Type)
- or else CW_Or_Controlled_Type (Utyp))
- and then Nkind (Exp) = N_Function_Call
- then
- Set_By_Ref (N);
-
- -- Remove side effects from the expression now so that other parts
- -- of the expander do not have to reanalyze this node without this
- -- optimization
-
- Rewrite (Exp, Duplicate_Subexpr_No_Checks (Exp));
-
- -- For controlled types, do the allocation on the secondary stack
- -- manually in order to call adjust at the right time:
-
- -- type Anon1 is access R_Type;
- -- for Anon1'Storage_pool use ss_pool;
- -- Anon2 : anon1 := new R_Type'(expr);
- -- return Anon2.all;
-
- -- We do the same for classwide types that are not potentially
- -- 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
- 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'));
- Alloc_Node : Node_Id;
-
+ Static_Predicate : declare
+ S : Node_Id;
+ D : Node_Id;
+ P : Node_Id;
+ Alts : List_Id;
+ Cstm : Node_Id;
+
+ function Lo_Val (N : Node_Id) return Node_Id;
+ -- Given static expression or static range, returns an identifier
+ -- whose value is the low bound of the expression value or range.
+
+ function Hi_Val (N : Node_Id) return Node_Id;
+ -- Given static expression or static range, returns an identifier
+ -- whose value is the high bound of the expression value or range.
+
+ ------------
+ -- Hi_Val --
+ ------------
+
+ function Hi_Val (N : Node_Id) return Node_Id is
begin
- Set_Ekind (Acc_Typ, E_Access_Type);
-
- Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
-
- Alloc_Node :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Reference_To (Etype (Exp), Loc),
- Expression => Relocate_Node (Exp)));
-
- 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))),
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Reference_To (Acc_Typ, Loc),
- Expression => Alloc_Node)));
-
- Rewrite (Exp,
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Temp, Loc)));
-
- Analyze_And_Resolve (Exp, R_Type);
- end;
-
- -- Otherwise use the gigi mechanism to allocate result on the
- -- secondary stack.
-
- else
- Set_Storage_Pool (N, RTE (RE_SS_Pool));
+ if Is_Static_Expression (N) then
+ return New_Copy (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return New_Copy (High_Bound (N));
+ end if;
+ end Hi_Val;
- -- If we are generating code for the VM do not use
- -- SS_Allocate since everything is heap-allocated anyway.
+ ------------
+ -- Lo_Val --
+ ------------
- if VM_Target = No_VM then
- Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
- end if;
- end if;
- end if;
+ function Lo_Val (N : Node_Id) return Node_Id is
+ begin
+ if Is_Static_Expression (N) then
+ return New_Copy (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return New_Copy (Low_Bound (N));
+ end if;
+ end Lo_Val;
- -- Implement the rules of 6.5(8-10), which require a tag check in the
- -- case of a limited tagged return type, and tag reassignment for
- -- nonlimited tagged results. These actions are needed when the return
- -- type is a specific tagged type and the result expression is a
- -- conversion or a formal parameter, because in that case the tag of the
- -- expression might differ from the tag of the specific result type.
-
- if Is_Tagged_Type (Utyp)
- and then not Is_Class_Wide_Type (Utyp)
- and then (Nkind (Exp) = N_Type_Conversion
- or else Nkind (Exp) = N_Unchecked_Type_Conversion
- or else (Is_Entity_Name (Exp)
- and then Ekind (Entity (Exp)) in Formal_Kind))
- then
- -- When the return type is limited, perform a check that the
- -- tag of the result is the same as the tag of the return type.
+ -- Start of processing for Static_Predicate
- if Is_Limited_Type (R_Type) then
- Insert_Action (Exp,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Selector_Name =>
- New_Reference_To (First_Tag_Component (Utyp), Loc)),
- Right_Opnd =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Node (First_Elmt
- (Access_Disp_Table (Base_Type (Utyp)))),
- Loc))),
- Reason => CE_Tag_Check_Failed));
-
- -- If the result type is a specific nonlimited tagged type, then we
- -- have to ensure that the tag of the result is that of the result
- -- type. This is handled by making a copy of the expression in the
- -- case where it might have a different tag, namely when the
- -- expression is a conversion or a formal parameter. We create a new
- -- object of the result type and initialize it from the expression,
- -- which will implicitly force the tag to be set appropriately.
+ begin
+ -- Convert loop identifier to normal variable and reanalyze it so
+ -- that this conversion works. We have to use the same defining
+ -- identifier, since there may be references in the loop body.
- else
- declare
- Result_Id : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
- Result_Exp : constant Node_Id :=
- New_Reference_To (Result_Id, Loc);
- 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));
+ Set_Analyzed (Loop_Id, False);
+ Set_Ekind (Loop_Id, E_Variable);
- begin
- Set_Assignment_OK (Result_Obj);
- Insert_Action (Exp, Result_Obj);
+ -- Loop to create branches of case statement
- Rewrite (Exp, Result_Exp);
- Analyze_And_Resolve (Exp, R_Type);
- end;
- end if;
+ Alts := New_List;
+ P := First (Stat);
+ while Present (P) loop
+ if No (Next (P)) then
+ S := Make_Exit_Statement (Loc);
+ else
+ S :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Loop_Id, Loc),
+ Expression => Lo_Val (Next (P)));
+ Set_Suppress_Assignment_Checks (S);
+ end if;
- -- Ada 2005 (AI-344): If the result type is class-wide, then insert
- -- a check that the level of the return expression's underlying type
- -- is not deeper than the level of the master enclosing the function.
- -- Always generate the check when the type of the return expression
- -- is class-wide, when it's a type conversion, or when it's a formal
- -- parameter. Otherwise, suppress the check in the case where the
- -- return expression has a specific type whose level is known not to
- -- be statically deeper than the function's result type.
+ Append_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Statements => New_List (S),
+ Discrete_Choices => New_List (Hi_Val (P))));
- -- Note: accessibility check is skipped in the VM case, since there
- -- does not seem to be any practical way to implement this check.
+ Next (P);
+ end loop;
- elsif Ada_Version >= Ada_05
- and then VM_Target = No_VM
- and then Is_Class_Wide_Type (R_Type)
- and then not Scope_Suppress (Accessibility_Check)
- and then
- (Is_Class_Wide_Type (Etype (Exp))
- or else Nkind (Exp) = N_Type_Conversion
- or else Nkind (Exp) = N_Unchecked_Type_Conversion
- or else (Is_Entity_Name (Exp)
- and then Ekind (Entity (Exp)) in Formal_Kind)
- or else Scope_Depth (Enclosing_Dynamic_Scope (Etype (Exp))) >
- Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))
- then
- declare
- Tag_Node : Node_Id;
+ -- Add others choice
+
+ S :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Loop_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ltype, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Occurrence_Of (Loop_Id, Loc))));
+ Set_Suppress_Assignment_Checks (S);
+
+ Append_To (Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (S)));
+
+ -- Construct case statement and append to body statements
+
+ Cstm :=
+ Make_Case_Statement (Loc,
+ Expression => New_Occurrence_Of (Loop_Id, Loc),
+ Alternatives => Alts);
+ Append_To (Stmts, Cstm);
+
+ -- Rewrite the loop
+
+ D :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Loop_Id,
+ Object_Definition => New_Occurrence_Of (Ltype, Loc),
+ Expression => Lo_Val (First (Stat)));
+ Set_Suppress_Assignment_Checks (D);
- begin
- -- Ada 2005 (AI-251): In class-wide interface objects we displace
- -- "this" to reference the base of the object --- required to get
- -- access to the TSD of the object.
-
- if Is_Class_Wide_Type (Etype (Exp))
- and then Is_Interface (Etype (Exp))
- and then Nkind (Exp) = N_Explicit_Dereference
- then
- Tag_Node :=
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Base_Address), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_Address),
- Duplicate_Subexpr (Prefix (Exp)))))));
- else
- Tag_Node :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Exp),
- Attribute_Name => Name_Tag);
- end if;
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Declarations => New_List (D),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Loop_Statement (Loc,
+ Statements => Stmts,
+ End_Label => Empty)))));
- Insert_Action (Exp,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Build_Get_Access_Level (Loc, Tag_Node),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Scope_Depth (Enclosing_Dynamic_Scope (Scope_Id)))),
- Reason => PE_Accessibility_Check_Failed));
- end;
+ Analyze (N);
+ end Static_Predicate;
end if;
- end Expand_Simple_Function_Return;
+ end Expand_Predicated_Loop;
------------------------------
-- Make_Tag_Ctrl_Assignment --
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 :=
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name =>
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
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To (RTE (RE_Finalizable),
New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Prev)),
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Unchecked_Convert_To (RTE (RE_Finalizable),
New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Next)),
OSDN Git Service
