This patch reimplements the expansion of attribute 'Loop_Entry. Instead of
performing the attribute and related loop transformation post-order, the same
actions are now carried out in-order. This allows for the proper type of the
constant to be propagated to the related context of the attribute.
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-04-24 Hristian Kirtchev <kirtc...@adacore.com>
* einfo.adb: Remove Loop_Entry_Attributes from the usage of
nodes. Flag 260 is now used.
(Has_Loop_Entry_Attributes): New routine.
(Loop_Entry_Attributes): Removed.
(Set_Has_Loop_Entry_Attributes): New routine.
(Set_Loop_Entry_Attributes): Removed.
(Write_Entity_Flags): Write out Flag 260.
(Write_Field10_Name): Remove the output for Loop_Entry_Attributes.
* einfo.ads: Remove attribute Loop_Entry_Attributes,
its related comment and uses in nodes. Add new attribute
Has_Loop_Entry_Attributes, related comment and uses in loop nodes.
(Has_Loop_Entry_Attributes): New routine and pragma Inline.
(Loop_Entry_Attributes): Removed along with pragma Inline.
(Set_Has_Loop_Entry_Attributes): New routine and pragma Inline.
(Set_Loop_Entry_Attributes): Removed along with pragma Inline.
* exp_attr.adb (Expand_Loop_Entry_Attribute): New routine.
(Expand_N_Attribute_Reference): Expand attribute 'Loop_Entry.
* exp_ch5.adb: Remove with and use clause for Elists.
(Expand_Loop_Entry_Attributes): Removed.
(Expand_N_Loop_Statement): Add local variable Stmt. Rename local
constant Isc to Scheme. When a loop is subject to attribute
'Loop_Entry, retrieve the nested loop from the conditional
block. Move the processing of controlled object at the end of
loop expansion.
* sem_attr.adb (Analyze_Attribute): Do not chain attribute
'Loop_Entry to its related loop.
* sem_ch5.adb (Analyze_Loop_Statement): Add local variable
Stmt. When the iteration scheme mentions attribute 'Loop_Entry,
the entire loop is rewritten into a block. Retrieve the nested
loop in such cases to complete the analysis.
* sem_util.ads, sem_util.adb (Find_Loop_In_Conditional_Block): New
routine.
(Subject_To_Loop_Entry_Attributes): New routine.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 198221)
+++ exp_ch5.adb (working copy)
@@ -28,7 +28,6 @@
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
-with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
@@ -111,10 +110,6 @@
procedure Expand_Iterator_Loop_Over_Array (N : Node_Id);
-- Expand loop over arrays that uses the form "for X of C"
- procedure Expand_Loop_Entry_Attributes (N : Node_Id);
- -- Given a loop statement subject to at least one Loop_Entry attribute,
- -- expand both the loop and all related Loop_Entry references.
-
procedure Expand_Predicated_Loop (N : Node_Id);
-- Expand for loop over predicated subtype
@@ -1527,347 +1522,6 @@
end;
end Expand_Assign_Record;
- ----------------------------------
- -- Expand_Loop_Entry_Attributes --
- ----------------------------------
-
- procedure Expand_Loop_Entry_Attributes (N : Node_Id) is
- procedure Build_Conditional_Block
- (Loc : Source_Ptr;
- Cond : Node_Id;
- Stmt : Node_Id;
- If_Stmt : out Node_Id;
- Blk_Stmt : out Node_Id);
- -- Create a block Blk_Stmt with an empty declarative list and a single
- -- statement Stmt. The block is encased in an if statement If_Stmt with
- -- condition Cond. If_Stmt is Empty when there is no condition provided.
-
- function Is_Array_Iteration (N : Node_Id) return Boolean;
- -- Determine whether loop statement N denotes an Ada 2012 iteration over
- -- an array object.
-
- -----------------------------
- -- Build_Conditional_Block --
- -----------------------------
-
- procedure Build_Conditional_Block
- (Loc : Source_Ptr;
- Cond : Node_Id;
- Stmt : Node_Id;
- If_Stmt : out Node_Id;
- Blk_Stmt : out Node_Id)
- is
- begin
- Blk_Stmt :=
- Make_Block_Statement (Loc,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt)));
-
- if Present (Cond) then
- If_Stmt :=
- Make_If_Statement (Loc,
- Condition => Cond,
- Then_Statements => New_List (Blk_Stmt));
- else
- If_Stmt := Empty;
- end if;
- end Build_Conditional_Block;
-
- ------------------------
- -- Is_Array_Iteration --
- ------------------------
-
- function Is_Array_Iteration (N : Node_Id) return Boolean is
- Stmt : constant Node_Id := Original_Node (N);
- Iter : Node_Id;
-
- begin
- if Nkind (Stmt) = N_Loop_Statement
- and then Present (Iteration_Scheme (Stmt))
- and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
- then
- Iter := Iterator_Specification (Iteration_Scheme (Stmt));
-
- return
- Of_Present (Iter)
- and then Is_Array_Type (Etype (Name (Iter)));
- end if;
-
- return False;
- end Is_Array_Iteration;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (N);
- Loop_Id : constant Entity_Id := Identifier (N);
- Scheme : constant Node_Id := Iteration_Scheme (N);
- Blk : Node_Id;
- LE : Node_Id;
- LE_Elmt : Elmt_Id;
- Result : Node_Id;
- Temp : Entity_Id;
- Typ : Entity_Id;
-
- -- Start of processing for Expand_Loop_Entry_Attributes
-
- begin
- -- The loop will never execute after it has been expanded, no point in
- -- processing it.
-
- if Is_Null_Loop (N) then
- return;
-
- -- A loop without an identifier cannot be referenced in 'Loop_Entry
-
- elsif No (Loop_Id) then
- return;
-
- -- The loop is not subject to 'Loop_Entry
-
- elsif No (Loop_Entry_Attributes (Entity (Loop_Id))) then
- return;
-
- -- Step 1: Loop transformations
-
- -- While loops are transformed into:
-
- -- if <Condition> then
- -- declare
- -- Temp1 : constant <type of Pref1> := <Pref1>;
- -- . . .
- -- TempN : constant <type of PrefN> := <PrefN>;
- -- begin
- -- loop
- -- <original source statements with attribute rewrites>
- -- exit when not <Condition>;
- -- end loop;
- -- end;
- -- end if;
-
- -- Note that loops over iterators and containers are already converted
- -- into while loops.
-
- elsif Present (Condition (Scheme)) then
- declare
- Cond : constant Node_Id := Condition (Scheme);
-
- begin
- -- Transform the original while loop into an infinite loop where
- -- the last statement checks the negated condition. This placement
- -- ensures that the condition will not be evaluated twice on the
- -- first iteration.
-
- -- Generate:
- -- exit when not <Cond>:
-
- Append_To (Statements (N),
- Make_Exit_Statement (Loc,
- Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond))));
-
- Build_Conditional_Block (Loc,
- Cond => Relocate_Node (Cond),
- Stmt => Relocate_Node (N),
- If_Stmt => Result,
- Blk_Stmt => Blk);
- end;
-
- -- Ada 2012 iteration over an array is transformed into:
-
- -- if <Array_Nam>'Length (1) > 0
- -- and then <Array_Nam>'Length (N) > 0
- -- then
- -- declare
- -- Temp1 : constant <type of Pref1> := <Pref1>;
- -- . . .
- -- TempN : constant <type of PrefN> := <PrefN>;
- -- begin
- -- for X in ... loop -- multiple loops depending on dims
- -- <original source statements with attribute rewrites>
- -- end loop;
- -- end;
- -- end if;
-
- elsif Is_Array_Iteration (N) then
- declare
- Array_Nam : constant Entity_Id :=
- Entity (Name (Iterator_Specification
- (Iteration_Scheme (Original_Node (N)))));
- Num_Dims : constant Pos :=
- Number_Dimensions (Etype (Array_Nam));
- Cond : Node_Id := Empty;
- Check : Node_Id;
- Top_Loop : Node_Id;
-
- begin
- -- Generate a check which determines whether all dimensions of
- -- the array are non-null.
-
- for Dim in 1 .. Num_Dims loop
- Check :=
- Make_Op_Gt (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Array_Nam, Loc),
- Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))),
- Right_Opnd =>
- Make_Integer_Literal (Loc, 0));
-
- if No (Cond) then
- Cond := Check;
- else
- Cond :=
- Make_And_Then (Loc,
- Left_Opnd => Cond,
- Right_Opnd => Check);
- end if;
- end loop;
-
- Top_Loop := Relocate_Node (N);
- Set_Analyzed (Top_Loop);
-
- Build_Conditional_Block (Loc,
- Cond => Cond,
- Stmt => Top_Loop,
- If_Stmt => Result,
- Blk_Stmt => Blk);
- end;
-
- -- For loops are transformed into:
-
- -- if <Low> <= <High> then
- -- declare
- -- Temp1 : constant <type of Pref1> := <Pref1>;
- -- . . .
- -- TempN : constant <type of PrefN> := <PrefN>;
- -- begin
- -- for <Def_Id> in <Low> .. <High> loop
- -- <original source statements with attribute rewrites>
- -- end loop;
- -- end;
- -- end if;
-
- elsif Present (Loop_Parameter_Specification (Scheme)) then
- declare
- Loop_Spec : constant Node_Id :=
- Loop_Parameter_Specification (Scheme);
- Cond : Node_Id;
- Subt_Def : Node_Id;
-
- begin
- Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
-
- -- When the loop iterates over a subtype indication with a range,
- -- use the low and high bounds of the subtype itself.
-
- if Nkind (Subt_Def) = N_Subtype_Indication then
- Subt_Def := Scalar_Range (Etype (Subt_Def));
- end if;
-
- pragma Assert (Nkind (Subt_Def) = N_Range);
-
- -- Generate
- -- Low <= High
-
- Cond :=
- Make_Op_Le (Loc,
- Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
- Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
-
- Build_Conditional_Block (Loc,
- Cond => Cond,
- Stmt => Relocate_Node (N),
- If_Stmt => Result,
- Blk_Stmt => Blk);
- end;
-
- -- Infinite loops are transformed into:
-
- -- declare
- -- Temp1 : constant <type of Pref1> := <Pref1>;
- -- . . .
- -- TempN : constant <type of PrefN> := <PrefN>;
- -- begin
- -- loop
- -- <original source statements with attribute rewrites>
- -- end loop;
- -- end;
-
- else
- Build_Conditional_Block (Loc,
- Cond => Empty,
- Stmt => Relocate_Node (N),
- If_Stmt => Result,
- Blk_Stmt => Blk);
-
- Result := Blk;
- end if;
-
- -- Step 2: Loop_Entry attribute transformations
-
- -- At this point the various loops have been augmented to contain a
- -- block. Populate the declarative list of the block with constants
- -- which store the value of their relative prefixes at the point of
- -- entry in the loop.
-
- LE_Elmt := First_Elmt (Loop_Entry_Attributes (Entity (Loop_Id)));
- while Present (LE_Elmt) loop
- LE := Node (LE_Elmt);
- Typ := Etype (Prefix (LE));
-
- -- Declare a constant to capture the value of the prefix of each
- -- Loop_Entry attribute.
-
- -- Generate:
- -- Temp : constant <type of Pref> := <Pref>;
-
- Temp := Make_Temporary (Loc, 'P');
-
- Append_To (Declarations (Blk),
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Typ, Loc),
- Expression => Relocate_Node (Prefix (LE))));
-
- -- Perform minor decoration as this information will be needed for
- -- the creation of index checks (if applicable).
-
- Set_Ekind (Temp, E_Constant);
- Set_Etype (Temp, Typ);
-
- -- Replace the original attribute with a reference to the constant
-
- Rewrite (LE, New_Reference_To (Temp, Loc));
- Set_Etype (LE, Typ);
-
- -- Analysis converts attribute references of the following form
-
- -- Prefix'Loop_Entry (Expr)
- -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN)
-
- -- into indexed components for error detection purposes. Generate
- -- index checks now that 'Loop_Entry has been properly expanded.
-
- if Nkind (Parent (LE)) = N_Indexed_Component then
- Generate_Index_Checks (Parent (LE));
- end if;
-
- Next_Elmt (LE_Elmt);
- end loop;
-
- -- Destroy the list of Loop_Entry attributes to prevent the infinite
- -- expansion when analyzing and expanding the newly generated loops.
-
- Set_Loop_Entry_Attributes (Entity (Loop_Id), No_Elist);
-
- Rewrite (N, Result);
- Analyze (N);
- end Expand_Loop_Entry_Attributes;
-
-----------------------------------
-- Expand_N_Assignment_Statement --
-----------------------------------
@@ -3777,8 +3431,9 @@
-- 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);
+ Loc : constant Source_Ptr := Sloc (N);
+ Scheme : constant Node_Id := Iteration_Scheme (N);
+ Stmt : Node_Id;
begin
-- Delete null loop
@@ -3788,12 +3443,10 @@
return;
end if;
- Process_Statements_For_Controlled_Objects (N);
-
-- Deal with condition for C/Fortran Boolean
- if Present (Isc) then
- Adjust_Condition (Condition (Isc));
+ if Present (Scheme) then
+ Adjust_Condition (Condition (Scheme));
end if;
-- Generate polling call
@@ -3804,7 +3457,7 @@
-- Nothing more to do for plain loop with no iteration scheme
- if No (Isc) then
+ if No (Scheme) then
null;
-- Case of for loop (Loop_Parameter_Specification present)
@@ -3813,9 +3466,10 @@
-- range bounds here, since they were frozen with constant declarations
-- and it is during that process that the validity checking is done.
- elsif Present (Loop_Parameter_Specification (Isc)) then
+ elsif Present (Loop_Parameter_Specification (Scheme)) then
declare
- LPS : constant Node_Id := Loop_Parameter_Specification (Isc);
+ LPS : constant Node_Id :=
+ Loop_Parameter_Specification (Scheme);
Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
Ltype : constant Entity_Id := Etype (Loop_Id);
Btype : constant Entity_Id := Base_Type (Ltype);
@@ -3990,22 +3644,22 @@
-- ...
-- end loop
- elsif Present (Isc)
- and then Present (Condition_Actions (Isc))
- and then Present (Condition (Isc))
+ elsif Present (Scheme)
+ and then Present (Condition_Actions (Scheme))
+ and then Present (Condition (Scheme))
then
declare
ES : Node_Id;
begin
ES :=
- Make_Exit_Statement (Sloc (Condition (Isc)),
+ Make_Exit_Statement (Sloc (Condition (Scheme)),
Condition =>
- Make_Op_Not (Sloc (Condition (Isc)),
- Right_Opnd => Condition (Isc)));
+ Make_Op_Not (Sloc (Condition (Scheme)),
+ Right_Opnd => Condition (Scheme)));
Prepend (ES, Statements (N));
- Insert_List_Before (ES, Condition_Actions (Isc));
+ Insert_List_Before (ES, Condition_Actions (Scheme));
-- This is not an implicit loop, since it is generated in response
-- to the loop statement being processed. If this is itself
@@ -4023,18 +3677,24 @@
-- Here to deal with iterator case
- elsif Present (Isc)
- and then Present (Iterator_Specification (Isc))
+ elsif Present (Scheme)
+ and then Present (Iterator_Specification (Scheme))
then
Expand_Iterator_Loop (N);
end if;
- -- If the loop is subject to at least one Loop_Entry attribute, it
- -- requires additional processing.
+ -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop
+ -- is transformed into a conditional block where the original loop is
+ -- the sole statement. Inspect the statements of the nested loop for
+ -- controlled objects.
- if Nkind (N) = N_Loop_Statement then
- Expand_Loop_Entry_Attributes (N);
+ Stmt := N;
+
+ if Subject_To_Loop_Entry_Attributes (Stmt) then
+ Stmt := Find_Loop_In_Conditional_Block (Stmt);
end if;
+
+ Process_Statements_For_Controlled_Objects (Stmt);
end Expand_N_Loop_Statement;
----------------------------
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb (revision 198234)
+++ sem_ch5.adb (working copy)
@@ -2545,6 +2545,7 @@
Iter : constant Node_Id := Iteration_Scheme (N);
Loc : constant Source_Ptr := Sloc (N);
Ent : Entity_Id;
+ Stmt : Node_Id;
-- Start of processing for Analyze_Loop_Statement
@@ -2707,13 +2708,22 @@
Analyze_Statements (Statements (N));
end if;
+ -- When the iteration scheme of a loop contains attribute 'Loop_Entry,
+ -- the loop is transformed into a conditional block. Retrieve the loop.
+
+ Stmt := N;
+
+ if Subject_To_Loop_Entry_Attributes (Stmt) then
+ Stmt := Find_Loop_In_Conditional_Block (Stmt);
+ end if;
+
-- Finish up processing for the loop. We kill all current values, since
-- in general we don't know if the statements in the loop have been
-- executed. We could do a bit better than this with a loop that we
-- know will execute at least once, but it's not worth the trouble and
-- the front end is not in the business of flow tracing.
- Process_End_Label (N, 'e', Ent);
+ Process_End_Label (Stmt, 'e', Ent);
End_Scope;
Kill_Current_Values;
@@ -2724,15 +2734,15 @@
-- before making this call, since Check_Infinite_Loop_Warning relies on
-- being able to use semantic visibility information to find references.
- if Comes_From_Source (N) then
- Check_Infinite_Loop_Warning (N);
+ if Comes_From_Source (Stmt) then
+ Check_Infinite_Loop_Warning (Stmt);
end if;
-- Code after loop is unreachable if the loop has no WHILE or FOR and
-- contains no EXIT statements within the body of the loop.
if No (Iter) and then not Has_Exit (Ent) then
- Check_Unreachable_Code (N);
+ Check_Unreachable_Code (Stmt);
end if;
end Analyze_Loop_Statement;
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 198221)
+++ exp_attr.adb (working copy)
@@ -136,6 +136,10 @@
-- that takes two floating-point arguments. The function to be called
-- is always the same as the attribute name.
+ procedure Expand_Loop_Entry_Attribute (Attr : Node_Id);
+ -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
+ -- loop may be converted into a conditional block. See body for details.
+
procedure Expand_Pred_Succ (N : Node_Id);
-- Handles expansion of Pred or Succ attributes for case of non-real
-- operand with overflow checking required.
@@ -635,10 +639,11 @@
-- by Expand_Fpt_Attribute
procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
- E1 : constant Node_Id := First (Expressions (N));
+ E1 : constant Node_Id := First (Expressions (N));
+ E2 : constant Node_Id := Next (E1);
Ftp : Entity_Id;
Pkg : RE_Id;
- E2 : constant Node_Id := Next (E1);
+
begin
Find_Fat_Info (Etype (E1), Ftp, Pkg);
Expand_Fpt_Attribute
@@ -648,6 +653,374 @@
Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RR;
+ ---------------------------------
+ -- Expand_Loop_Entry_Attribute --
+ ---------------------------------
+
+ procedure Expand_Loop_Entry_Attribute (Attr : Node_Id) is
+ procedure Build_Conditional_Block
+ (Loc : Source_Ptr;
+ Cond : Node_Id;
+ Loop_Stmt : Node_Id;
+ If_Stmt : out Node_Id;
+ Blk_Stmt : out Node_Id);
+ -- Create a block Blk_Stmt with an empty declarative list and a single
+ -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
+ -- condition Cond. If_Stmt is Empty when there is no condition provided.
+
+ function Is_Array_Iteration (N : Node_Id) return Boolean;
+ -- Determine whether loop statement N denotes an Ada 2012 iteration over
+ -- an array object.
+
+ -----------------------------
+ -- Build_Conditional_Block --
+ -----------------------------
+
+ procedure Build_Conditional_Block
+ (Loc : Source_Ptr;
+ Cond : Node_Id;
+ Loop_Stmt : Node_Id;
+ If_Stmt : out Node_Id;
+ Blk_Stmt : out Node_Id)
+ is
+ begin
+ -- Do not reanalyze the original loop statement because it is simply
+ -- being relocated.
+
+ Set_Analyzed (Loop_Stmt);
+
+ Blk_Stmt :=
+ Make_Block_Statement (Loc,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Loop_Stmt)));
+
+ if Present (Cond) then
+ If_Stmt :=
+ Make_If_Statement (Loc,
+ Condition => Cond,
+ Then_Statements => New_List (Blk_Stmt));
+ else
+ If_Stmt := Empty;
+ end if;
+ end Build_Conditional_Block;
+
+ ------------------------
+ -- Is_Array_Iteration --
+ ------------------------
+
+ function Is_Array_Iteration (N : Node_Id) return Boolean is
+ Stmt : constant Node_Id := Original_Node (N);
+ Iter : Node_Id;
+
+ begin
+ if Nkind (Stmt) = N_Loop_Statement
+ and then Present (Iteration_Scheme (Stmt))
+ and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
+ then
+ Iter := Iterator_Specification (Iteration_Scheme (Stmt));
+
+ return
+ Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
+ end if;
+
+ return False;
+ end Is_Array_Iteration;
+
+ -- Local variables
+
+ Exprs : constant List_Id := Expressions (Attr);
+ Pref : constant Node_Id := Prefix (Attr);
+ Typ : constant Entity_Id := Etype (Pref);
+ Blk : Node_Id;
+ Decls : List_Id;
+ Installed : Boolean;
+ Loc : Source_Ptr;
+ Loop_Id : Entity_Id;
+ Loop_Stmt : Node_Id;
+ Result : Node_Id;
+ Scheme : Node_Id;
+ Temp_Decl : Node_Id;
+ Temp_Id : Entity_Id;
+
+ -- Start of processing for Expand_Loop_Entry_Attribute
+
+ begin
+ -- Step 1: Find the related loop
+
+ -- The loop label variant of attribute 'Loop_Entry already has all the
+ -- information in its expression.
+
+ if Present (Exprs) then
+ Loop_Id := Entity (First (Exprs));
+ Loop_Stmt := Label_Construct (Parent (Loop_Id));
+
+ -- Climb the parent chain to find the nearest enclosing loop. Skip all
+ -- internally generated loops for quantified expressions.
+
+ else
+ Loop_Stmt := Attr;
+ while Present (Loop_Stmt) loop
+ if Nkind (Loop_Stmt) = N_Loop_Statement
+ and then Present (Identifier (Loop_Stmt))
+ then
+ exit;
+ end if;
+
+ Loop_Stmt := Parent (Loop_Stmt);
+ end loop;
+
+ Loop_Id := Entity (Identifier (Loop_Stmt));
+ end if;
+
+ Loc := Sloc (Loop_Stmt);
+
+ -- Step 2: Transform the loop
+
+ -- The loop has already been transformed during the expansion of a prior
+ -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
+
+ if Has_Loop_Entry_Attributes (Loop_Id) then
+ Decls := Declarations (Parent (Parent (Loop_Stmt)));
+ Result := Empty;
+
+ -- Transform the loop into a conditional block
+
+ else
+ Set_Has_Loop_Entry_Attributes (Loop_Id);
+ Scheme := Iteration_Scheme (Loop_Stmt);
+
+ -- While loops are transformed into:
+
+ -- if <Condition> then
+ -- declare
+ -- Temp1 : constant <type of Pref1> := <Pref1>;
+ -- . . .
+ -- TempN : constant <type of PrefN> := <PrefN>;
+ -- begin
+ -- loop
+ -- <original source statements with attribute rewrites>
+ -- exit when not <Condition>;
+ -- end loop;
+ -- end;
+ -- end if;
+
+ -- Note that loops over iterators and containers are already
+ -- converted into while loops.
+
+ if Present (Condition (Scheme)) then
+ declare
+ Cond : constant Node_Id := Condition (Scheme);
+
+ begin
+ -- Transform the original while loop into an infinite loop
+ -- where the last statement checks the negated condition. This
+ -- placement ensures that the condition will not be evaluated
+ -- twice on the first iteration.
+
+ -- Generate:
+ -- exit when not <Cond>:
+
+ Append_To (Statements (Loop_Stmt),
+ Make_Exit_Statement (Loc,
+ Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond))));
+
+ Build_Conditional_Block (Loc,
+ Cond => Relocate_Node (Cond),
+ Loop_Stmt => Relocate_Node (Loop_Stmt),
+ If_Stmt => Result,
+ Blk_Stmt => Blk);
+ end;
+
+ -- Ada 2012 iteration over an array is transformed into:
+
+ -- if <Array_Nam>'Length (1) > 0
+ -- and then <Array_Nam>'Length (N) > 0
+ -- then
+ -- declare
+ -- Temp1 : constant <type of Pref1> := <Pref1>;
+ -- . . .
+ -- TempN : constant <type of PrefN> := <PrefN>;
+ -- begin
+ -- for X in ... loop -- multiple loops depending on dims
+ -- <original source statements with attribute rewrites>
+ -- end loop;
+ -- end;
+ -- end if;
+
+ elsif Is_Array_Iteration (Loop_Stmt) then
+ declare
+ Array_Nam : constant Entity_Id :=
+ Entity (Name (Iterator_Specification
+ (Iteration_Scheme (Original_Node (Loop_Stmt)))));
+ Num_Dims : constant Pos :=
+ Number_Dimensions (Etype (Array_Nam));
+ Cond : Node_Id := Empty;
+ Check : Node_Id;
+
+ begin
+ -- Generate a check which determines whether all dimensions of
+ -- the array are non-null.
+
+ for Dim in 1 .. Num_Dims loop
+ Check :=
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Array_Nam, Loc),
+ Attribute_Name => Name_Length,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 0));
+
+ if No (Cond) then
+ Cond := Check;
+ else
+ Cond :=
+ Make_And_Then (Loc,
+ Left_Opnd => Cond,
+ Right_Opnd => Check);
+ end if;
+ end loop;
+
+ Build_Conditional_Block (Loc,
+ Cond => Cond,
+ Loop_Stmt => Relocate_Node (Loop_Stmt),
+ If_Stmt => Result,
+ Blk_Stmt => Blk);
+ end;
+
+ -- For loops are transformed into:
+
+ -- if <Low> <= <High> then
+ -- declare
+ -- Temp1 : constant <type of Pref1> := <Pref1>;
+ -- . . .
+ -- TempN : constant <type of PrefN> := <PrefN>;
+ -- begin
+ -- for <Def_Id> in <Low> .. <High> loop
+ -- <original source statements with attribute rewrites>
+ -- end loop;
+ -- end;
+ -- end if;
+
+ elsif Present (Loop_Parameter_Specification (Scheme)) then
+ declare
+ Loop_Spec : constant Node_Id :=
+ Loop_Parameter_Specification (Scheme);
+ Cond : Node_Id;
+ Subt_Def : Node_Id;
+
+ begin
+ Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
+
+ -- When the loop iterates over a subtype indication with a
+ -- range, use the low and high bounds of the subtype itself.
+
+ if Nkind (Subt_Def) = N_Subtype_Indication then
+ Subt_Def := Scalar_Range (Etype (Subt_Def));
+ end if;
+
+ pragma Assert (Nkind (Subt_Def) = N_Range);
+
+ -- Generate
+ -- Low <= High
+
+ Cond :=
+ Make_Op_Le (Loc,
+ Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
+ Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
+
+ Build_Conditional_Block (Loc,
+ Cond => Cond,
+ Loop_Stmt => Relocate_Node (Loop_Stmt),
+ If_Stmt => Result,
+ Blk_Stmt => Blk);
+ end;
+
+ -- Infinite loops are transformed into:
+
+ -- declare
+ -- Temp1 : constant <type of Pref1> := <Pref1>;
+ -- . . .
+ -- TempN : constant <type of PrefN> := <PrefN>;
+ -- begin
+ -- loop
+ -- <original source statements with attribute rewrites>
+ -- end loop;
+ -- end;
+
+ else
+ Build_Conditional_Block (Loc,
+ Cond => Empty,
+ Loop_Stmt => Relocate_Node (Loop_Stmt),
+ If_Stmt => Result,
+ Blk_Stmt => Blk);
+
+ Result := Blk;
+ end if;
+
+ Decls := Declarations (Blk);
+ end if;
+
+ -- Step 3: Create a constant to capture the value of the prefix at the
+ -- entry point into the loop.
+
+ -- Generate:
+ -- Temp : constant <type of Pref> := <Pref>;
+
+ Temp_Id := Make_Temporary (Loc, 'P');
+
+ Temp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Typ, Loc),
+ Expression => Relocate_Node (Pref));
+ Append_To (Decls, Temp_Decl);
+
+ -- Step 4: Analyze all bits
+
+ Rewrite (Attr, New_Reference_To (Temp_Id, Loc));
+
+ -- The analysis of the conditional block takes care of the constant
+ -- declaration.
+
+ Installed := Current_Scope = Loop_Id;
+
+ if not Installed then
+ Push_Scope (Scope (Loop_Id));
+ end if;
+
+ if Present (Result) then
+ Rewrite (Loop_Stmt, Result);
+ Analyze (Loop_Stmt);
+ else
+ Analyze (Temp_Decl);
+ end if;
+
+ Analyze (Attr);
+
+ -- Patch up a renaming of a 'Loop_Entry attribute. This case may arise
+ -- when the attribute is used as the name in an Ada 2012 iterator loop.
+
+ if Nkind (Parent (Attr)) = N_Object_Renaming_Declaration then
+ declare
+ Mark : constant Node_Id := Subtype_Mark (Parent (Attr));
+
+ begin
+ Rewrite (Mark, New_Reference_To (Etype (Temp_Id), Sloc (Mark)));
+ Analyze (Mark);
+ end;
+ end if;
+
+ if not Installed then
+ Pop_Scope;
+ end if;
+ end Expand_Loop_Entry_Attribute;
+
----------------------------------
-- Expand_N_Attribute_Reference --
----------------------------------
@@ -3138,11 +3511,12 @@
end if;
end Length;
- -- The expansion of this attribute is carried out when the target loop
- -- is processed. See Expand_Loop_Entry_Attributes for details.
+ -- Attribute Loop_Entry is replaced with a reference to a constant value
+ -- which captures the prefix at the entry point of the related loop. The
+ -- loop itself may be transformed into a conditional block.
when Attribute_Loop_Entry =>
- null;
+ Expand_Loop_Entry_Attribute (N);
-------------
-- Machine --
Index: einfo.adb
===================================================================
--- einfo.adb (revision 198221)
+++ einfo.adb (working copy)
@@ -93,7 +93,6 @@
-- Discriminal_Link Node10
-- Float_Rep Uint10 (but returns Float_Rep_Kind)
-- Handler_Records List10
- -- Loop_Entry_Attributes Elist10
-- Normalized_Position_Max Uint10
-- Component_Bit_Offset Uint11
@@ -548,9 +547,8 @@
-- Is_Invariant_Procedure Flag257
-- Has_Dynamic_Predicate_Aspect Flag258
-- Has_Static_Predicate_Aspect Flag259
+ -- Has_Loop_Entry_Attributes Flag260
- -- (unused) Flag260
-
-- (unused) Flag261
-- (unused) Flag262
-- (unused) Flag263
@@ -1467,6 +1465,12 @@
return Flag232 (Id);
end Has_Invariants;
+ function Has_Loop_Entry_Attributes (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Loop);
+ return Flag260 (Id);
+ end Has_Loop_Entry_Attributes;
+
function Has_Machine_Radix_Clause (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
@@ -2396,12 +2400,6 @@
return Node16 (Id);
end Lit_Strings;
- function Loop_Entry_Attributes (Id : E) return L is
- begin
- pragma Assert (Ekind (Id) = E_Loop);
- return Elist10 (Id);
- end Loop_Entry_Attributes;
-
function Low_Bound_Tested (Id : E) return B is
begin
return Flag205 (Id);
@@ -4051,6 +4049,12 @@
Set_Flag232 (Id, V);
end Set_Has_Invariants;
+ procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Loop);
+ Set_Flag260 (Id, V);
+ end Set_Has_Loop_Entry_Attributes;
+
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True) is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
@@ -5022,12 +5026,6 @@
Set_Node16 (Id, V);
end Set_Lit_Strings;
- procedure Set_Loop_Entry_Attributes (Id : E; V : L) is
- begin
- pragma Assert (Ekind (Id) = E_Loop);
- Set_Elist10 (Id, V);
- end Set_Loop_Entry_Attributes;
-
procedure Set_Low_Bound_Tested (Id : E; V : B := True) is
begin
pragma Assert (Is_Formal (Id));
@@ -7816,6 +7814,7 @@
W ("Has_Inheritable_Invariants", Flag248 (Id));
W ("Has_Initial_Value", Flag219 (Id));
W ("Has_Invariants", Flag232 (Id));
+ W ("Has_Loop_Entry_Attributes", Flag260 (Id));
W ("Has_Machine_Radix_Clause", Flag83 (Id));
W ("Has_Master_Entity", Flag21 (Id));
W ("Has_Missing_Return", Flag142 (Id));
@@ -8268,9 +8267,6 @@
E_Procedure =>
Write_Str ("Handler_Records");
- when E_Loop =>
- Write_Str ("Loop_Entry_Attributes");
-
when E_Component |
E_Discriminant =>
Write_Str ("Normalized_Position_Max");
Index: einfo.ads
===================================================================
--- einfo.ads (revision 198221)
+++ einfo.ads (working copy)
@@ -1598,6 +1598,11 @@
-- Note that it might be the full type which has inheritable invariants,
-- and then the flag will also be set in the private type.
+-- Has_Loop_Entry_Attributes (Flag260)
+-- Defined in E_Loop entities. Set when the loop is subject to at least
+-- one attribute 'Loop_Entry. The flag also implies that the loop has
+-- already been transformed. See Expand_Loop_Entry_Attribute for details.
+
-- Has_Machine_Radix_Clause (Flag83)
-- Defined in decimal types and subtypes, set if a Machine_Radix
-- representation clause is present. This flag is used to detect
@@ -3033,10 +3038,6 @@
-- the nature and use of this entity for implementing the Image and
-- Value attributes for the enumeration type in question.
--- Loop_Entry_Attributes (Elist10)
--- Defined for loop statement scopes. The list contains all Loop_Entry
--- attribute references related to the target loop.
-
-- Low_Bound_Tested (Flag205)
-- Defined in all entities. Currently this can only be set True for
-- formal parameter entries of a standard unconstrained one-dimensional
@@ -5507,8 +5508,8 @@
-- E_Loop
-- First_Exit_Statement (Node8)
- -- Loop_Entry_Attributes (Elist10)
-- Has_Exit (Flag47)
+ -- Has_Loop_Entry_Attributes (Flag260)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
@@ -6280,6 +6281,7 @@
function Has_Initial_Value (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
+ function Has_Loop_Entry_Attributes (Id : E) return B;
function Has_Machine_Radix_Clause (Id : E) return B;
function Has_Master_Entity (Id : E) return B;
function Has_Missing_Return (Id : E) return B;
@@ -6444,7 +6446,6 @@
function Limited_View (Id : E) return E;
function Lit_Indexes (Id : E) return E;
function Lit_Strings (Id : E) return E;
- function Loop_Entry_Attributes (Id : E) return L;
function Low_Bound_Tested (Id : E) return B;
function Machine_Radix_10 (Id : E) return B;
function Master_Id (Id : E) return E;
@@ -6887,6 +6888,7 @@
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True);
procedure Set_Has_Initial_Value (Id : E; V : B := True);
procedure Set_Has_Invariants (Id : E; V : B := True);
+ procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True);
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True);
procedure Set_Has_Master_Entity (Id : E; V : B := True);
procedure Set_Has_Missing_Return (Id : E; V : B := True);
@@ -7057,7 +7059,6 @@
procedure Set_Limited_View (Id : E; V : E);
procedure Set_Lit_Indexes (Id : E; V : E);
procedure Set_Lit_Strings (Id : E; V : E);
- procedure Set_Loop_Entry_Attributes (Id : E; V : L);
procedure Set_Low_Bound_Tested (Id : E; V : B := True);
procedure Set_Machine_Radix_10 (Id : E; V : B := True);
procedure Set_Master_Id (Id : E; V : E);
@@ -7586,6 +7587,7 @@
pragma Inline (Has_Inheritable_Invariants);
pragma Inline (Has_Initial_Value);
pragma Inline (Has_Invariants);
+ pragma Inline (Has_Loop_Entry_Attributes);
pragma Inline (Has_Machine_Radix_Clause);
pragma Inline (Has_Master_Entity);
pragma Inline (Has_Missing_Return);
@@ -7795,7 +7797,6 @@
pragma Inline (Limited_View);
pragma Inline (Lit_Indexes);
pragma Inline (Lit_Strings);
- pragma Inline (Loop_Entry_Attributes);
pragma Inline (Low_Bound_Tested);
pragma Inline (Machine_Radix_10);
pragma Inline (Master_Id);
@@ -8043,6 +8044,7 @@
pragma Inline (Set_Has_Inheritable_Invariants);
pragma Inline (Set_Has_Initial_Value);
pragma Inline (Set_Has_Invariants);
+ pragma Inline (Set_Has_Loop_Entry_Attributes);
pragma Inline (Set_Has_Machine_Radix_Clause);
pragma Inline (Set_Has_Master_Entity);
pragma Inline (Set_Has_Missing_Return);
@@ -8212,7 +8214,6 @@
pragma Inline (Set_Limited_View);
pragma Inline (Set_Lit_Indexes);
pragma Inline (Set_Lit_Strings);
- pragma Inline (Set_Loop_Entry_Attributes);
pragma Inline (Set_Low_Bound_Tested);
pragma Inline (Set_Machine_Radix_10);
pragma Inline (Set_Master_Id);
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 198234)
+++ sem_util.adb (working copy)
@@ -4740,6 +4740,41 @@
raise Program_Error;
end Find_Corresponding_Discriminant;
+ ------------------------------------
+ -- Find_Loop_In_Conditional_Block --
+ ------------------------------------
+
+ function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
+ Stmt : Node_Id;
+
+ begin
+ Stmt := N;
+
+ if Nkind (Stmt) = N_If_Statement then
+ Stmt := First (Then_Statements (Stmt));
+ end if;
+
+ pragma Assert (Nkind (Stmt) = N_Block_Statement);
+
+ -- Inspect the statements of the conditional block. In general the loop
+ -- should be the first statement in the statement sequence of the block,
+ -- but the finalization machinery may have introduced extra object
+ -- declarations.
+
+ Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Loop_Statement then
+ return Stmt;
+ end if;
+
+ Next (Stmt);
+ end loop;
+
+ -- The expansion of attribute 'Loop_Entry produced a malformed block
+
+ raise Program_Error;
+ end Find_Loop_In_Conditional_Block;
+
--------------------------
-- Find_Overlaid_Entity --
--------------------------
@@ -13870,6 +13905,33 @@
and then not Is_Formal (Entity (R2));
end Statically_Different;
+ --------------------------------------
+ -- Subject_To_Loop_Entry_Attributes --
+ --------------------------------------
+
+ function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
+ Stmt : Node_Id;
+
+ begin
+ Stmt := N;
+
+ -- The expansion mechanism transform a loop subject to at least one
+ -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
+ -- the conditional part.
+
+ if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
+ and then Nkind (Original_Node (N)) = N_Loop_Statement
+ then
+ Stmt := Original_Node (N);
+ end if;
+
+ return
+ Nkind (Stmt) = N_Loop_Statement
+ and then Present (Identifier (Stmt))
+ and then Present (Entity (Identifier (Stmt)))
+ and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
+ end Subject_To_Loop_Entry_Attributes;
+
-----------------------------
-- Subprogram_Access_Level --
-----------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 198221)
+++ sem_util.ads (working copy)
@@ -474,6 +474,11 @@
-- analyzed. Subsequent uses of this id on a different type denotes the
-- discriminant at the same position in this new type.
+ function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id;
+ -- Find the nested loop statement in a conditional block. Loops subject to
+ -- attribute 'Loop_Entry are transformed into blocks. Parts of the original
+ -- loop are nested within the block.
+
procedure Find_Overlaid_Entity
(N : Node_Id;
Ent : out Entity_Id;
@@ -1524,6 +1529,10 @@
-- Return True if it can be statically determined that the Expressions
-- E1 and E2 refer to different objects
+ function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean;
+ -- Determine whether node N is a loop statement subject to at least one
+ -- 'Loop_Entry attribute.
+
function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
-- Return the accessibility level of the view denoted by Subp
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 198234)
+++ sem_attr.adb (working copy)
@@ -3891,19 +3891,7 @@
Error_Attr_P ("prefix of attribute % must denote an entity");
end if;
- Set_Etype (N, Etype (P));
-
- -- Associate the attribute with its related loop
-
- if No (Loop_Entry_Attributes (Loop_Id)) then
- Set_Loop_Entry_Attributes (Loop_Id, New_Elmt_List);
- end if;
-
- -- A Loop_Entry may be [pre]analyzed several times, depending on the
- -- context. Ensure that it appears only once in the attributes list
- -- of the related loop.
-
- Append_Unique_Elmt (N, Loop_Entry_Attributes (Loop_Id));
+ Set_Etype (N, P_Type);
end Loop_Entry;
-------------
