Patchwork [Ada] Use of attribute 'Loop_Entry in various contexts

login
register
mail settings
Submitter Arnaud Charlet
Date April 24, 2013, 2:18 p.m.
Message ID <20130424141846.GA15109@adacore.com>
Download mbox | patch
Permalink /patch/239210/
State New
Headers show

Comments

Arnaud Charlet - April 24, 2013, 2:18 p.m.
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  <kirtchev@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.

Patch

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;
 
       -------------