File : exp_ch5.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 5                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25 
  26 with Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Aggr; use Exp_Aggr;
  34 with Exp_Ch6;  use Exp_Ch6;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Exp_Ch11; use Exp_Ch11;
  37 with Exp_Dbug; use Exp_Dbug;
  38 with Exp_Pakd; use Exp_Pakd;
  39 with Exp_Tss;  use Exp_Tss;
  40 with Exp_Util; use Exp_Util;
  41 with Ghost;    use Ghost;
  42 with Inline;   use Inline;
  43 with Namet;    use Namet;
  44 with Nlists;   use Nlists;
  45 with Nmake;    use Nmake;
  46 with Opt;      use Opt;
  47 with Restrict; use Restrict;
  48 with Rident;   use Rident;
  49 with Rtsfind;  use Rtsfind;
  50 with Sinfo;    use Sinfo;
  51 with Sem;      use Sem;
  52 with Sem_Aux;  use Sem_Aux;
  53 with Sem_Ch3;  use Sem_Ch3;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Ch13; use Sem_Ch13;
  56 with Sem_Eval; use Sem_Eval;
  57 with Sem_Res;  use Sem_Res;
  58 with Sem_Util; use Sem_Util;
  59 with Snames;   use Snames;
  60 with Stand;    use Stand;
  61 with Stringt;  use Stringt;
  62 with Tbuild;   use Tbuild;
  63 with Uintp;    use Uintp;
  64 with Validsw;  use Validsw;
  65 
  66 package body Exp_Ch5 is
  67 
  68    procedure Build_Formal_Container_Iteration
  69      (N         : Node_Id;
  70       Container : Entity_Id;
  71       Cursor    : Entity_Id;
  72       Init      : out Node_Id;
  73       Advance   : out Node_Id;
  74       New_Loop  : out Node_Id);
  75    --  Utility to create declarations and loop statement for both forms
  76    --  of formal container iterators.
  77 
  78    function Change_Of_Representation (N : Node_Id) return Boolean;
  79    --  Determine if the right hand side of assignment N is a type conversion
  80    --  which requires a change of representation. Called only for the array
  81    --  and record cases.
  82 
  83    procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id);
  84    --  N is an assignment which assigns an array value. This routine process
  85    --  the various special cases and checks required for such assignments,
  86    --  including change of representation. Rhs is normally simply the right
  87    --  hand side of the assignment, except that if the right hand side is a
  88    --  type conversion or a qualified expression, then the RHS is the actual
  89    --  expression inside any such type conversions or qualifications.
  90 
  91    function Expand_Assign_Array_Loop
  92      (N      : Node_Id;
  93       Larray : Entity_Id;
  94       Rarray : Entity_Id;
  95       L_Type : Entity_Id;
  96       R_Type : Entity_Id;
  97       Ndim   : Pos;
  98       Rev    : Boolean) return Node_Id;
  99    --  N is an assignment statement which assigns an array value. This routine
 100    --  expands the assignment into a loop (or nested loops for the case of a
 101    --  multi-dimensional array) to do the assignment component by component.
 102    --  Larray and Rarray are the entities of the actual arrays on the left
 103    --  hand and right hand sides. L_Type and R_Type are the types of these
 104    --  arrays (which may not be the same, due to either sliding, or to a
 105    --  change of representation case). Ndim is the number of dimensions and
 106    --  the parameter Rev indicates if the loops run normally (Rev = False),
 107    --  or reversed (Rev = True). The value returned is the constructed
 108    --  loop statement. Auxiliary declarations are inserted before node N
 109    --  using the standard Insert_Actions mechanism.
 110 
 111    procedure Expand_Assign_Record (N : Node_Id);
 112    --  N is an assignment of an untagged record value. This routine handles
 113    --  the case where the assignment must be made component by component,
 114    --  either because the target is not byte aligned, or there is a change
 115    --  of representation, or when we have a tagged type with a representation
 116    --  clause (this last case is required because holes in the tagged type
 117    --  might be filled with components from child types).
 118 
 119    procedure Expand_Formal_Container_Loop (N : Node_Id);
 120    --  Use the primitives specified in an Iterable aspect to expand a loop
 121    --  over a so-called formal container, primarily for SPARK usage.
 122 
 123    procedure Expand_Formal_Container_Element_Loop (N : Node_Id);
 124    --  Same, for an iterator of the form " For E of C". In this case the
 125    --  iterator provides the name of the element, and the cursor is generated
 126    --  internally.
 127 
 128    procedure Expand_Iterator_Loop (N : Node_Id);
 129    --  Expand loop over arrays and containers that uses the form "for X of C"
 130    --  with an optional subtype mark, or "for Y in C".
 131 
 132    procedure Expand_Iterator_Loop_Over_Container
 133      (N             : Node_Id;
 134       Isc           : Node_Id;
 135       I_Spec        : Node_Id;
 136       Container     : Node_Id;
 137       Container_Typ : Entity_Id);
 138    --  Expand loop over containers that uses the form "for X of C" with an
 139    --  optional subtype mark, or "for Y in C". Isc is the iteration scheme.
 140    --  I_Spec is the iterator specification and Container is either the
 141    --  Container (for OF) or the iterator (for IN).
 142 
 143    procedure Expand_Predicated_Loop (N : Node_Id);
 144    --  Expand for loop over predicated subtype
 145 
 146    function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
 147    --  Generate the necessary code for controlled and tagged assignment, that
 148    --  is to say, finalization of the target before, adjustment of the target
 149    --  after and save and restore of the tag and finalization pointers which
 150    --  are not 'part of the value' and must not be changed upon assignment. N
 151    --  is the original Assignment node.
 152 
 153    --------------------------------------
 154    -- Build_Formal_Container_iteration --
 155    --------------------------------------
 156 
 157    procedure Build_Formal_Container_Iteration
 158      (N         : Node_Id;
 159       Container : Entity_Id;
 160       Cursor    : Entity_Id;
 161       Init      : out Node_Id;
 162       Advance   : out Node_Id;
 163       New_Loop  : out Node_Id)
 164    is
 165       Loc      : constant Source_Ptr := Sloc (N);
 166       Stats    : constant List_Id    := Statements (N);
 167       Typ      : constant Entity_Id  := Base_Type (Etype (Container));
 168       First_Op : constant Entity_Id  :=
 169                    Get_Iterable_Type_Primitive (Typ, Name_First);
 170       Next_Op  : constant Entity_Id  :=
 171                    Get_Iterable_Type_Primitive (Typ, Name_Next);
 172 
 173       Has_Element_Op : constant Entity_Id :=
 174                    Get_Iterable_Type_Primitive (Typ, Name_Has_Element);
 175    begin
 176       --  Declaration for Cursor
 177 
 178       Init :=
 179         Make_Object_Declaration (Loc,
 180           Defining_Identifier => Cursor,
 181           Object_Definition   => New_Occurrence_Of (Etype (First_Op),  Loc),
 182           Expression          =>
 183             Make_Function_Call (Loc,
 184               Name                   => New_Occurrence_Of (First_Op, Loc),
 185               Parameter_Associations => New_List (
 186                 New_Occurrence_Of (Container, Loc))));
 187 
 188       --  Statement that advances cursor in loop
 189 
 190       Advance :=
 191         Make_Assignment_Statement (Loc,
 192           Name       => New_Occurrence_Of (Cursor, Loc),
 193           Expression =>
 194             Make_Function_Call (Loc,
 195               Name                   => New_Occurrence_Of (Next_Op, Loc),
 196               Parameter_Associations => New_List (
 197                 New_Occurrence_Of (Container, Loc),
 198                 New_Occurrence_Of (Cursor, Loc))));
 199 
 200       --  Iterator is rewritten as a while_loop
 201 
 202       New_Loop :=
 203         Make_Loop_Statement (Loc,
 204           Iteration_Scheme =>
 205             Make_Iteration_Scheme (Loc,
 206               Condition =>
 207                 Make_Function_Call (Loc,
 208                   Name => New_Occurrence_Of (Has_Element_Op, Loc),
 209                   Parameter_Associations => New_List (
 210                     New_Occurrence_Of (Container, Loc),
 211                     New_Occurrence_Of (Cursor, Loc)))),
 212           Statements       => Stats,
 213           End_Label        => Empty);
 214    end Build_Formal_Container_Iteration;
 215 
 216    ------------------------------
 217    -- Change_Of_Representation --
 218    ------------------------------
 219 
 220    function Change_Of_Representation (N : Node_Id) return Boolean is
 221       Rhs : constant Node_Id := Expression (N);
 222    begin
 223       return
 224         Nkind (Rhs) = N_Type_Conversion
 225           and then
 226             not Same_Representation (Etype (Rhs), Etype (Expression (Rhs)));
 227    end Change_Of_Representation;
 228 
 229    -------------------------
 230    -- Expand_Assign_Array --
 231    -------------------------
 232 
 233    --  There are two issues here. First, do we let Gigi do a block move, or
 234    --  do we expand out into a loop? Second, we need to set the two flags
 235    --  Forwards_OK and Backwards_OK which show whether the block move (or
 236    --  corresponding loops) can be legitimately done in a forwards (low to
 237    --  high) or backwards (high to low) manner.
 238 
 239    procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id) is
 240       Loc : constant Source_Ptr := Sloc (N);
 241 
 242       Lhs : constant Node_Id := Name (N);
 243 
 244       Act_Lhs : constant Node_Id := Get_Referenced_Object (Lhs);
 245       Act_Rhs : Node_Id          := Get_Referenced_Object (Rhs);
 246 
 247       L_Type : constant Entity_Id :=
 248                  Underlying_Type (Get_Actual_Subtype (Act_Lhs));
 249       R_Type : Entity_Id :=
 250                  Underlying_Type (Get_Actual_Subtype (Act_Rhs));
 251 
 252       L_Slice : constant Boolean := Nkind (Act_Lhs) = N_Slice;
 253       R_Slice : constant Boolean := Nkind (Act_Rhs) = N_Slice;
 254 
 255       Crep : constant Boolean := Change_Of_Representation (N);
 256 
 257       Larray  : Node_Id;
 258       Rarray  : Node_Id;
 259 
 260       Ndim : constant Pos := Number_Dimensions (L_Type);
 261 
 262       Loop_Required : Boolean := False;
 263       --  This switch is set to True if the array move must be done using
 264       --  an explicit front end generated loop.
 265 
 266       procedure Apply_Dereference (Arg : Node_Id);
 267       --  If the argument is an access to an array, and the assignment is
 268       --  converted into a procedure call, apply explicit dereference.
 269 
 270       function Has_Address_Clause (Exp : Node_Id) return Boolean;
 271       --  Test if Exp is a reference to an array whose declaration has
 272       --  an address clause, or it is a slice of such an array.
 273 
 274       function Is_Formal_Array (Exp : Node_Id) return Boolean;
 275       --  Test if Exp is a reference to an array which is either a formal
 276       --  parameter or a slice of a formal parameter. These are the cases
 277       --  where hidden aliasing can occur.
 278 
 279       function Is_Non_Local_Array (Exp : Node_Id) return Boolean;
 280       --  Determine if Exp is a reference to an array variable which is other
 281       --  than an object defined in the current scope, or a slice of such
 282       --  an object. Such objects can be aliased to parameters (unlike local
 283       --  array references).
 284 
 285       -----------------------
 286       -- Apply_Dereference --
 287       -----------------------
 288 
 289       procedure Apply_Dereference (Arg : Node_Id) is
 290          Typ : constant Entity_Id := Etype (Arg);
 291       begin
 292          if Is_Access_Type (Typ) then
 293             Rewrite (Arg, Make_Explicit_Dereference (Loc,
 294               Prefix => Relocate_Node (Arg)));
 295             Analyze_And_Resolve (Arg, Designated_Type (Typ));
 296          end if;
 297       end Apply_Dereference;
 298 
 299       ------------------------
 300       -- Has_Address_Clause --
 301       ------------------------
 302 
 303       function Has_Address_Clause (Exp : Node_Id) return Boolean is
 304       begin
 305          return
 306            (Is_Entity_Name (Exp) and then
 307                               Present (Address_Clause (Entity (Exp))))
 308              or else
 309            (Nkind (Exp) = N_Slice and then Has_Address_Clause (Prefix (Exp)));
 310       end Has_Address_Clause;
 311 
 312       ---------------------
 313       -- Is_Formal_Array --
 314       ---------------------
 315 
 316       function Is_Formal_Array (Exp : Node_Id) return Boolean is
 317       begin
 318          return
 319            (Is_Entity_Name (Exp) and then Is_Formal (Entity (Exp)))
 320              or else
 321            (Nkind (Exp) = N_Slice and then Is_Formal_Array (Prefix (Exp)));
 322       end Is_Formal_Array;
 323 
 324       ------------------------
 325       -- Is_Non_Local_Array --
 326       ------------------------
 327 
 328       function Is_Non_Local_Array (Exp : Node_Id) return Boolean is
 329       begin
 330          return (Is_Entity_Name (Exp)
 331                    and then Scope (Entity (Exp)) /= Current_Scope)
 332             or else (Nkind (Exp) = N_Slice
 333                        and then Is_Non_Local_Array (Prefix (Exp)));
 334       end Is_Non_Local_Array;
 335 
 336       --  Determine if Lhs, Rhs are formal arrays or nonlocal arrays
 337 
 338       Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
 339       Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs);
 340 
 341       Lhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Lhs);
 342       Rhs_Non_Local_Var : constant Boolean := Is_Non_Local_Array (Act_Rhs);
 343 
 344    --  Start of processing for Expand_Assign_Array
 345 
 346    begin
 347       --  Deal with length check. Note that the length check is done with
 348       --  respect to the right hand side as given, not a possible underlying
 349       --  renamed object, since this would generate incorrect extra checks.
 350 
 351       Apply_Length_Check (Rhs, L_Type);
 352 
 353       --  We start by assuming that the move can be done in either direction,
 354       --  i.e. that the two sides are completely disjoint.
 355 
 356       Set_Forwards_OK  (N, True);
 357       Set_Backwards_OK (N, True);
 358 
 359       --  Normally it is only the slice case that can lead to overlap, and
 360       --  explicit checks for slices are made below. But there is one case
 361       --  where the slice can be implicit and invisible to us: when we have a
 362       --  one dimensional array, and either both operands are parameters, or
 363       --  one is a parameter (which can be a slice passed by reference) and the
 364       --  other is a non-local variable. In this case the parameter could be a
 365       --  slice that overlaps with the other operand.
 366 
 367       --  However, if the array subtype is a constrained first subtype in the
 368       --  parameter case, then we don't have to worry about overlap, since
 369       --  slice assignments aren't possible (other than for a slice denoting
 370       --  the whole array).
 371 
 372       --  Note: No overlap is possible if there is a change of representation,
 373       --  so we can exclude this case.
 374 
 375       if Ndim = 1
 376         and then not Crep
 377         and then
 378            ((Lhs_Formal and Rhs_Formal)
 379               or else
 380             (Lhs_Formal and Rhs_Non_Local_Var)
 381               or else
 382             (Rhs_Formal and Lhs_Non_Local_Var))
 383         and then
 384            (not Is_Constrained (Etype (Lhs))
 385              or else not Is_First_Subtype (Etype (Lhs)))
 386       then
 387          Set_Forwards_OK  (N, False);
 388          Set_Backwards_OK (N, False);
 389 
 390          --  Note: the bit-packed case is not worrisome here, since if we have
 391          --  a slice passed as a parameter, it is always aligned on a byte
 392          --  boundary, and if there are no explicit slices, the assignment
 393          --  can be performed directly.
 394       end if;
 395 
 396       --  If either operand has an address clause clear Backwards_OK and
 397       --  Forwards_OK, since we cannot tell if the operands overlap. We
 398       --  exclude this treatment when Rhs is an aggregate, since we know
 399       --  that overlap can't occur.
 400 
 401       if (Has_Address_Clause (Lhs) and then Nkind (Rhs) /= N_Aggregate)
 402         or else Has_Address_Clause (Rhs)
 403       then
 404          Set_Forwards_OK  (N, False);
 405          Set_Backwards_OK (N, False);
 406       end if;
 407 
 408       --  We certainly must use a loop for change of representation and also
 409       --  we use the operand of the conversion on the right hand side as the
 410       --  effective right hand side (the component types must match in this
 411       --  situation).
 412 
 413       if Crep then
 414          Act_Rhs := Get_Referenced_Object (Rhs);
 415          R_Type  := Get_Actual_Subtype (Act_Rhs);
 416          Loop_Required := True;
 417 
 418       --  We require a loop if the left side is possibly bit unaligned
 419 
 420       elsif Possible_Bit_Aligned_Component (Lhs)
 421               or else
 422             Possible_Bit_Aligned_Component (Rhs)
 423       then
 424          Loop_Required := True;
 425 
 426       --  Arrays with controlled components are expanded into a loop to force
 427       --  calls to Adjust at the component level.
 428 
 429       elsif Has_Controlled_Component (L_Type) then
 430          Loop_Required := True;
 431 
 432       --  If object is atomic/VFA, we cannot tolerate a loop
 433 
 434       elsif Is_Atomic_Or_VFA_Object (Act_Lhs)
 435               or else
 436             Is_Atomic_Or_VFA_Object (Act_Rhs)
 437       then
 438          return;
 439 
 440       --  Loop is required if we have atomic components since we have to
 441       --  be sure to do any accesses on an element by element basis.
 442 
 443       elsif Has_Atomic_Components (L_Type)
 444         or else Has_Atomic_Components (R_Type)
 445         or else Is_Atomic_Or_VFA (Component_Type (L_Type))
 446         or else Is_Atomic_Or_VFA (Component_Type (R_Type))
 447       then
 448          Loop_Required := True;
 449 
 450       --  Case where no slice is involved
 451 
 452       elsif not L_Slice and not R_Slice then
 453 
 454          --  The following code deals with the case of unconstrained bit packed
 455          --  arrays. The problem is that the template for such arrays contains
 456          --  the bounds of the actual source level array, but the copy of an
 457          --  entire array requires the bounds of the underlying array. It would
 458          --  be nice if the back end could take care of this, but right now it
 459          --  does not know how, so if we have such a type, then we expand out
 460          --  into a loop, which is inefficient but works correctly. If we don't
 461          --  do this, we get the wrong length computed for the array to be
 462          --  moved. The two cases we need to worry about are:
 463 
 464          --  Explicit dereference of an unconstrained packed array type as in
 465          --  the following example:
 466 
 467          --    procedure C52 is
 468          --       type BITS is array(INTEGER range <>) of BOOLEAN;
 469          --       pragma PACK(BITS);
 470          --       type A is access BITS;
 471          --       P1,P2 : A;
 472          --    begin
 473          --       P1 := new BITS (1 .. 65_535);
 474          --       P2 := new BITS (1 .. 65_535);
 475          --       P2.ALL := P1.ALL;
 476          --    end C52;
 477 
 478          --  A formal parameter reference with an unconstrained bit array type
 479          --  is the other case we need to worry about (here we assume the same
 480          --  BITS type declared above):
 481 
 482          --    procedure Write_All (File : out BITS; Contents : BITS);
 483          --    begin
 484          --       File.Storage := Contents;
 485          --    end Write_All;
 486 
 487          --  We expand to a loop in either of these two cases
 488 
 489          --  Question for future thought. Another potentially more efficient
 490          --  approach would be to create the actual subtype, and then do an
 491          --  unchecked conversion to this actual subtype ???
 492 
 493          Check_Unconstrained_Bit_Packed_Array : declare
 494 
 495             function Is_UBPA_Reference (Opnd : Node_Id) return Boolean;
 496             --  Function to perform required test for the first case, above
 497             --  (dereference of an unconstrained bit packed array).
 498 
 499             -----------------------
 500             -- Is_UBPA_Reference --
 501             -----------------------
 502 
 503             function Is_UBPA_Reference (Opnd : Node_Id) return Boolean is
 504                Typ      : constant Entity_Id := Underlying_Type (Etype (Opnd));
 505                P_Type   : Entity_Id;
 506                Des_Type : Entity_Id;
 507 
 508             begin
 509                if Present (Packed_Array_Impl_Type (Typ))
 510                  and then Is_Array_Type (Packed_Array_Impl_Type (Typ))
 511                  and then not Is_Constrained (Packed_Array_Impl_Type (Typ))
 512                then
 513                   return True;
 514 
 515                elsif Nkind (Opnd) = N_Explicit_Dereference then
 516                   P_Type := Underlying_Type (Etype (Prefix (Opnd)));
 517 
 518                   if not Is_Access_Type (P_Type) then
 519                      return False;
 520 
 521                   else
 522                      Des_Type := Designated_Type (P_Type);
 523                      return
 524                        Is_Bit_Packed_Array (Des_Type)
 525                          and then not Is_Constrained (Des_Type);
 526                   end if;
 527 
 528                else
 529                   return False;
 530                end if;
 531             end Is_UBPA_Reference;
 532 
 533          --  Start of processing for Check_Unconstrained_Bit_Packed_Array
 534 
 535          begin
 536             if Is_UBPA_Reference (Lhs)
 537                  or else
 538                Is_UBPA_Reference (Rhs)
 539             then
 540                Loop_Required := True;
 541 
 542             --  Here if we do not have the case of a reference to a bit packed
 543             --  unconstrained array case. In this case gigi can most certainly
 544             --  handle the assignment if a forwards move is allowed.
 545 
 546             --  (could it handle the backwards case also???)
 547 
 548             elsif Forwards_OK (N) then
 549                return;
 550             end if;
 551          end Check_Unconstrained_Bit_Packed_Array;
 552 
 553       --  The back end can always handle the assignment if the right side is a
 554       --  string literal (note that overlap is definitely impossible in this
 555       --  case). If the type is packed, a string literal is always converted
 556       --  into an aggregate, except in the case of a null slice, for which no
 557       --  aggregate can be written. In that case, rewrite the assignment as a
 558       --  null statement, a length check has already been emitted to verify
 559       --  that the range of the left-hand side is empty.
 560 
 561       --  Note that this code is not executed if we have an assignment of a
 562       --  string literal to a non-bit aligned component of a record, a case
 563       --  which cannot be handled by the backend.
 564 
 565       elsif Nkind (Rhs) = N_String_Literal then
 566          if String_Length (Strval (Rhs)) = 0
 567            and then Is_Bit_Packed_Array (L_Type)
 568          then
 569             Rewrite (N, Make_Null_Statement (Loc));
 570             Analyze (N);
 571          end if;
 572 
 573          return;
 574 
 575       --  If either operand is bit packed, then we need a loop, since we can't
 576       --  be sure that the slice is byte aligned. Similarly, if either operand
 577       --  is a possibly unaligned slice, then we need a loop (since the back
 578       --  end cannot handle unaligned slices).
 579 
 580       elsif Is_Bit_Packed_Array (L_Type)
 581         or else Is_Bit_Packed_Array (R_Type)
 582         or else Is_Possibly_Unaligned_Slice (Lhs)
 583         or else Is_Possibly_Unaligned_Slice (Rhs)
 584       then
 585          Loop_Required := True;
 586 
 587       --  If we are not bit-packed, and we have only one slice, then no overlap
 588       --  is possible except in the parameter case, so we can let the back end
 589       --  handle things.
 590 
 591       elsif not (L_Slice and R_Slice) then
 592          if Forwards_OK (N) then
 593             return;
 594          end if;
 595       end if;
 596 
 597       --  If the right-hand side is a string literal, introduce a temporary for
 598       --  it, for use in the generated loop that will follow.
 599 
 600       if Nkind (Rhs) = N_String_Literal then
 601          declare
 602             Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Rhs);
 603             Decl : Node_Id;
 604 
 605          begin
 606             Decl :=
 607               Make_Object_Declaration (Loc,
 608                  Defining_Identifier => Temp,
 609                  Object_Definition => New_Occurrence_Of (L_Type, Loc),
 610                  Expression => Relocate_Node (Rhs));
 611 
 612             Insert_Action (N, Decl);
 613             Rewrite (Rhs, New_Occurrence_Of (Temp, Loc));
 614             R_Type := Etype (Temp);
 615          end;
 616       end if;
 617 
 618       --  Come here to complete the analysis
 619 
 620       --    Loop_Required: Set to True if we know that a loop is required
 621       --                   regardless of overlap considerations.
 622 
 623       --    Forwards_OK:   Set to False if we already know that a forwards
 624       --                   move is not safe, else set to True.
 625 
 626       --    Backwards_OK:  Set to False if we already know that a backwards
 627       --                   move is not safe, else set to True
 628 
 629       --  Our task at this stage is to complete the overlap analysis, which can
 630       --  result in possibly setting Forwards_OK or Backwards_OK to False, and
 631       --  then generating the final code, either by deciding that it is OK
 632       --  after all to let Gigi handle it, or by generating appropriate code
 633       --  in the front end.
 634 
 635       declare
 636          L_Index_Typ : constant Node_Id := Etype (First_Index (L_Type));
 637          R_Index_Typ : constant Node_Id := Etype (First_Index (R_Type));
 638 
 639          Left_Lo  : constant Node_Id := Type_Low_Bound  (L_Index_Typ);
 640          Left_Hi  : constant Node_Id := Type_High_Bound (L_Index_Typ);
 641          Right_Lo : constant Node_Id := Type_Low_Bound  (R_Index_Typ);
 642          Right_Hi : constant Node_Id := Type_High_Bound (R_Index_Typ);
 643 
 644          Act_L_Array : Node_Id;
 645          Act_R_Array : Node_Id;
 646 
 647          Cleft_Lo  : Node_Id;
 648          Cright_Lo : Node_Id;
 649          Condition : Node_Id;
 650 
 651          Cresult : Compare_Result;
 652 
 653       begin
 654          --  Get the expressions for the arrays. If we are dealing with a
 655          --  private type, then convert to the underlying type. We can do
 656          --  direct assignments to an array that is a private type, but we
 657          --  cannot assign to elements of the array without this extra
 658          --  unchecked conversion.
 659 
 660          --  Note: We propagate Parent to the conversion nodes to generate
 661          --  a well-formed subtree.
 662 
 663          if Nkind (Act_Lhs) = N_Slice then
 664             Larray := Prefix (Act_Lhs);
 665          else
 666             Larray := Act_Lhs;
 667 
 668             if Is_Private_Type (Etype (Larray)) then
 669                declare
 670                   Par : constant Node_Id := Parent (Larray);
 671                begin
 672                   Larray :=
 673                     Unchecked_Convert_To
 674                       (Underlying_Type (Etype (Larray)), Larray);
 675                   Set_Parent (Larray, Par);
 676                end;
 677             end if;
 678          end if;
 679 
 680          if Nkind (Act_Rhs) = N_Slice then
 681             Rarray := Prefix (Act_Rhs);
 682          else
 683             Rarray := Act_Rhs;
 684 
 685             if Is_Private_Type (Etype (Rarray)) then
 686                declare
 687                   Par : constant Node_Id := Parent (Rarray);
 688                begin
 689                   Rarray :=
 690                     Unchecked_Convert_To
 691                       (Underlying_Type (Etype (Rarray)), Rarray);
 692                   Set_Parent (Rarray, Par);
 693                end;
 694             end if;
 695          end if;
 696 
 697          --  If both sides are slices, we must figure out whether it is safe
 698          --  to do the move in one direction or the other. It is always safe
 699          --  if there is a change of representation since obviously two arrays
 700          --  with different representations cannot possibly overlap.
 701 
 702          if (not Crep) and L_Slice and R_Slice then
 703             Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs));
 704             Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs));
 705 
 706             --  If both left and right hand arrays are entity names, and refer
 707             --  to different entities, then we know that the move is safe (the
 708             --  two storage areas are completely disjoint).
 709 
 710             if Is_Entity_Name (Act_L_Array)
 711               and then Is_Entity_Name (Act_R_Array)
 712               and then Entity (Act_L_Array) /= Entity (Act_R_Array)
 713             then
 714                null;
 715 
 716             --  Otherwise, we assume the worst, which is that the two arrays
 717             --  are the same array. There is no need to check if we know that
 718             --  is the case, because if we don't know it, we still have to
 719             --  assume it.
 720 
 721             --  Generally if the same array is involved, then we have an
 722             --  overlapping case. We will have to really assume the worst (i.e.
 723             --  set neither of the OK flags) unless we can determine the lower
 724             --  or upper bounds at compile time and compare them.
 725 
 726             else
 727                Cresult :=
 728                  Compile_Time_Compare
 729                    (Left_Lo, Right_Lo, Assume_Valid => True);
 730 
 731                if Cresult = Unknown then
 732                   Cresult :=
 733                     Compile_Time_Compare
 734                       (Left_Hi, Right_Hi, Assume_Valid => True);
 735                end if;
 736 
 737                case Cresult is
 738                   when LT | LE | EQ => Set_Backwards_OK (N, False);
 739                   when GT | GE      => Set_Forwards_OK  (N, False);
 740                   when NE | Unknown => Set_Backwards_OK (N, False);
 741                                        Set_Forwards_OK  (N, False);
 742                end case;
 743             end if;
 744          end if;
 745 
 746          --  If after that analysis Loop_Required is False, meaning that we
 747          --  have not discovered some non-overlap reason for requiring a loop,
 748          --  then the outcome depends on the capabilities of the back end.
 749 
 750          if not Loop_Required then
 751             --  Assume the back end can deal with all cases of overlap by
 752             --  falling back to memmove if it cannot use a more efficient
 753             --  approach.
 754 
 755             return;
 756          end if;
 757 
 758          --  At this stage we have to generate an explicit loop, and we have
 759          --  the following cases:
 760 
 761          --  Forwards_OK = True
 762 
 763          --    Rnn : right_index := right_index'First;
 764          --    for Lnn in left-index loop
 765          --       left (Lnn) := right (Rnn);
 766          --       Rnn := right_index'Succ (Rnn);
 767          --    end loop;
 768 
 769          --    Note: the above code MUST be analyzed with checks off, because
 770          --    otherwise the Succ could overflow. But in any case this is more
 771          --    efficient.
 772 
 773          --  Forwards_OK = False, Backwards_OK = True
 774 
 775          --    Rnn : right_index := right_index'Last;
 776          --    for Lnn in reverse left-index loop
 777          --       left (Lnn) := right (Rnn);
 778          --       Rnn := right_index'Pred (Rnn);
 779          --    end loop;
 780 
 781          --    Note: the above code MUST be analyzed with checks off, because
 782          --    otherwise the Pred could overflow. But in any case this is more
 783          --    efficient.
 784 
 785          --  Forwards_OK = Backwards_OK = False
 786 
 787          --    This only happens if we have the same array on each side. It is
 788          --    possible to create situations using overlays that violate this,
 789          --    but we simply do not promise to get this "right" in this case.
 790 
 791          --    There are two possible subcases. If the No_Implicit_Conditionals
 792          --    restriction is set, then we generate the following code:
 793 
 794          --      declare
 795          --        T : constant <operand-type> := rhs;
 796          --      begin
 797          --        lhs := T;
 798          --      end;
 799 
 800          --    If implicit conditionals are permitted, then we generate:
 801 
 802          --      if Left_Lo <= Right_Lo then
 803          --         <code for Forwards_OK = True above>
 804          --      else
 805          --         <code for Backwards_OK = True above>
 806          --      end if;
 807 
 808          --  In order to detect possible aliasing, we examine the renamed
 809          --  expression when the source or target is a renaming. However,
 810          --  the renaming may be intended to capture an address that may be
 811          --  affected by subsequent code, and therefore we must recover
 812          --  the actual entity for the expansion that follows, not the
 813          --  object it renames. In particular, if source or target designate
 814          --  a portion of a dynamically allocated object, the pointer to it
 815          --  may be reassigned but the renaming preserves the proper location.
 816 
 817          if Is_Entity_Name (Rhs)
 818            and then
 819              Nkind (Parent (Entity (Rhs))) = N_Object_Renaming_Declaration
 820            and then Nkind (Act_Rhs) = N_Slice
 821          then
 822             Rarray := Rhs;
 823          end if;
 824 
 825          if Is_Entity_Name (Lhs)
 826            and then
 827              Nkind (Parent (Entity (Lhs))) = N_Object_Renaming_Declaration
 828            and then Nkind (Act_Lhs) = N_Slice
 829          then
 830             Larray := Lhs;
 831          end if;
 832 
 833          --  Cases where either Forwards_OK or Backwards_OK is true
 834 
 835          if Forwards_OK (N) or else Backwards_OK (N) then
 836             if Needs_Finalization (Component_Type (L_Type))
 837               and then Base_Type (L_Type) = Base_Type (R_Type)
 838               and then Ndim = 1
 839               and then not No_Ctrl_Actions (N)
 840             then
 841                declare
 842                   Proc    : constant Entity_Id :=
 843                               TSS (Base_Type (L_Type), TSS_Slice_Assign);
 844                   Actuals : List_Id;
 845 
 846                begin
 847                   Apply_Dereference (Larray);
 848                   Apply_Dereference (Rarray);
 849                   Actuals := New_List (
 850                     Duplicate_Subexpr (Larray,   Name_Req => True),
 851                     Duplicate_Subexpr (Rarray,   Name_Req => True),
 852                     Duplicate_Subexpr (Left_Lo,  Name_Req => True),
 853                     Duplicate_Subexpr (Left_Hi,  Name_Req => True),
 854                     Duplicate_Subexpr (Right_Lo, Name_Req => True),
 855                     Duplicate_Subexpr (Right_Hi, Name_Req => True));
 856 
 857                   Append_To (Actuals,
 858                     New_Occurrence_Of (
 859                       Boolean_Literals (not Forwards_OK (N)), Loc));
 860 
 861                   Rewrite (N,
 862                     Make_Procedure_Call_Statement (Loc,
 863                       Name => New_Occurrence_Of (Proc, Loc),
 864                       Parameter_Associations => Actuals));
 865                end;
 866 
 867             else
 868                Rewrite (N,
 869                  Expand_Assign_Array_Loop
 870                    (N, Larray, Rarray, L_Type, R_Type, Ndim,
 871                     Rev => not Forwards_OK (N)));
 872             end if;
 873 
 874          --  Case of both are false with No_Implicit_Conditionals
 875 
 876          elsif Restriction_Active (No_Implicit_Conditionals) then
 877             declare
 878                   T : constant Entity_Id :=
 879                         Make_Defining_Identifier (Loc, Chars => Name_T);
 880 
 881             begin
 882                Rewrite (N,
 883                  Make_Block_Statement (Loc,
 884                   Declarations => New_List (
 885                     Make_Object_Declaration (Loc,
 886                       Defining_Identifier => T,
 887                       Constant_Present  => True,
 888                       Object_Definition =>
 889                         New_Occurrence_Of (Etype (Rhs), Loc),
 890                       Expression        => Relocate_Node (Rhs))),
 891 
 892                     Handled_Statement_Sequence =>
 893                       Make_Handled_Sequence_Of_Statements (Loc,
 894                         Statements => New_List (
 895                           Make_Assignment_Statement (Loc,
 896                             Name       => Relocate_Node (Lhs),
 897                             Expression => New_Occurrence_Of (T, Loc))))));
 898             end;
 899 
 900          --  Case of both are false with implicit conditionals allowed
 901 
 902          else
 903             --  Before we generate this code, we must ensure that the left and
 904             --  right side array types are defined. They may be itypes, and we
 905             --  cannot let them be defined inside the if, since the first use
 906             --  in the then may not be executed.
 907 
 908             Ensure_Defined (L_Type, N);
 909             Ensure_Defined (R_Type, N);
 910 
 911             --  We normally compare addresses to find out which way round to
 912             --  do the loop, since this is reliable, and handles the cases of
 913             --  parameters, conversions etc. But we can't do that in the bit
 914             --  packed case, because addresses don't work there.
 915 
 916             if not Is_Bit_Packed_Array (L_Type) then
 917                Condition :=
 918                  Make_Op_Le (Loc,
 919                    Left_Opnd =>
 920                      Unchecked_Convert_To (RTE (RE_Integer_Address),
 921                        Make_Attribute_Reference (Loc,
 922                          Prefix =>
 923                            Make_Indexed_Component (Loc,
 924                              Prefix =>
 925                                Duplicate_Subexpr_Move_Checks (Larray, True),
 926                              Expressions => New_List (
 927                                Make_Attribute_Reference (Loc,
 928                                  Prefix =>
 929                                    New_Occurrence_Of
 930                                      (L_Index_Typ, Loc),
 931                                  Attribute_Name => Name_First))),
 932                          Attribute_Name => Name_Address)),
 933 
 934                    Right_Opnd =>
 935                      Unchecked_Convert_To (RTE (RE_Integer_Address),
 936                        Make_Attribute_Reference (Loc,
 937                          Prefix =>
 938                            Make_Indexed_Component (Loc,
 939                              Prefix =>
 940                                Duplicate_Subexpr_Move_Checks (Rarray, True),
 941                              Expressions => New_List (
 942                                Make_Attribute_Reference (Loc,
 943                                  Prefix =>
 944                                    New_Occurrence_Of
 945                                      (R_Index_Typ, Loc),
 946                                  Attribute_Name => Name_First))),
 947                          Attribute_Name => Name_Address)));
 948 
 949             --  For the bit packed and VM cases we use the bounds. That's OK,
 950             --  because we don't have to worry about parameters, since they
 951             --  cannot cause overlap. Perhaps we should worry about weird slice
 952             --  conversions ???
 953 
 954             else
 955                --  Copy the bounds
 956 
 957                Cleft_Lo  := New_Copy_Tree (Left_Lo);
 958                Cright_Lo := New_Copy_Tree (Right_Lo);
 959 
 960                --  If the types do not match we add an implicit conversion
 961                --  here to ensure proper match
 962 
 963                if Etype (Left_Lo) /= Etype (Right_Lo) then
 964                   Cright_Lo :=
 965                     Unchecked_Convert_To (Etype (Left_Lo), Cright_Lo);
 966                end if;
 967 
 968                --  Reset the Analyzed flag, because the bounds of the index
 969                --  type itself may be universal, and must must be reanalyzed
 970                --  to acquire the proper type for the back end.
 971 
 972                Set_Analyzed (Cleft_Lo, False);
 973                Set_Analyzed (Cright_Lo, False);
 974 
 975                Condition :=
 976                  Make_Op_Le (Loc,
 977                    Left_Opnd  => Cleft_Lo,
 978                    Right_Opnd => Cright_Lo);
 979             end if;
 980 
 981             if Needs_Finalization (Component_Type (L_Type))
 982               and then Base_Type (L_Type) = Base_Type (R_Type)
 983               and then Ndim = 1
 984               and then not No_Ctrl_Actions (N)
 985             then
 986 
 987                --  Call TSS procedure for array assignment, passing the
 988                --  explicit bounds of right and left hand sides.
 989 
 990                declare
 991                   Proc    : constant Entity_Id :=
 992                               TSS (Base_Type (L_Type), TSS_Slice_Assign);
 993                   Actuals : List_Id;
 994 
 995                begin
 996                   Apply_Dereference (Larray);
 997                   Apply_Dereference (Rarray);
 998                   Actuals := New_List (
 999                     Duplicate_Subexpr (Larray,   Name_Req => True),
1000                     Duplicate_Subexpr (Rarray,   Name_Req => True),
1001                     Duplicate_Subexpr (Left_Lo,  Name_Req => True),
1002                     Duplicate_Subexpr (Left_Hi,  Name_Req => True),
1003                     Duplicate_Subexpr (Right_Lo, Name_Req => True),
1004                     Duplicate_Subexpr (Right_Hi, Name_Req => True));
1005 
1006                   Append_To (Actuals,
1007                      Make_Op_Not (Loc,
1008                        Right_Opnd => Condition));
1009 
1010                   Rewrite (N,
1011                     Make_Procedure_Call_Statement (Loc,
1012                       Name => New_Occurrence_Of (Proc, Loc),
1013                       Parameter_Associations => Actuals));
1014                end;
1015 
1016             else
1017                Rewrite (N,
1018                  Make_Implicit_If_Statement (N,
1019                    Condition => Condition,
1020 
1021                    Then_Statements => New_List (
1022                      Expand_Assign_Array_Loop
1023                       (N, Larray, Rarray, L_Type, R_Type, Ndim,
1024                        Rev => False)),
1025 
1026                    Else_Statements => New_List (
1027                      Expand_Assign_Array_Loop
1028                       (N, Larray, Rarray, L_Type, R_Type, Ndim,
1029                        Rev => True))));
1030             end if;
1031          end if;
1032 
1033          Analyze (N, Suppress => All_Checks);
1034       end;
1035 
1036    exception
1037       when RE_Not_Available =>
1038          return;
1039    end Expand_Assign_Array;
1040 
1041    ------------------------------
1042    -- Expand_Assign_Array_Loop --
1043    ------------------------------
1044 
1045    --  The following is an example of the loop generated for the case of a
1046    --  two-dimensional array:
1047 
1048    --    declare
1049    --       R2b : Tm1X1 := 1;
1050    --    begin
1051    --       for L1b in 1 .. 100 loop
1052    --          declare
1053    --             R4b : Tm1X2 := 1;
1054    --          begin
1055    --             for L3b in 1 .. 100 loop
1056    --                vm1 (L1b, L3b) := vm2 (R2b, R4b);
1057    --                R4b := Tm1X2'succ(R4b);
1058    --             end loop;
1059    --          end;
1060    --          R2b := Tm1X1'succ(R2b);
1061    --       end loop;
1062    --    end;
1063 
1064    --  Here Rev is False, and Tm1Xn are the subscript types for the right hand
1065    --  side. The declarations of R2b and R4b are inserted before the original
1066    --  assignment statement.
1067 
1068    function Expand_Assign_Array_Loop
1069      (N      : Node_Id;
1070       Larray : Entity_Id;
1071       Rarray : Entity_Id;
1072       L_Type : Entity_Id;
1073       R_Type : Entity_Id;
1074       Ndim   : Pos;
1075       Rev    : Boolean) return Node_Id
1076    is
1077       Loc  : constant Source_Ptr := Sloc (N);
1078 
1079       Lnn : array (1 .. Ndim) of Entity_Id;
1080       Rnn : array (1 .. Ndim) of Entity_Id;
1081       --  Entities used as subscripts on left and right sides
1082 
1083       L_Index_Type : array (1 .. Ndim) of Entity_Id;
1084       R_Index_Type : array (1 .. Ndim) of Entity_Id;
1085       --  Left and right index types
1086 
1087       Assign : Node_Id;
1088 
1089       F_Or_L : Name_Id;
1090       S_Or_P : Name_Id;
1091 
1092       function Build_Step (J : Nat) return Node_Id;
1093       --  The increment step for the index of the right-hand side is written
1094       --  as an attribute reference (Succ or Pred). This function returns
1095       --  the corresponding node, which is placed at the end of the loop body.
1096 
1097       ----------------
1098       -- Build_Step --
1099       ----------------
1100 
1101       function Build_Step (J : Nat) return Node_Id is
1102          Step : Node_Id;
1103          Lim  : Name_Id;
1104 
1105       begin
1106          if Rev then
1107             Lim := Name_First;
1108          else
1109             Lim := Name_Last;
1110          end if;
1111 
1112          Step :=
1113             Make_Assignment_Statement (Loc,
1114                Name => New_Occurrence_Of (Rnn (J), Loc),
1115                Expression =>
1116                  Make_Attribute_Reference (Loc,
1117                    Prefix =>
1118                      New_Occurrence_Of (R_Index_Type (J), Loc),
1119                    Attribute_Name => S_Or_P,
1120                    Expressions => New_List (
1121                      New_Occurrence_Of (Rnn (J), Loc))));
1122 
1123       --  Note that on the last iteration of the loop, the index is increased
1124       --  (or decreased) past the corresponding bound. This is consistent with
1125       --  the C semantics of the back-end, where such an off-by-one value on a
1126       --  dead index variable is OK. However, in CodePeer mode this leads to
1127       --  spurious warnings, and thus we place a guard around the attribute
1128       --  reference. For obvious reasons we only do this for CodePeer.
1129 
1130          if CodePeer_Mode then
1131             Step :=
1132               Make_If_Statement (Loc,
1133                  Condition =>
1134                     Make_Op_Ne (Loc,
1135                        Left_Opnd  => New_Occurrence_Of (Lnn (J), Loc),
1136                        Right_Opnd =>
1137                          Make_Attribute_Reference (Loc,
1138                            Prefix => New_Occurrence_Of (L_Index_Type (J), Loc),
1139                            Attribute_Name => Lim)),
1140                  Then_Statements => New_List (Step));
1141          end if;
1142 
1143          return Step;
1144       end Build_Step;
1145 
1146    --  Start of processing for Expand_Assign_Array_Loop
1147 
1148    begin
1149       if Rev then
1150          F_Or_L := Name_Last;
1151          S_Or_P := Name_Pred;
1152       else
1153          F_Or_L := Name_First;
1154          S_Or_P := Name_Succ;
1155       end if;
1156 
1157       --  Setup index types and subscript entities
1158 
1159       declare
1160          L_Index : Node_Id;
1161          R_Index : Node_Id;
1162 
1163       begin
1164          L_Index := First_Index (L_Type);
1165          R_Index := First_Index (R_Type);
1166 
1167          for J in 1 .. Ndim loop
1168             Lnn (J) := Make_Temporary (Loc, 'L');
1169             Rnn (J) := Make_Temporary (Loc, 'R');
1170 
1171             L_Index_Type (J) := Etype (L_Index);
1172             R_Index_Type (J) := Etype (R_Index);
1173 
1174             Next_Index (L_Index);
1175             Next_Index (R_Index);
1176          end loop;
1177       end;
1178 
1179       --  Now construct the assignment statement
1180 
1181       declare
1182          ExprL : constant List_Id := New_List;
1183          ExprR : constant List_Id := New_List;
1184 
1185       begin
1186          for J in 1 .. Ndim loop
1187             Append_To (ExprL, New_Occurrence_Of (Lnn (J), Loc));
1188             Append_To (ExprR, New_Occurrence_Of (Rnn (J), Loc));
1189          end loop;
1190 
1191          Assign :=
1192            Make_Assignment_Statement (Loc,
1193              Name =>
1194                Make_Indexed_Component (Loc,
1195                  Prefix      => Duplicate_Subexpr (Larray, Name_Req => True),
1196                  Expressions => ExprL),
1197              Expression =>
1198                Make_Indexed_Component (Loc,
1199                  Prefix      => Duplicate_Subexpr (Rarray, Name_Req => True),
1200                  Expressions => ExprR));
1201 
1202          --  We set assignment OK, since there are some cases, e.g. in object
1203          --  declarations, where we are actually assigning into a constant.
1204          --  If there really is an illegality, it was caught long before now,
1205          --  and was flagged when the original assignment was analyzed.
1206 
1207          Set_Assignment_OK (Name (Assign));
1208 
1209          --  Propagate the No_Ctrl_Actions flag to individual assignments
1210 
1211          Set_No_Ctrl_Actions (Assign, No_Ctrl_Actions (N));
1212       end;
1213 
1214       --  Now construct the loop from the inside out, with the last subscript
1215       --  varying most rapidly. Note that Assign is first the raw assignment
1216       --  statement, and then subsequently the loop that wraps it up.
1217 
1218       for J in reverse 1 .. Ndim loop
1219          Assign :=
1220            Make_Block_Statement (Loc,
1221              Declarations => New_List (
1222               Make_Object_Declaration (Loc,
1223                 Defining_Identifier => Rnn (J),
1224                 Object_Definition =>
1225                   New_Occurrence_Of (R_Index_Type (J), Loc),
1226                 Expression =>
1227                   Make_Attribute_Reference (Loc,
1228                     Prefix => New_Occurrence_Of (R_Index_Type (J), Loc),
1229                     Attribute_Name => F_Or_L))),
1230 
1231            Handled_Statement_Sequence =>
1232              Make_Handled_Sequence_Of_Statements (Loc,
1233                Statements => New_List (
1234                  Make_Implicit_Loop_Statement (N,
1235                    Iteration_Scheme =>
1236                      Make_Iteration_Scheme (Loc,
1237                        Loop_Parameter_Specification =>
1238                          Make_Loop_Parameter_Specification (Loc,
1239                            Defining_Identifier => Lnn (J),
1240                            Reverse_Present => Rev,
1241                            Discrete_Subtype_Definition =>
1242                              New_Occurrence_Of (L_Index_Type (J), Loc))),
1243 
1244                    Statements => New_List (Assign, Build_Step (J))))));
1245       end loop;
1246 
1247       return Assign;
1248    end Expand_Assign_Array_Loop;
1249 
1250    --------------------------
1251    -- Expand_Assign_Record --
1252    --------------------------
1253 
1254    procedure Expand_Assign_Record (N : Node_Id) is
1255       Lhs   : constant Node_Id    := Name (N);
1256       Rhs   : Node_Id             := Expression (N);
1257       L_Typ : constant Entity_Id  := Base_Type (Etype (Lhs));
1258 
1259    begin
1260       --  If change of representation, then extract the real right hand side
1261       --  from the type conversion, and proceed with component-wise assignment,
1262       --  since the two types are not the same as far as the back end is
1263       --  concerned.
1264 
1265       if Change_Of_Representation (N) then
1266          Rhs := Expression (Rhs);
1267 
1268       --  If this may be a case of a large bit aligned component, then proceed
1269       --  with component-wise assignment, to avoid possible clobbering of other
1270       --  components sharing bits in the first or last byte of the component to
1271       --  be assigned.
1272 
1273       elsif Possible_Bit_Aligned_Component (Lhs)
1274               or
1275             Possible_Bit_Aligned_Component (Rhs)
1276       then
1277          null;
1278 
1279       --  If we have a tagged type that has a complete record representation
1280       --  clause, we must do we must do component-wise assignments, since child
1281       --  types may have used gaps for their components, and we might be
1282       --  dealing with a view conversion.
1283 
1284       elsif Is_Fully_Repped_Tagged_Type (L_Typ) then
1285          null;
1286 
1287       --  If neither condition met, then nothing special to do, the back end
1288       --  can handle assignment of the entire component as a single entity.
1289 
1290       else
1291          return;
1292       end if;
1293 
1294       --  At this stage we know that we must do a component wise assignment
1295 
1296       declare
1297          Loc   : constant Source_Ptr := Sloc (N);
1298          R_Typ : constant Entity_Id  := Base_Type (Etype (Rhs));
1299          Decl  : constant Node_Id    := Declaration_Node (R_Typ);
1300          RDef  : Node_Id;
1301          F     : Entity_Id;
1302 
1303          function Find_Component
1304            (Typ  : Entity_Id;
1305             Comp : Entity_Id) return Entity_Id;
1306          --  Find the component with the given name in the underlying record
1307          --  declaration for Typ. We need to use the actual entity because the
1308          --  type may be private and resolution by identifier alone would fail.
1309 
1310          function Make_Component_List_Assign
1311            (CL  : Node_Id;
1312             U_U : Boolean := False) return List_Id;
1313          --  Returns a sequence of statements to assign the components that
1314          --  are referenced in the given component list. The flag U_U is
1315          --  used to force the usage of the inferred value of the variant
1316          --  part expression as the switch for the generated case statement.
1317 
1318          function Make_Field_Assign
1319            (C   : Entity_Id;
1320             U_U : Boolean := False) return Node_Id;
1321          --  Given C, the entity for a discriminant or component, build an
1322          --  assignment for the corresponding field values. The flag U_U
1323          --  signals the presence of an Unchecked_Union and forces the usage
1324          --  of the inferred discriminant value of C as the right hand side
1325          --  of the assignment.
1326 
1327          function Make_Field_Assigns (CI : List_Id) return List_Id;
1328          --  Given CI, a component items list, construct series of statements
1329          --  for fieldwise assignment of the corresponding components.
1330 
1331          --------------------
1332          -- Find_Component --
1333          --------------------
1334 
1335          function Find_Component
1336            (Typ  : Entity_Id;
1337             Comp : Entity_Id) return Entity_Id
1338          is
1339             Utyp : constant Entity_Id := Underlying_Type (Typ);
1340             C    : Entity_Id;
1341 
1342          begin
1343             C := First_Entity (Utyp);
1344             while Present (C) loop
1345                if Chars (C) = Chars (Comp) then
1346                   return C;
1347                end if;
1348 
1349                Next_Entity (C);
1350             end loop;
1351 
1352             raise Program_Error;
1353          end Find_Component;
1354 
1355          --------------------------------
1356          -- Make_Component_List_Assign --
1357          --------------------------------
1358 
1359          function Make_Component_List_Assign
1360            (CL  : Node_Id;
1361             U_U : Boolean := False) return List_Id
1362          is
1363             CI : constant List_Id := Component_Items (CL);
1364             VP : constant Node_Id := Variant_Part (CL);
1365 
1366             Alts   : List_Id;
1367             DC     : Node_Id;
1368             DCH    : List_Id;
1369             Expr   : Node_Id;
1370             Result : List_Id;
1371             V      : Node_Id;
1372 
1373          begin
1374             Result := Make_Field_Assigns (CI);
1375 
1376             if Present (VP) then
1377                V := First_Non_Pragma (Variants (VP));
1378                Alts := New_List;
1379                while Present (V) loop
1380                   DCH := New_List;
1381                   DC := First (Discrete_Choices (V));
1382                   while Present (DC) loop
1383                      Append_To (DCH, New_Copy_Tree (DC));
1384                      Next (DC);
1385                   end loop;
1386 
1387                   Append_To (Alts,
1388                     Make_Case_Statement_Alternative (Loc,
1389                       Discrete_Choices => DCH,
1390                       Statements =>
1391                         Make_Component_List_Assign (Component_List (V))));
1392                   Next_Non_Pragma (V);
1393                end loop;
1394 
1395                --  If we have an Unchecked_Union, use the value of the inferred
1396                --  discriminant of the variant part expression as the switch
1397                --  for the case statement. The case statement may later be
1398                --  folded.
1399 
1400                if U_U then
1401                   Expr :=
1402                     New_Copy (Get_Discriminant_Value (
1403                       Entity (Name (VP)),
1404                       Etype (Rhs),
1405                       Discriminant_Constraint (Etype (Rhs))));
1406                else
1407                   Expr :=
1408                     Make_Selected_Component (Loc,
1409                       Prefix        => Duplicate_Subexpr (Rhs),
1410                       Selector_Name =>
1411                         Make_Identifier (Loc, Chars (Name (VP))));
1412                end if;
1413 
1414                Append_To (Result,
1415                  Make_Case_Statement (Loc,
1416                    Expression => Expr,
1417                    Alternatives => Alts));
1418             end if;
1419 
1420             return Result;
1421          end Make_Component_List_Assign;
1422 
1423          -----------------------
1424          -- Make_Field_Assign --
1425          -----------------------
1426 
1427          function Make_Field_Assign
1428            (C   : Entity_Id;
1429             U_U : Boolean := False) return Node_Id
1430          is
1431             A    : Node_Id;
1432             Expr : Node_Id;
1433 
1434          begin
1435             --  In the case of an Unchecked_Union, use the discriminant
1436             --  constraint value as on the right hand side of the assignment.
1437 
1438             if U_U then
1439                Expr :=
1440                  New_Copy (Get_Discriminant_Value (C,
1441                    Etype (Rhs),
1442                    Discriminant_Constraint (Etype (Rhs))));
1443             else
1444                Expr :=
1445                  Make_Selected_Component (Loc,
1446                    Prefix        => Duplicate_Subexpr (Rhs),
1447                    Selector_Name => New_Occurrence_Of (C, Loc));
1448             end if;
1449 
1450             A :=
1451               Make_Assignment_Statement (Loc,
1452                 Name =>
1453                   Make_Selected_Component (Loc,
1454                     Prefix        => Duplicate_Subexpr (Lhs),
1455                     Selector_Name =>
1456                       New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
1457                 Expression => Expr);
1458 
1459             --  Set Assignment_OK, so discriminants can be assigned
1460 
1461             Set_Assignment_OK (Name (A), True);
1462 
1463             if Componentwise_Assignment (N)
1464               and then Nkind (Name (A)) = N_Selected_Component
1465               and then Chars (Selector_Name (Name (A))) = Name_uParent
1466             then
1467                Set_Componentwise_Assignment (A);
1468             end if;
1469 
1470             return A;
1471          end Make_Field_Assign;
1472 
1473          ------------------------
1474          -- Make_Field_Assigns --
1475          ------------------------
1476 
1477          function Make_Field_Assigns (CI : List_Id) return List_Id is
1478             Item   : Node_Id;
1479             Result : List_Id;
1480 
1481          begin
1482             Item := First (CI);
1483             Result := New_List;
1484 
1485             while Present (Item) loop
1486 
1487                --  Look for components, but exclude _tag field assignment if
1488                --  the special Componentwise_Assignment flag is set.
1489 
1490                if Nkind (Item) = N_Component_Declaration
1491                  and then not (Is_Tag (Defining_Identifier (Item))
1492                                  and then Componentwise_Assignment (N))
1493                then
1494                   Append_To
1495                     (Result, Make_Field_Assign (Defining_Identifier (Item)));
1496                end if;
1497 
1498                Next (Item);
1499             end loop;
1500 
1501             return Result;
1502          end Make_Field_Assigns;
1503 
1504       --  Start of processing for Expand_Assign_Record
1505 
1506       begin
1507          --  Note that we use the base types for this processing. This results
1508          --  in some extra work in the constrained case, but the change of
1509          --  representation case is so unusual that it is not worth the effort.
1510 
1511          --  First copy the discriminants. This is done unconditionally. It
1512          --  is required in the unconstrained left side case, and also in the
1513          --  case where this assignment was constructed during the expansion
1514          --  of a type conversion (since initialization of discriminants is
1515          --  suppressed in this case). It is unnecessary but harmless in
1516          --  other cases.
1517 
1518          if Has_Discriminants (L_Typ) then
1519             F := First_Discriminant (R_Typ);
1520             while Present (F) loop
1521 
1522                --  If we are expanding the initialization of a derived record
1523                --  that constrains or renames discriminants of the parent, we
1524                --  must use the corresponding discriminant in the parent.
1525 
1526                declare
1527                   CF : Entity_Id;
1528 
1529                begin
1530                   if Inside_Init_Proc
1531                     and then Present (Corresponding_Discriminant (F))
1532                   then
1533                      CF := Corresponding_Discriminant (F);
1534                   else
1535                      CF := F;
1536                   end if;
1537 
1538                   if Is_Unchecked_Union (Base_Type (R_Typ)) then
1539 
1540                      --  Within an initialization procedure this is the
1541                      --  assignment to an unchecked union component, in which
1542                      --  case there is no discriminant to initialize.
1543 
1544                      if Inside_Init_Proc then
1545                         null;
1546 
1547                      else
1548                         --  The assignment is part of a conversion from a
1549                         --  derived unchecked union type with an inferable
1550                         --  discriminant, to a parent type.
1551 
1552                         Insert_Action (N, Make_Field_Assign (CF, True));
1553                      end if;
1554 
1555                   else
1556                      Insert_Action (N, Make_Field_Assign (CF));
1557                   end if;
1558 
1559                   Next_Discriminant (F);
1560                end;
1561             end loop;
1562          end if;
1563 
1564          --  We know the underlying type is a record, but its current view
1565          --  may be private. We must retrieve the usable record declaration.
1566 
1567          if Nkind_In (Decl, N_Private_Type_Declaration,
1568                             N_Private_Extension_Declaration)
1569            and then Present (Full_View (R_Typ))
1570          then
1571             RDef := Type_Definition (Declaration_Node (Full_View (R_Typ)));
1572          else
1573             RDef := Type_Definition (Decl);
1574          end if;
1575 
1576          if Nkind (RDef) = N_Derived_Type_Definition then
1577             RDef := Record_Extension_Part (RDef);
1578          end if;
1579 
1580          if Nkind (RDef) = N_Record_Definition
1581            and then Present (Component_List (RDef))
1582          then
1583             if Is_Unchecked_Union (R_Typ) then
1584                Insert_Actions (N,
1585                  Make_Component_List_Assign (Component_List (RDef), True));
1586             else
1587                Insert_Actions
1588                  (N, Make_Component_List_Assign (Component_List (RDef)));
1589             end if;
1590 
1591             Rewrite (N, Make_Null_Statement (Loc));
1592          end if;
1593       end;
1594    end Expand_Assign_Record;
1595 
1596    -----------------------------------
1597    -- Expand_N_Assignment_Statement --
1598    -----------------------------------
1599 
1600    --  This procedure implements various cases where an assignment statement
1601    --  cannot just be passed on to the back end in untransformed state.
1602 
1603    procedure Expand_N_Assignment_Statement (N : Node_Id) is
1604       Crep : constant Boolean    := Change_Of_Representation (N);
1605       Lhs  : constant Node_Id    := Name (N);
1606       Loc  : constant Source_Ptr := Sloc (N);
1607       Rhs  : constant Node_Id    := Expression (N);
1608       Typ  : constant Entity_Id  := Underlying_Type (Etype (Lhs));
1609       Exp  : Node_Id;
1610 
1611       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1612 
1613    begin
1614       --  The assignment statement is Ghost when the left hand side is Ghost.
1615       --  Set the mode now to ensure that any nodes generated during expansion
1616       --  are properly marked as Ghost.
1617 
1618       Set_Ghost_Mode (N);
1619 
1620       --  Special case to check right away, if the Componentwise_Assignment
1621       --  flag is set, this is a reanalysis from the expansion of the primitive
1622       --  assignment procedure for a tagged type, and all we need to do is to
1623       --  expand to assignment of components, because otherwise, we would get
1624       --  infinite recursion (since this looks like a tagged assignment which
1625       --  would normally try to *call* the primitive assignment procedure).
1626 
1627       if Componentwise_Assignment (N) then
1628          Expand_Assign_Record (N);
1629          Ghost_Mode := Save_Ghost_Mode;
1630          return;
1631       end if;
1632 
1633       --  Defend against invalid subscripts on left side if we are in standard
1634       --  validity checking mode. No need to do this if we are checking all
1635       --  subscripts.
1636 
1637       --  Note that we do this right away, because there are some early return
1638       --  paths in this procedure, and this is required on all paths.
1639 
1640       if Validity_Checks_On
1641         and then Validity_Check_Default
1642         and then not Validity_Check_Subscripts
1643       then
1644          Check_Valid_Lvalue_Subscripts (Lhs);
1645       end if;
1646 
1647       --  Ada 2005 (AI-327): Handle assignment to priority of protected object
1648 
1649       --  Rewrite an assignment to X'Priority into a run-time call
1650 
1651       --   For example:         X'Priority := New_Prio_Expr;
1652       --   ...is expanded into  Set_Ceiling (X._Object, New_Prio_Expr);
1653 
1654       --  Note that although X'Priority is notionally an object, it is quite
1655       --  deliberately not defined as an aliased object in the RM. This means
1656       --  that it works fine to rewrite it as a call, without having to worry
1657       --  about complications that would other arise from X'Priority'Access,
1658       --  which is illegal, because of the lack of aliasing.
1659 
1660       if Ada_Version >= Ada_2005 then
1661          declare
1662             Call           : Node_Id;
1663             Conctyp        : Entity_Id;
1664             Ent            : Entity_Id;
1665             Subprg         : Entity_Id;
1666             RT_Subprg_Name : Node_Id;
1667 
1668          begin
1669             --  Handle chains of renamings
1670 
1671             Ent := Name (N);
1672             while Nkind (Ent) in N_Has_Entity
1673               and then Present (Entity (Ent))
1674               and then Present (Renamed_Object (Entity (Ent)))
1675             loop
1676                Ent := Renamed_Object (Entity (Ent));
1677             end loop;
1678 
1679             --  The attribute Priority applied to protected objects has been
1680             --  previously expanded into a call to the Get_Ceiling run-time
1681             --  subprogram. In restricted profiles this is not available.
1682 
1683             if Is_Expanded_Priority_Attribute (Ent) then
1684 
1685                --  Look for the enclosing concurrent type
1686 
1687                Conctyp := Current_Scope;
1688                while not Is_Concurrent_Type (Conctyp) loop
1689                   Conctyp := Scope (Conctyp);
1690                end loop;
1691 
1692                pragma Assert (Is_Protected_Type (Conctyp));
1693 
1694                --  Generate the first actual of the call
1695 
1696                Subprg := Current_Scope;
1697                while not Present (Protected_Body_Subprogram (Subprg)) loop
1698                   Subprg := Scope (Subprg);
1699                end loop;
1700 
1701                --  Select the appropriate run-time call
1702 
1703                if Number_Entries (Conctyp) = 0 then
1704                   RT_Subprg_Name :=
1705                     New_Occurrence_Of (RTE (RE_Set_Ceiling), Loc);
1706                else
1707                   RT_Subprg_Name :=
1708                     New_Occurrence_Of (RTE (RO_PE_Set_Ceiling), Loc);
1709                end if;
1710 
1711                Call :=
1712                  Make_Procedure_Call_Statement (Loc,
1713                    Name => RT_Subprg_Name,
1714                    Parameter_Associations => New_List (
1715                      New_Copy_Tree (First (Parameter_Associations (Ent))),
1716                      Relocate_Node (Expression (N))));
1717 
1718                Rewrite (N, Call);
1719                Analyze (N);
1720 
1721                Ghost_Mode := Save_Ghost_Mode;
1722                return;
1723             end if;
1724          end;
1725       end if;
1726 
1727       --  Deal with assignment checks unless suppressed
1728 
1729       if not Suppress_Assignment_Checks (N) then
1730 
1731          --  First deal with generation of range check if required
1732 
1733          if Do_Range_Check (Rhs) then
1734             Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
1735          end if;
1736 
1737          --  Then generate predicate check if required
1738 
1739          Apply_Predicate_Check (Rhs, Typ);
1740       end if;
1741 
1742       --  Check for a special case where a high level transformation is
1743       --  required. If we have either of:
1744 
1745       --    P.field := rhs;
1746       --    P (sub) := rhs;
1747 
1748       --  where P is a reference to a bit packed array, then we have to unwind
1749       --  the assignment. The exact meaning of being a reference to a bit
1750       --  packed array is as follows:
1751 
1752       --    An indexed component whose prefix is a bit packed array is a
1753       --    reference to a bit packed array.
1754 
1755       --    An indexed component or selected component whose prefix is a
1756       --    reference to a bit packed array is itself a reference ot a
1757       --    bit packed array.
1758 
1759       --  The required transformation is
1760 
1761       --     Tnn : prefix_type := P;
1762       --     Tnn.field := rhs;
1763       --     P := Tnn;
1764 
1765       --  or
1766 
1767       --     Tnn : prefix_type := P;
1768       --     Tnn (subscr) := rhs;
1769       --     P := Tnn;
1770 
1771       --  Since P is going to be evaluated more than once, any subscripts
1772       --  in P must have their evaluation forced.
1773 
1774       if Nkind_In (Lhs, N_Indexed_Component, N_Selected_Component)
1775         and then Is_Ref_To_Bit_Packed_Array (Prefix (Lhs))
1776       then
1777          declare
1778             BPAR_Expr : constant Node_Id   := Relocate_Node (Prefix (Lhs));
1779             BPAR_Typ  : constant Entity_Id := Etype (BPAR_Expr);
1780             Tnn       : constant Entity_Id :=
1781                           Make_Temporary (Loc, 'T', BPAR_Expr);
1782 
1783          begin
1784             --  Insert the post assignment first, because we want to copy the
1785             --  BPAR_Expr tree before it gets analyzed in the context of the
1786             --  pre assignment. Note that we do not analyze the post assignment
1787             --  yet (we cannot till we have completed the analysis of the pre
1788             --  assignment). As usual, the analysis of this post assignment
1789             --  will happen on its own when we "run into" it after finishing
1790             --  the current assignment.
1791 
1792             Insert_After (N,
1793               Make_Assignment_Statement (Loc,
1794                 Name       => New_Copy_Tree (BPAR_Expr),
1795                 Expression => New_Occurrence_Of (Tnn, Loc)));
1796 
1797             --  At this stage BPAR_Expr is a reference to a bit packed array
1798             --  where the reference was not expanded in the original tree,
1799             --  since it was on the left side of an assignment. But in the
1800             --  pre-assignment statement (the object definition), BPAR_Expr
1801             --  will end up on the right hand side, and must be reexpanded. To
1802             --  achieve this, we reset the analyzed flag of all selected and
1803             --  indexed components down to the actual indexed component for
1804             --  the packed array.
1805 
1806             Exp := BPAR_Expr;
1807             loop
1808                Set_Analyzed (Exp, False);
1809 
1810                if Nkind_In
1811                    (Exp, N_Selected_Component, N_Indexed_Component)
1812                then
1813                   Exp := Prefix (Exp);
1814                else
1815                   exit;
1816                end if;
1817             end loop;
1818 
1819             --  Now we can insert and analyze the pre-assignment
1820 
1821             --  If the right-hand side requires a transient scope, it has
1822             --  already been placed on the stack. However, the declaration is
1823             --  inserted in the tree outside of this scope, and must reflect
1824             --  the proper scope for its variable. This awkward bit is forced
1825             --  by the stricter scope discipline imposed by GCC 2.97.
1826 
1827             declare
1828                Uses_Transient_Scope : constant Boolean :=
1829                                         Scope_Is_Transient
1830                                           and then N = Node_To_Be_Wrapped;
1831 
1832             begin
1833                if Uses_Transient_Scope then
1834                   Push_Scope (Scope (Current_Scope));
1835                end if;
1836 
1837                Insert_Before_And_Analyze (N,
1838                  Make_Object_Declaration (Loc,
1839                    Defining_Identifier => Tnn,
1840                    Object_Definition   => New_Occurrence_Of (BPAR_Typ, Loc),
1841                    Expression          => BPAR_Expr));
1842 
1843                if Uses_Transient_Scope then
1844                   Pop_Scope;
1845                end if;
1846             end;
1847 
1848             --  Now fix up the original assignment and continue processing
1849 
1850             Rewrite (Prefix (Lhs),
1851               New_Occurrence_Of (Tnn, Loc));
1852 
1853             --  We do not need to reanalyze that assignment, and we do not need
1854             --  to worry about references to the temporary, but we do need to
1855             --  make sure that the temporary is not marked as a true constant
1856             --  since we now have a generated assignment to it.
1857 
1858             Set_Is_True_Constant (Tnn, False);
1859          end;
1860       end if;
1861 
1862       --  When we have the appropriate type of aggregate in the expression (it
1863       --  has been determined during analysis of the aggregate by setting the
1864       --  delay flag), let's perform in place assignment and thus avoid
1865       --  creating a temporary.
1866 
1867       if Is_Delayed_Aggregate (Rhs) then
1868          Convert_Aggr_In_Assignment (N);
1869          Rewrite (N, Make_Null_Statement (Loc));
1870          Analyze (N);
1871 
1872          Ghost_Mode := Save_Ghost_Mode;
1873          return;
1874       end if;
1875 
1876       --  Apply discriminant check if required. If Lhs is an access type to a
1877       --  designated type with discriminants, we must always check. If the
1878       --  type has unknown discriminants, more elaborate processing below.
1879 
1880       if Has_Discriminants (Etype (Lhs))
1881         and then not Has_Unknown_Discriminants (Etype (Lhs))
1882       then
1883          --  Skip discriminant check if change of representation. Will be
1884          --  done when the change of representation is expanded out.
1885 
1886          if not Crep then
1887             Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
1888          end if;
1889 
1890       --  If the type is private without discriminants, and the full type
1891       --  has discriminants (necessarily with defaults) a check may still be
1892       --  necessary if the Lhs is aliased. The private discriminants must be
1893       --  visible to build the discriminant constraints.
1894 
1895       --  Only an explicit dereference that comes from source indicates
1896       --  aliasing. Access to formals of protected operations and entries
1897       --  create dereferences but are not semantic aliasings.
1898 
1899       elsif Is_Private_Type (Etype (Lhs))
1900         and then Has_Discriminants (Typ)
1901         and then Nkind (Lhs) = N_Explicit_Dereference
1902         and then Comes_From_Source (Lhs)
1903       then
1904          declare
1905             Lt  : constant Entity_Id := Etype (Lhs);
1906             Ubt : Entity_Id          := Base_Type (Typ);
1907 
1908          begin
1909             --  In the case of an expander-generated record subtype whose base
1910             --  type still appears private, Typ will have been set to that
1911             --  private type rather than the underlying record type (because
1912             --  Underlying type will have returned the record subtype), so it's
1913             --  necessary to apply Underlying_Type again to the base type to
1914             --  get the record type we need for the discriminant check. Such
1915             --  subtypes can be created for assignments in certain cases, such
1916             --  as within an instantiation passed this kind of private type.
1917             --  It would be good to avoid this special test, but making changes
1918             --  to prevent this odd form of record subtype seems difficult. ???
1919 
1920             if Is_Private_Type (Ubt) then
1921                Ubt := Underlying_Type (Ubt);
1922             end if;
1923 
1924             Set_Etype (Lhs, Ubt);
1925             Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs));
1926             Apply_Discriminant_Check (Rhs, Ubt, Lhs);
1927             Set_Etype (Lhs, Lt);
1928          end;
1929 
1930       --  If the Lhs has a private type with unknown discriminants, it may
1931       --  have a full view with discriminants, but those are nameable only
1932       --  in the underlying type, so convert the Rhs to it before potential
1933       --  checking. Convert Lhs as well, otherwise the actual subtype might
1934       --  not be constructible. If the discriminants have defaults the type
1935       --  is unconstrained and there is nothing to check.
1936 
1937       elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
1938         and then Has_Discriminants (Typ)
1939         and then not Has_Defaulted_Discriminants (Typ)
1940       then
1941          Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
1942          Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
1943          Apply_Discriminant_Check (Rhs, Typ, Lhs);
1944 
1945       --  In the access type case, we need the same discriminant check, and
1946       --  also range checks if we have an access to constrained array.
1947 
1948       elsif Is_Access_Type (Etype (Lhs))
1949         and then Is_Constrained (Designated_Type (Etype (Lhs)))
1950       then
1951          if Has_Discriminants (Designated_Type (Etype (Lhs))) then
1952 
1953             --  Skip discriminant check if change of representation. Will be
1954             --  done when the change of representation is expanded out.
1955 
1956             if not Crep then
1957                Apply_Discriminant_Check (Rhs, Etype (Lhs));
1958             end if;
1959 
1960          elsif Is_Array_Type (Designated_Type (Etype (Lhs))) then
1961             Apply_Range_Check (Rhs, Etype (Lhs));
1962 
1963             if Is_Constrained (Etype (Lhs)) then
1964                Apply_Length_Check (Rhs, Etype (Lhs));
1965             end if;
1966 
1967             if Nkind (Rhs) = N_Allocator then
1968                declare
1969                   Target_Typ : constant Entity_Id := Etype (Expression (Rhs));
1970                   C_Es       : Check_Result;
1971 
1972                begin
1973                   C_Es :=
1974                     Get_Range_Checks
1975                       (Lhs,
1976                        Target_Typ,
1977                        Etype (Designated_Type (Etype (Lhs))));
1978 
1979                   Insert_Range_Checks
1980                     (C_Es,
1981                      N,
1982                      Target_Typ,
1983                      Sloc (Lhs),
1984                      Lhs);
1985                end;
1986             end if;
1987          end if;
1988 
1989       --  Apply range check for access type case
1990 
1991       elsif Is_Access_Type (Etype (Lhs))
1992         and then Nkind (Rhs) = N_Allocator
1993         and then Nkind (Expression (Rhs)) = N_Qualified_Expression
1994       then
1995          Analyze_And_Resolve (Expression (Rhs));
1996          Apply_Range_Check
1997            (Expression (Rhs), Designated_Type (Etype (Lhs)));
1998       end if;
1999 
2000       --  Ada 2005 (AI-231): Generate the run-time check
2001 
2002       if Is_Access_Type (Typ)
2003         and then Can_Never_Be_Null (Etype (Lhs))
2004         and then not Can_Never_Be_Null (Etype (Rhs))
2005 
2006         --  If an actual is an out parameter of a null-excluding access
2007         --  type, there is access check on entry, so we set the flag
2008         --  Suppress_Assignment_Checks on the generated statement to
2009         --  assign the actual to the parameter block, and we do not want
2010         --  to generate an additional check at this point.
2011 
2012         and then not Suppress_Assignment_Checks (N)
2013       then
2014          Apply_Constraint_Check (Rhs, Etype (Lhs));
2015       end if;
2016 
2017       --  Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
2018       --  stand-alone obj of an anonymous access type. Do not install the check
2019       --  when the Lhs denotes a container cursor and the Next function employs
2020       --  an access type, because this can never result in a dangling pointer.
2021 
2022       if Is_Access_Type (Typ)
2023         and then Is_Entity_Name (Lhs)
2024         and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
2025         and then Present (Effective_Extra_Accessibility (Entity (Lhs)))
2026       then
2027          declare
2028             function Lhs_Entity return Entity_Id;
2029             --  Look through renames to find the underlying entity.
2030             --  For assignment to a rename, we don't care about the
2031             --  Enclosing_Dynamic_Scope of the rename declaration.
2032 
2033             ----------------
2034             -- Lhs_Entity --
2035             ----------------
2036 
2037             function Lhs_Entity return Entity_Id is
2038                Result : Entity_Id := Entity (Lhs);
2039 
2040             begin
2041                while Present (Renamed_Object (Result)) loop
2042 
2043                   --  Renamed_Object must return an Entity_Name here
2044                   --  because of preceding "Present (E_E_A (...))" test.
2045 
2046                   Result := Entity (Renamed_Object (Result));
2047                end loop;
2048 
2049                return Result;
2050             end Lhs_Entity;
2051 
2052             --  Local Declarations
2053 
2054             Access_Check : constant Node_Id :=
2055                              Make_Raise_Program_Error (Loc,
2056                                Condition =>
2057                                  Make_Op_Gt (Loc,
2058                                    Left_Opnd  =>
2059                                      Dynamic_Accessibility_Level (Rhs),
2060                                    Right_Opnd =>
2061                                      Make_Integer_Literal (Loc,
2062                                        Intval =>
2063                                          Scope_Depth
2064                                            (Enclosing_Dynamic_Scope
2065                                              (Lhs_Entity)))),
2066                                Reason => PE_Accessibility_Check_Failed);
2067 
2068             Access_Level_Update : constant Node_Id :=
2069                                     Make_Assignment_Statement (Loc,
2070                                      Name       =>
2071                                        New_Occurrence_Of
2072                                          (Effective_Extra_Accessibility
2073                                             (Entity (Lhs)), Loc),
2074                                      Expression =>
2075                                         Dynamic_Accessibility_Level (Rhs));
2076 
2077          begin
2078             if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
2079                Insert_Action (N, Access_Check);
2080             end if;
2081 
2082             Insert_Action (N, Access_Level_Update);
2083          end;
2084       end if;
2085 
2086       --  Case of assignment to a bit packed array element. If there is a
2087       --  change of representation this must be expanded into components,
2088       --  otherwise this is a bit-field assignment.
2089 
2090       if Nkind (Lhs) = N_Indexed_Component
2091         and then Is_Bit_Packed_Array (Etype (Prefix (Lhs)))
2092       then
2093          --  Normal case, no change of representation
2094 
2095          if not Crep then
2096             Expand_Bit_Packed_Element_Set (N);
2097             Ghost_Mode := Save_Ghost_Mode;
2098             return;
2099 
2100          --  Change of representation case
2101 
2102          else
2103             --  Generate the following, to force component-by-component
2104             --  assignments in an efficient way. Otherwise each component
2105             --  will require a temporary and two bit-field manipulations.
2106 
2107             --  T1 : Elmt_Type;
2108             --  T1 := RhS;
2109             --  Lhs := T1;
2110 
2111             declare
2112                Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
2113                Stats : List_Id;
2114 
2115             begin
2116                Stats :=
2117                  New_List (
2118                    Make_Object_Declaration (Loc,
2119                      Defining_Identifier => Tnn,
2120                      Object_Definition   =>
2121                        New_Occurrence_Of (Etype (Lhs), Loc)),
2122                    Make_Assignment_Statement (Loc,
2123                      Name       => New_Occurrence_Of (Tnn, Loc),
2124                      Expression => Relocate_Node (Rhs)),
2125                    Make_Assignment_Statement (Loc,
2126                      Name       => Relocate_Node (Lhs),
2127                      Expression => New_Occurrence_Of (Tnn, Loc)));
2128 
2129                Insert_Actions (N, Stats);
2130                Rewrite (N, Make_Null_Statement (Loc));
2131                Analyze (N);
2132             end;
2133          end if;
2134 
2135       --  Build-in-place function call case. Note that we're not yet doing
2136       --  build-in-place for user-written assignment statements (the assignment
2137       --  here came from an aggregate.)
2138 
2139       elsif Ada_Version >= Ada_2005
2140         and then Is_Build_In_Place_Function_Call (Rhs)
2141       then
2142          Make_Build_In_Place_Call_In_Assignment (N, Rhs);
2143 
2144       elsif Is_Tagged_Type (Typ)
2145         or else (Needs_Finalization (Typ) and then not Is_Array_Type (Typ))
2146       then
2147          Tagged_Case : declare
2148             L                   : List_Id := No_List;
2149             Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N);
2150 
2151          begin
2152             --  In the controlled case, we ensure that function calls are
2153             --  evaluated before finalizing the target. In all cases, it makes
2154             --  the expansion easier if the side-effects are removed first.
2155 
2156             Remove_Side_Effects (Lhs);
2157             Remove_Side_Effects (Rhs);
2158 
2159             --  Avoid recursion in the mechanism
2160 
2161             Set_Analyzed (N);
2162 
2163             --  If dispatching assignment, we need to dispatch to _assign
2164 
2165             if Is_Class_Wide_Type (Typ)
2166 
2167                --  If the type is tagged, we may as well use the predefined
2168                --  primitive assignment. This avoids inlining a lot of code
2169                --  and in the class-wide case, the assignment is replaced
2170                --  by a dispatching call to _assign. It is suppressed in the
2171                --  case of assignments created by the expander that correspond
2172                --  to initializations, where we do want to copy the tag
2173                --  (Expand_Ctrl_Actions flag is set False in this case). It is
2174                --  also suppressed if restriction No_Dispatching_Calls is in
2175                --  force because in that case predefined primitives are not
2176                --  generated.
2177 
2178                or else (Is_Tagged_Type (Typ)
2179                          and then Chars (Current_Scope) /= Name_uAssign
2180                          and then Expand_Ctrl_Actions
2181                          and then
2182                            not Restriction_Active (No_Dispatching_Calls))
2183             then
2184                if Is_Limited_Type (Typ) then
2185 
2186                   --  This can happen in an instance when the formal is an
2187                   --  extension of a limited interface, and the actual is
2188                   --  limited. This is an error according to AI05-0087, but
2189                   --  is not caught at the point of instantiation in earlier
2190                   --  versions.
2191 
2192                   --  This is wrong, error messages cannot be issued during
2193                   --  expansion, since they would be missed in -gnatc mode ???
2194 
2195                   Error_Msg_N ("assignment not available on limited type", N);
2196                   Ghost_Mode := Save_Ghost_Mode;
2197                   return;
2198                end if;
2199 
2200                --  Fetch the primitive op _assign and proper type to call it.
2201                --  Because of possible conflicts between private and full view,
2202                --  fetch the proper type directly from the operation profile.
2203 
2204                declare
2205                   Op    : constant Entity_Id :=
2206                             Find_Prim_Op (Typ, Name_uAssign);
2207                   F_Typ : Entity_Id := Etype (First_Formal (Op));
2208 
2209                begin
2210                   --  If the assignment is dispatching, make sure to use the
2211                   --  proper type.
2212 
2213                   if Is_Class_Wide_Type (Typ) then
2214                      F_Typ := Class_Wide_Type (F_Typ);
2215                   end if;
2216 
2217                   L := New_List;
2218 
2219                   --  In case of assignment to a class-wide tagged type, before
2220                   --  the assignment we generate run-time check to ensure that
2221                   --  the tags of source and target match.
2222 
2223                   if not Tag_Checks_Suppressed (Typ)
2224                     and then Is_Class_Wide_Type (Typ)
2225                     and then Is_Tagged_Type (Typ)
2226                     and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
2227                   then
2228                      declare
2229                         Lhs_Tag : Node_Id;
2230                         Rhs_Tag : Node_Id;
2231 
2232                      begin
2233                         if not Is_Interface (Typ) then
2234                            Lhs_Tag :=
2235                              Make_Selected_Component (Loc,
2236                                Prefix        => Duplicate_Subexpr (Lhs),
2237                                Selector_Name =>
2238                                  Make_Identifier (Loc, Name_uTag));
2239                            Rhs_Tag :=
2240                              Make_Selected_Component (Loc,
2241                                Prefix        => Duplicate_Subexpr (Rhs),
2242                                Selector_Name =>
2243                                  Make_Identifier (Loc, Name_uTag));
2244                         else
2245                            --  Displace the pointer to the base of the objects
2246                            --  applying 'Address, which is later expanded into
2247                            --  a call to RE_Base_Address.
2248 
2249                            Lhs_Tag :=
2250                              Make_Explicit_Dereference (Loc,
2251                                Prefix =>
2252                                  Unchecked_Convert_To (RTE (RE_Tag_Ptr),
2253                                    Make_Attribute_Reference (Loc,
2254                                      Prefix         => Duplicate_Subexpr (Lhs),
2255                                      Attribute_Name => Name_Address)));
2256                            Rhs_Tag :=
2257                              Make_Explicit_Dereference (Loc,
2258                                Prefix =>
2259                                  Unchecked_Convert_To (RTE (RE_Tag_Ptr),
2260                                    Make_Attribute_Reference (Loc,
2261                                      Prefix         => Duplicate_Subexpr (Rhs),
2262                                      Attribute_Name => Name_Address)));
2263                         end if;
2264 
2265                         Append_To (L,
2266                           Make_Raise_Constraint_Error (Loc,
2267                             Condition =>
2268                               Make_Op_Ne (Loc,
2269                                 Left_Opnd  => Lhs_Tag,
2270                                 Right_Opnd => Rhs_Tag),
2271                             Reason    => CE_Tag_Check_Failed));
2272                      end;
2273                   end if;
2274 
2275                   declare
2276                      Left_N  : Node_Id := Duplicate_Subexpr (Lhs);
2277                      Right_N : Node_Id := Duplicate_Subexpr (Rhs);
2278 
2279                   begin
2280                      --  In order to dispatch the call to _assign the type of
2281                      --  the actuals must match. Add conversion (if required).
2282 
2283                      if Etype (Lhs) /= F_Typ then
2284                         Left_N := Unchecked_Convert_To (F_Typ, Left_N);
2285                      end if;
2286 
2287                      if Etype (Rhs) /= F_Typ then
2288                         Right_N := Unchecked_Convert_To (F_Typ, Right_N);
2289                      end if;
2290 
2291                      Append_To (L,
2292                        Make_Procedure_Call_Statement (Loc,
2293                          Name => New_Occurrence_Of (Op, Loc),
2294                          Parameter_Associations => New_List (
2295                            Node1 => Left_N,
2296                            Node2 => Right_N)));
2297                   end;
2298                end;
2299 
2300             else
2301                L := Make_Tag_Ctrl_Assignment (N);
2302 
2303                --  We can't afford to have destructive Finalization Actions in
2304                --  the Self assignment case, so if the target and the source
2305                --  are not obviously different, code is generated to avoid the
2306                --  self assignment case:
2307 
2308                --    if lhs'address /= rhs'address then
2309                --       <code for controlled and/or tagged assignment>
2310                --    end if;
2311 
2312                --  Skip this if Restriction (No_Finalization) is active
2313 
2314                if not Statically_Different (Lhs, Rhs)
2315                  and then Expand_Ctrl_Actions
2316                  and then not Restriction_Active (No_Finalization)
2317                then
2318                   L := New_List (
2319                     Make_Implicit_If_Statement (N,
2320                       Condition =>
2321                         Make_Op_Ne (Loc,
2322                           Left_Opnd =>
2323                             Make_Attribute_Reference (Loc,
2324                               Prefix         => Duplicate_Subexpr (Lhs),
2325                               Attribute_Name => Name_Address),
2326 
2327                            Right_Opnd =>
2328                             Make_Attribute_Reference (Loc,
2329                               Prefix         => Duplicate_Subexpr (Rhs),
2330                               Attribute_Name => Name_Address)),
2331 
2332                       Then_Statements => L));
2333                end if;
2334 
2335                --  We need to set up an exception handler for implementing
2336                --  7.6.1(18). The remaining adjustments are tackled by the
2337                --  implementation of adjust for record_controllers (see
2338                --  s-finimp.adb).
2339 
2340                --  This is skipped if we have no finalization
2341 
2342                if Expand_Ctrl_Actions
2343                  and then not Restriction_Active (No_Finalization)
2344                then
2345                   L := New_List (
2346                     Make_Block_Statement (Loc,
2347                       Handled_Statement_Sequence =>
2348                         Make_Handled_Sequence_Of_Statements (Loc,
2349                           Statements => L,
2350                           Exception_Handlers => New_List (
2351                             Make_Handler_For_Ctrl_Operation (Loc)))));
2352                end if;
2353             end if;
2354 
2355             Rewrite (N,
2356               Make_Block_Statement (Loc,
2357                 Handled_Statement_Sequence =>
2358                   Make_Handled_Sequence_Of_Statements (Loc, Statements => L)));
2359 
2360             --  If no restrictions on aborts, protect the whole assignment
2361             --  for controlled objects as per 9.8(11).
2362 
2363             if Needs_Finalization (Typ)
2364               and then Expand_Ctrl_Actions
2365               and then Abort_Allowed
2366             then
2367                declare
2368                   Blk : constant Entity_Id :=
2369                           New_Internal_Entity
2370                             (E_Block, Current_Scope, Sloc (N), 'B');
2371                   AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
2372 
2373                begin
2374                   Set_Scope (Blk, Current_Scope);
2375                   Set_Etype (Blk, Standard_Void_Type);
2376                   Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
2377 
2378                   Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
2379                   Set_At_End_Proc (Handled_Statement_Sequence (N),
2380                     New_Occurrence_Of (AUD, Loc));
2381 
2382                   --  Present the Abort_Undefer_Direct function to the backend
2383                   --  so that it can inline the call to the function.
2384 
2385                   Add_Inlined_Body (AUD, N);
2386 
2387                   Expand_At_End_Handler
2388                     (Handled_Statement_Sequence (N), Blk);
2389                end;
2390             end if;
2391 
2392             --  N has been rewritten to a block statement for which it is
2393             --  known by construction that no checks are necessary: analyze
2394             --  it with all checks suppressed.
2395 
2396             Analyze (N, Suppress => All_Checks);
2397             Ghost_Mode := Save_Ghost_Mode;
2398             return;
2399          end Tagged_Case;
2400 
2401       --  Array types
2402 
2403       elsif Is_Array_Type (Typ) then
2404          declare
2405             Actual_Rhs : Node_Id := Rhs;
2406 
2407          begin
2408             while Nkind_In (Actual_Rhs, N_Type_Conversion,
2409                                         N_Qualified_Expression)
2410             loop
2411                Actual_Rhs := Expression (Actual_Rhs);
2412             end loop;
2413 
2414             Expand_Assign_Array (N, Actual_Rhs);
2415             Ghost_Mode := Save_Ghost_Mode;
2416             return;
2417          end;
2418 
2419       --  Record types
2420 
2421       elsif Is_Record_Type (Typ) then
2422          Expand_Assign_Record (N);
2423          Ghost_Mode := Save_Ghost_Mode;
2424          return;
2425 
2426       --  Scalar types. This is where we perform the processing related to the
2427       --  requirements of (RM 13.9.1(9-11)) concerning the handling of invalid
2428       --  scalar values.
2429 
2430       elsif Is_Scalar_Type (Typ) then
2431 
2432          --  Case where right side is known valid
2433 
2434          if Expr_Known_Valid (Rhs) then
2435 
2436             --  Here the right side is valid, so it is fine. The case to deal
2437             --  with is when the left side is a local variable reference whose
2438             --  value is not currently known to be valid. If this is the case,
2439             --  and the assignment appears in an unconditional context, then
2440             --  we can mark the left side as now being valid if one of these
2441             --  conditions holds:
2442 
2443             --    The expression of the right side has Do_Range_Check set so
2444             --    that we know a range check will be performed. Note that it
2445             --    can be the case that a range check is omitted because we
2446             --    make the assumption that we can assume validity for operands
2447             --    appearing in the right side in determining whether a range
2448             --    check is required
2449 
2450             --    The subtype of the right side matches the subtype of the
2451             --    left side. In this case, even though we have not checked
2452             --    the range of the right side, we know it is in range of its
2453             --    subtype if the expression is valid.
2454 
2455             if Is_Local_Variable_Reference (Lhs)
2456               and then not Is_Known_Valid (Entity (Lhs))
2457               and then In_Unconditional_Context (N)
2458             then
2459                if Do_Range_Check (Rhs)
2460                  or else Etype (Lhs) = Etype (Rhs)
2461                then
2462                   Set_Is_Known_Valid (Entity (Lhs), True);
2463                end if;
2464             end if;
2465 
2466          --  Case where right side may be invalid in the sense of the RM
2467          --  reference above. The RM does not require that we check for the
2468          --  validity on an assignment, but it does require that the assignment
2469          --  of an invalid value not cause erroneous behavior.
2470 
2471          --  The general approach in GNAT is to use the Is_Known_Valid flag
2472          --  to avoid the need for validity checking on assignments. However
2473          --  in some cases, we have to do validity checking in order to make
2474          --  sure that the setting of this flag is correct.
2475 
2476          else
2477             --  Validate right side if we are validating copies
2478 
2479             if Validity_Checks_On
2480               and then Validity_Check_Copies
2481             then
2482                --  Skip this if left hand side is an array or record component
2483                --  and elementary component validity checks are suppressed.
2484 
2485                if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component)
2486                  and then not Validity_Check_Components
2487                then
2488                   null;
2489                else
2490                   Ensure_Valid (Rhs);
2491                end if;
2492 
2493                --  We can propagate this to the left side where appropriate
2494 
2495                if Is_Local_Variable_Reference (Lhs)
2496                  and then not Is_Known_Valid (Entity (Lhs))
2497                  and then In_Unconditional_Context (N)
2498                then
2499                   Set_Is_Known_Valid (Entity (Lhs), True);
2500                end if;
2501 
2502             --  Otherwise check to see what should be done
2503 
2504             --  If left side is a local variable, then we just set its flag to
2505             --  indicate that its value may no longer be valid, since we are
2506             --  copying a potentially invalid value.
2507 
2508             elsif Is_Local_Variable_Reference (Lhs) then
2509                Set_Is_Known_Valid (Entity (Lhs), False);
2510 
2511             --  Check for case of a nonlocal variable on the left side which
2512             --  is currently known to be valid. In this case, we simply ensure
2513             --  that the right side is valid. We only play the game of copying
2514             --  validity status for local variables, since we are doing this
2515             --  statically, not by tracing the full flow graph.
2516 
2517             elsif Is_Entity_Name (Lhs)
2518               and then Is_Known_Valid (Entity (Lhs))
2519             then
2520                --  Note: If Validity_Checking mode is set to none, we ignore
2521                --  the Ensure_Valid call so don't worry about that case here.
2522 
2523                Ensure_Valid (Rhs);
2524 
2525             --  In all other cases, we can safely copy an invalid value without
2526             --  worrying about the status of the left side. Since it is not a
2527             --  variable reference it will not be considered
2528             --  as being known to be valid in any case.
2529 
2530             else
2531                null;
2532             end if;
2533          end if;
2534       end if;
2535 
2536       Ghost_Mode := Save_Ghost_Mode;
2537 
2538    exception
2539       when RE_Not_Available =>
2540          Ghost_Mode := Save_Ghost_Mode;
2541          return;
2542    end Expand_N_Assignment_Statement;
2543 
2544    ------------------------------
2545    -- Expand_N_Block_Statement --
2546    ------------------------------
2547 
2548    --  Encode entity names defined in block statement
2549 
2550    procedure Expand_N_Block_Statement (N : Node_Id) is
2551    begin
2552       Qualify_Entity_Names (N);
2553    end Expand_N_Block_Statement;
2554 
2555    -----------------------------
2556    -- Expand_N_Case_Statement --
2557    -----------------------------
2558 
2559    procedure Expand_N_Case_Statement (N : Node_Id) is
2560       Loc    : constant Source_Ptr := Sloc (N);
2561       Expr   : constant Node_Id    := Expression (N);
2562       Alt    : Node_Id;
2563       Len    : Nat;
2564       Cond   : Node_Id;
2565       Choice : Node_Id;
2566       Chlist : List_Id;
2567 
2568    begin
2569       --  Check for the situation where we know at compile time which branch
2570       --  will be taken.
2571 
2572       --  If the value is static but its subtype is predicated and the value
2573       --  does not obey the predicate, the value is marked non-static, and
2574       --  there can be no corresponding static alternative. In that case we
2575       --  replace the case statement with an exception, regardless of whether
2576       --  assertions are enabled or not, unless predicates are ignored.
2577 
2578       if Compile_Time_Known_Value (Expr)
2579         and then Has_Predicates (Etype (Expr))
2580         and then not Predicates_Ignored (Etype (Expr))
2581         and then not Is_OK_Static_Expression (Expr)
2582       then
2583          Rewrite (N,
2584            Make_Raise_Constraint_Error (Loc, Reason => CE_Invalid_Data));
2585          Analyze (N);
2586          return;
2587 
2588       elsif Compile_Time_Known_Value (Expr)
2589         and then (not Has_Predicates (Etype (Expr))
2590                    or else Is_Static_Expression (Expr))
2591       then
2592          Alt := Find_Static_Alternative (N);
2593 
2594          --  Do not consider controlled objects found in a case statement which
2595          --  actually models a case expression because their early finalization
2596          --  will affect the result of the expression.
2597 
2598          if not From_Conditional_Expression (N) then
2599             Process_Statements_For_Controlled_Objects (Alt);
2600          end if;
2601 
2602          --  Move statements from this alternative after the case statement.
2603          --  They are already analyzed, so will be skipped by the analyzer.
2604 
2605          Insert_List_After (N, Statements (Alt));
2606 
2607          --  That leaves the case statement as a shell. So now we can kill all
2608          --  other alternatives in the case statement.
2609 
2610          Kill_Dead_Code (Expression (N));
2611 
2612          declare
2613             Dead_Alt : Node_Id;
2614 
2615          begin
2616             --  Loop through case alternatives, skipping pragmas, and skipping
2617             --  the one alternative that we select (and therefore retain).
2618 
2619             Dead_Alt := First (Alternatives (N));
2620             while Present (Dead_Alt) loop
2621                if Dead_Alt /= Alt
2622                  and then Nkind (Dead_Alt) = N_Case_Statement_Alternative
2623                then
2624                   Kill_Dead_Code (Statements (Dead_Alt), Warn_On_Deleted_Code);
2625                end if;
2626 
2627                Next (Dead_Alt);
2628             end loop;
2629          end;
2630 
2631          Rewrite (N, Make_Null_Statement (Loc));
2632          return;
2633       end if;
2634 
2635       --  Here if the choice is not determined at compile time
2636 
2637       declare
2638          Last_Alt : constant Node_Id := Last (Alternatives (N));
2639 
2640          Others_Present : Boolean;
2641          Others_Node    : Node_Id;
2642 
2643          Then_Stms : List_Id;
2644          Else_Stms : List_Id;
2645 
2646       begin
2647          if Nkind (First (Discrete_Choices (Last_Alt))) = N_Others_Choice then
2648             Others_Present := True;
2649             Others_Node    := Last_Alt;
2650          else
2651             Others_Present := False;
2652          end if;
2653 
2654          --  First step is to worry about possible invalid argument. The RM
2655          --  requires (RM 5.4(13)) that if the result is invalid (e.g. it is
2656          --  outside the base range), then Constraint_Error must be raised.
2657 
2658          --  Case of validity check required (validity checks are on, the
2659          --  expression is not known to be valid, and the case statement
2660          --  comes from source -- no need to validity check internally
2661          --  generated case statements).
2662 
2663          if Validity_Check_Default
2664            and then not Predicates_Ignored (Etype (Expr))
2665          then
2666             Ensure_Valid (Expr);
2667          end if;
2668 
2669          --  If there is only a single alternative, just replace it with the
2670          --  sequence of statements since obviously that is what is going to
2671          --  be executed in all cases.
2672 
2673          Len := List_Length (Alternatives (N));
2674 
2675          if Len = 1 then
2676 
2677             --  We still need to evaluate the expression if it has any side
2678             --  effects.
2679 
2680             Remove_Side_Effects (Expression (N));
2681             Alt := First (Alternatives (N));
2682 
2683             --  Do not consider controlled objects found in a case statement
2684             --  which actually models a case expression because their early
2685             --  finalization will affect the result of the expression.
2686 
2687             if not From_Conditional_Expression (N) then
2688                Process_Statements_For_Controlled_Objects (Alt);
2689             end if;
2690 
2691             Insert_List_After (N, Statements (Alt));
2692 
2693             --  That leaves the case statement as a shell. The alternative that
2694             --  will be executed is reset to a null list. So now we can kill
2695             --  the entire case statement.
2696 
2697             Kill_Dead_Code (Expression (N));
2698             Rewrite (N, Make_Null_Statement (Loc));
2699             return;
2700 
2701          --  An optimization. If there are only two alternatives, and only
2702          --  a single choice, then rewrite the whole case statement as an
2703          --  if statement, since this can result in subsequent optimizations.
2704          --  This helps not only with case statements in the source of a
2705          --  simple form, but also with generated code (discriminant check
2706          --  functions in particular).
2707 
2708          --  Note: it is OK to do this before expanding out choices for any
2709          --  static predicates, since the if statement processing will handle
2710          --  the static predicate case fine.
2711 
2712          elsif Len = 2 then
2713             Chlist := Discrete_Choices (First (Alternatives (N)));
2714 
2715             if List_Length (Chlist) = 1 then
2716                Choice := First (Chlist);
2717 
2718                Then_Stms := Statements (First (Alternatives (N)));
2719                Else_Stms := Statements (Last  (Alternatives (N)));
2720 
2721                --  For TRUE, generate "expression", not expression = true
2722 
2723                if Nkind (Choice) = N_Identifier
2724                  and then Entity (Choice) = Standard_True
2725                then
2726                   Cond := Expression (N);
2727 
2728                --  For FALSE, generate "expression" and switch then/else
2729 
2730                elsif Nkind (Choice) = N_Identifier
2731                  and then Entity (Choice) = Standard_False
2732                then
2733                   Cond := Expression (N);
2734                   Else_Stms := Statements (First (Alternatives (N)));
2735                   Then_Stms := Statements (Last  (Alternatives (N)));
2736 
2737                --  For a range, generate "expression in range"
2738 
2739                elsif Nkind (Choice) = N_Range
2740                  or else (Nkind (Choice) = N_Attribute_Reference
2741                            and then Attribute_Name (Choice) = Name_Range)
2742                  or else (Is_Entity_Name (Choice)
2743                            and then Is_Type (Entity (Choice)))
2744                then
2745                   Cond :=
2746                     Make_In (Loc,
2747                       Left_Opnd  => Expression (N),
2748                       Right_Opnd => Relocate_Node (Choice));
2749 
2750                --  A subtype indication is not a legal operator in a membership
2751                --  test, so retrieve its range.
2752 
2753                elsif Nkind (Choice) = N_Subtype_Indication then
2754                   Cond :=
2755                     Make_In (Loc,
2756                       Left_Opnd  => Expression (N),
2757                       Right_Opnd =>
2758                         Relocate_Node
2759                           (Range_Expression (Constraint (Choice))));
2760 
2761                --  For any other subexpression "expression = value"
2762 
2763                else
2764                   Cond :=
2765                     Make_Op_Eq (Loc,
2766                       Left_Opnd  => Expression (N),
2767                       Right_Opnd => Relocate_Node (Choice));
2768                end if;
2769 
2770                --  Now rewrite the case as an IF
2771 
2772                Rewrite (N,
2773                  Make_If_Statement (Loc,
2774                    Condition => Cond,
2775                    Then_Statements => Then_Stms,
2776                    Else_Statements => Else_Stms));
2777                Analyze (N);
2778                return;
2779             end if;
2780          end if;
2781 
2782          --  If the last alternative is not an Others choice, replace it with
2783          --  an N_Others_Choice. Note that we do not bother to call Analyze on
2784          --  the modified case statement, since it's only effect would be to
2785          --  compute the contents of the Others_Discrete_Choices which is not
2786          --  needed by the back end anyway.
2787 
2788          --  The reason for this is that the back end always needs some default
2789          --  for a switch, so if we have not supplied one in the processing
2790          --  above for validity checking, then we need to supply one here.
2791 
2792          if not Others_Present then
2793             Others_Node := Make_Others_Choice (Sloc (Last_Alt));
2794 
2795             --  If Predicates_Ignored is true the value does not satisfy the
2796             --  predicate, and there is no Others choice, Constraint_Error
2797             --  must be raised (4.5.7 (21/3)).
2798 
2799             if Predicates_Ignored (Etype (Expr)) then
2800                declare
2801                   Except  : constant Node_Id :=
2802                               Make_Raise_Constraint_Error (Loc,
2803                                 Reason => CE_Invalid_Data);
2804                   New_Alt : constant Node_Id :=
2805                               Make_Case_Statement_Alternative (Loc,
2806                                 Discrete_Choices => New_List (
2807                                   Make_Others_Choice (Loc)),
2808                                 Statements       => New_List (Except));
2809 
2810                begin
2811                   Append (New_Alt, Alternatives (N));
2812                   Analyze_And_Resolve (Except);
2813                end;
2814 
2815             else
2816                Set_Others_Discrete_Choices
2817                  (Others_Node, Discrete_Choices (Last_Alt));
2818                Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
2819             end if;
2820 
2821          end if;
2822 
2823          --  Deal with possible declarations of controlled objects, and also
2824          --  with rewriting choice sequences for static predicate references.
2825 
2826          Alt := First_Non_Pragma (Alternatives (N));
2827          while Present (Alt) loop
2828 
2829             --  Do not consider controlled objects found in a case statement
2830             --  which actually models a case expression because their early
2831             --  finalization will affect the result of the expression.
2832 
2833             if not From_Conditional_Expression (N) then
2834                Process_Statements_For_Controlled_Objects (Alt);
2835             end if;
2836 
2837             if Has_SP_Choice (Alt) then
2838                Expand_Static_Predicates_In_Choices (Alt);
2839             end if;
2840 
2841             Next_Non_Pragma (Alt);
2842          end loop;
2843       end;
2844    end Expand_N_Case_Statement;
2845 
2846    -----------------------------
2847    -- Expand_N_Exit_Statement --
2848    -----------------------------
2849 
2850    --  The only processing required is to deal with a possible C/Fortran
2851    --  boolean value used as the condition for the exit statement.
2852 
2853    procedure Expand_N_Exit_Statement (N : Node_Id) is
2854    begin
2855       Adjust_Condition (Condition (N));
2856    end Expand_N_Exit_Statement;
2857 
2858    ----------------------------------
2859    -- Expand_Formal_Container_Loop --
2860    ----------------------------------
2861 
2862    procedure Expand_Formal_Container_Loop (N : Node_Id) is
2863       Loc       : constant Source_Ptr := Sloc (N);
2864       Isc       : constant Node_Id    := Iteration_Scheme (N);
2865       I_Spec    : constant Node_Id    := Iterator_Specification (Isc);
2866       Cursor    : constant Entity_Id  := Defining_Identifier (I_Spec);
2867       Container : constant Node_Id    := Entity (Name (I_Spec));
2868       Stats     : constant List_Id    := Statements (N);
2869 
2870       Advance  : Node_Id;
2871       Blk_Nod  : Node_Id;
2872       Init     : Node_Id;
2873       New_Loop : Node_Id;
2874 
2875    begin
2876       --  The expansion resembles the one for Ada containers, but the
2877       --  primitives mention the domain of iteration explicitly, and
2878       --  function First applied to the container yields a cursor directly.
2879 
2880       --    Cursor : Cursor_type := First (Container);
2881       --    while Has_Element (Cursor, Container) loop
2882       --          <original loop statements>
2883       --       Cursor := Next (Container, Cursor);
2884       --    end loop;
2885 
2886       Build_Formal_Container_Iteration
2887         (N, Container, Cursor, Init, Advance, New_Loop);
2888 
2889       Set_Ekind (Cursor, E_Variable);
2890       Append_To (Stats, Advance);
2891 
2892       --  Build block to capture declaration of cursor entity.
2893 
2894       Blk_Nod :=
2895         Make_Block_Statement (Loc,
2896           Declarations               => New_List (Init),
2897           Handled_Statement_Sequence =>
2898             Make_Handled_Sequence_Of_Statements (Loc,
2899               Statements => New_List (New_Loop)));
2900 
2901       Rewrite (N, Blk_Nod);
2902       Analyze (N);
2903    end Expand_Formal_Container_Loop;
2904 
2905    ------------------------------------------
2906    -- Expand_Formal_Container_Element_Loop --
2907    ------------------------------------------
2908 
2909    procedure Expand_Formal_Container_Element_Loop (N : Node_Id) is
2910       Loc           : constant Source_Ptr := Sloc (N);
2911       Isc           : constant Node_Id    := Iteration_Scheme (N);
2912       I_Spec        : constant Node_Id    := Iterator_Specification (Isc);
2913       Element       : constant Entity_Id  := Defining_Identifier (I_Spec);
2914       Container     : constant Node_Id    := Entity (Name (I_Spec));
2915       Container_Typ : constant Entity_Id  := Base_Type (Etype (Container));
2916       Stats         : constant List_Id    := Statements (N);
2917 
2918       Cursor    : constant Entity_Id :=
2919                     Make_Defining_Identifier (Loc,
2920                       Chars => New_External_Name (Chars (Element), 'C'));
2921       Elmt_Decl : Node_Id;
2922       Elmt_Ref  : Node_Id;
2923 
2924       Element_Op : constant Entity_Id :=
2925                      Get_Iterable_Type_Primitive (Container_Typ, Name_Element);
2926 
2927       Advance   : Node_Id;
2928       Init      : Node_Id;
2929       New_Loop  : Node_Id;
2930 
2931    begin
2932       --  For an element iterator, the Element aspect must be present,
2933       --  (this is checked during analysis) and the expansion takes the form:
2934 
2935       --    Cursor : Cursor_type := First (Container);
2936       --    Elmt : Element_Type;
2937       --    while Has_Element (Cursor, Container) loop
2938       --       Elmt := Element (Container, Cursor);
2939       --          <original loop statements>
2940       --       Cursor := Next (Container, Cursor);
2941       --    end loop;
2942 
2943       --   However this expansion is not legal if the element is indefinite.
2944       --   In that case we create a block to hold a variable declaration
2945       --   initialized with a call to Element, and generate:
2946 
2947       --    Cursor : Cursor_type := First (Container);
2948       --    while Has_Element (Cursor, Container) loop
2949       --       declare
2950       --          Elmt : Element-Type := Element (Container, Cursor);
2951       --       begin
2952       --          <original loop statements>
2953       --          Cursor := Next (Container, Cursor);
2954       --       end;
2955       --    end loop;
2956 
2957       Build_Formal_Container_Iteration
2958         (N, Container, Cursor, Init, Advance, New_Loop);
2959       Append_To (Stats, Advance);
2960 
2961       Set_Ekind (Cursor, E_Variable);
2962       Insert_Action (N, Init);
2963 
2964       --  Declaration for Element.
2965 
2966       Elmt_Decl :=
2967         Make_Object_Declaration (Loc,
2968           Defining_Identifier => Element,
2969           Object_Definition   => New_Occurrence_Of (Etype (Element_Op), Loc));
2970 
2971       if not Is_Constrained (Etype (Element_Op)) then
2972          Set_Expression (Elmt_Decl,
2973            Make_Function_Call (Loc,
2974              Name                   => New_Occurrence_Of (Element_Op, Loc),
2975              Parameter_Associations => New_List (
2976                New_Occurrence_Of (Container, Loc),
2977                New_Occurrence_Of (Cursor, Loc))));
2978 
2979          Set_Statements (New_Loop,
2980            New_List
2981              (Make_Block_Statement (Loc,
2982                 Declarations => New_List (Elmt_Decl),
2983                 Handled_Statement_Sequence =>
2984                   Make_Handled_Sequence_Of_Statements (Loc,
2985                     Statements =>  Stats))));
2986 
2987       else
2988          Elmt_Ref :=
2989            Make_Assignment_Statement (Loc,
2990              Name       => New_Occurrence_Of (Element, Loc),
2991              Expression =>
2992                Make_Function_Call (Loc,
2993                  Name                   => New_Occurrence_Of (Element_Op, Loc),
2994                  Parameter_Associations => New_List (
2995                    New_Occurrence_Of (Container, Loc),
2996                    New_Occurrence_Of (Cursor, Loc))));
2997 
2998          Prepend (Elmt_Ref, Stats);
2999 
3000          --  The element is assignable in the expanded code
3001 
3002          Set_Assignment_OK (Name (Elmt_Ref));
3003 
3004          --  The loop is rewritten as a block, to hold the element declaration
3005 
3006          New_Loop :=
3007            Make_Block_Statement (Loc,
3008              Declarations               => New_List (Elmt_Decl),
3009              Handled_Statement_Sequence =>
3010                Make_Handled_Sequence_Of_Statements (Loc,
3011                  Statements =>  New_List (New_Loop)));
3012       end if;
3013 
3014       --  The element is only modified in expanded code, so it appears as
3015       --  unassigned to the warning machinery. We must suppress this spurious
3016       --  warning explicitly.
3017 
3018       Set_Warnings_Off (Element);
3019 
3020       Rewrite (N, New_Loop);
3021 
3022       --  The loop parameter is declared by an object declaration, but within
3023       --  the loop we must prevent user assignments to it, so we analyze the
3024       --  declaration and reset the entity kind, before analyzing the rest of
3025       --  the loop;
3026 
3027       Analyze (Elmt_Decl);
3028       Set_Ekind (Defining_Identifier (Elmt_Decl), E_Loop_Parameter);
3029 
3030       Analyze (N);
3031    end Expand_Formal_Container_Element_Loop;
3032 
3033    -----------------------------
3034    -- Expand_N_Goto_Statement --
3035    -----------------------------
3036 
3037    --  Add poll before goto if polling active
3038 
3039    procedure Expand_N_Goto_Statement (N : Node_Id) is
3040    begin
3041       Generate_Poll_Call (N);
3042    end Expand_N_Goto_Statement;
3043 
3044    ---------------------------
3045    -- Expand_N_If_Statement --
3046    ---------------------------
3047 
3048    --  First we deal with the case of C and Fortran convention boolean values,
3049    --  with zero/non-zero semantics.
3050 
3051    --  Second, we deal with the obvious rewriting for the cases where the
3052    --  condition of the IF is known at compile time to be True or False.
3053 
3054    --  Third, we remove elsif parts which have non-empty Condition_Actions and
3055    --  rewrite as independent if statements. For example:
3056 
3057    --     if x then xs
3058    --     elsif y then ys
3059    --     ...
3060    --     end if;
3061 
3062    --  becomes
3063    --
3064    --     if x then xs
3065    --     else
3066    --        <<condition actions of y>>
3067    --        if y then ys
3068    --        ...
3069    --        end if;
3070    --     end if;
3071 
3072    --  This rewriting is needed if at least one elsif part has a non-empty
3073    --  Condition_Actions list. We also do the same processing if there is a
3074    --  constant condition in an elsif part (in conjunction with the first
3075    --  processing step mentioned above, for the recursive call made to deal
3076    --  with the created inner if, this deals with properly optimizing the
3077    --  cases of constant elsif conditions).
3078 
3079    procedure Expand_N_If_Statement (N : Node_Id) is
3080       Loc    : constant Source_Ptr := Sloc (N);
3081       Hed    : Node_Id;
3082       E      : Node_Id;
3083       New_If : Node_Id;
3084 
3085       Warn_If_Deleted : constant Boolean :=
3086                           Warn_On_Deleted_Code and then Comes_From_Source (N);
3087       --  Indicates whether we want warnings when we delete branches of the
3088       --  if statement based on constant condition analysis. We never want
3089       --  these warnings for expander generated code.
3090 
3091    begin
3092       --  Do not consider controlled objects found in an if statement which
3093       --  actually models an if expression because their early finalization
3094       --  will affect the result of the expression.
3095 
3096       if not From_Conditional_Expression (N) then
3097          Process_Statements_For_Controlled_Objects (N);
3098       end if;
3099 
3100       Adjust_Condition (Condition (N));
3101 
3102       --  The following loop deals with constant conditions for the IF. We
3103       --  need a loop because as we eliminate False conditions, we grab the
3104       --  first elsif condition and use it as the primary condition.
3105 
3106       while Compile_Time_Known_Value (Condition (N)) loop
3107 
3108          --  If condition is True, we can simply rewrite the if statement now
3109          --  by replacing it by the series of then statements.
3110 
3111          if Is_True (Expr_Value (Condition (N))) then
3112 
3113             --  All the else parts can be killed
3114 
3115             Kill_Dead_Code (Elsif_Parts (N), Warn_If_Deleted);
3116             Kill_Dead_Code (Else_Statements (N), Warn_If_Deleted);
3117 
3118             Hed := Remove_Head (Then_Statements (N));
3119             Insert_List_After (N, Then_Statements (N));
3120             Rewrite (N, Hed);
3121             return;
3122 
3123          --  If condition is False, then we can delete the condition and
3124          --  the Then statements
3125 
3126          else
3127             --  We do not delete the condition if constant condition warnings
3128             --  are enabled, since otherwise we end up deleting the desired
3129             --  warning. Of course the backend will get rid of this True/False
3130             --  test anyway, so nothing is lost here.
3131 
3132             if not Constant_Condition_Warnings then
3133                Kill_Dead_Code (Condition (N));
3134             end if;
3135 
3136             Kill_Dead_Code (Then_Statements (N), Warn_If_Deleted);
3137 
3138             --  If there are no elsif statements, then we simply replace the
3139             --  entire if statement by the sequence of else statements.
3140 
3141             if No (Elsif_Parts (N)) then
3142                if No (Else_Statements (N))
3143                  or else Is_Empty_List (Else_Statements (N))
3144                then
3145                   Rewrite (N,
3146                     Make_Null_Statement (Sloc (N)));
3147                else
3148                   Hed := Remove_Head (Else_Statements (N));
3149                   Insert_List_After (N, Else_Statements (N));
3150                   Rewrite (N, Hed);
3151                end if;
3152 
3153                return;
3154 
3155             --  If there are elsif statements, the first of them becomes the
3156             --  if/then section of the rebuilt if statement This is the case
3157             --  where we loop to reprocess this copied condition.
3158 
3159             else
3160                Hed := Remove_Head (Elsif_Parts (N));
3161                Insert_Actions      (N, Condition_Actions (Hed));
3162                Set_Condition       (N, Condition (Hed));
3163                Set_Then_Statements (N, Then_Statements (Hed));
3164 
3165                --  Hed might have been captured as the condition determining
3166                --  the current value for an entity. Now it is detached from
3167                --  the tree, so a Current_Value pointer in the condition might
3168                --  need to be updated.
3169 
3170                Set_Current_Value_Condition (N);
3171 
3172                if Is_Empty_List (Elsif_Parts (N)) then
3173                   Set_Elsif_Parts (N, No_List);
3174                end if;
3175             end if;
3176          end if;
3177       end loop;
3178 
3179       --  Loop through elsif parts, dealing with constant conditions and
3180       --  possible condition actions that are present.
3181 
3182       if Present (Elsif_Parts (N)) then
3183          E := First (Elsif_Parts (N));
3184          while Present (E) loop
3185 
3186             --  Do not consider controlled objects found in an if statement
3187             --  which actually models an if expression because their early
3188             --  finalization will affect the result of the expression.
3189 
3190             if not From_Conditional_Expression (N) then
3191                Process_Statements_For_Controlled_Objects (E);
3192             end if;
3193 
3194             Adjust_Condition (Condition (E));
3195 
3196             --  If there are condition actions, then rewrite the if statement
3197             --  as indicated above. We also do the same rewrite for a True or
3198             --  False condition. The further processing of this constant
3199             --  condition is then done by the recursive call to expand the
3200             --  newly created if statement
3201 
3202             if Present (Condition_Actions (E))
3203               or else Compile_Time_Known_Value (Condition (E))
3204             then
3205                --  Note this is not an implicit if statement, since it is part
3206                --  of an explicit if statement in the source (or of an implicit
3207                --  if statement that has already been tested).
3208 
3209                New_If :=
3210                  Make_If_Statement (Sloc (E),
3211                    Condition       => Condition (E),
3212                    Then_Statements => Then_Statements (E),
3213                    Elsif_Parts     => No_List,
3214                    Else_Statements => Else_Statements (N));
3215 
3216                --  Elsif parts for new if come from remaining elsif's of parent
3217 
3218                while Present (Next (E)) loop
3219                   if No (Elsif_Parts (New_If)) then
3220                      Set_Elsif_Parts (New_If, New_List);
3221                   end if;
3222 
3223                   Append (Remove_Next (E), Elsif_Parts (New_If));
3224                end loop;
3225 
3226                Set_Else_Statements (N, New_List (New_If));
3227 
3228                if Present (Condition_Actions (E)) then
3229                   Insert_List_Before (New_If, Condition_Actions (E));
3230                end if;
3231 
3232                Remove (E);
3233 
3234                if Is_Empty_List (Elsif_Parts (N)) then
3235                   Set_Elsif_Parts (N, No_List);
3236                end if;
3237 
3238                Analyze (New_If);
3239                return;
3240 
3241             --  No special processing for that elsif part, move to next
3242 
3243             else
3244                Next (E);
3245             end if;
3246          end loop;
3247       end if;
3248 
3249       --  Some more optimizations applicable if we still have an IF statement
3250 
3251       if Nkind (N) /= N_If_Statement then
3252          return;
3253       end if;
3254 
3255       --  Another optimization, special cases that can be simplified
3256 
3257       --     if expression then
3258       --        return true;
3259       --     else
3260       --        return false;
3261       --     end if;
3262 
3263       --  can be changed to:
3264 
3265       --     return expression;
3266 
3267       --  and
3268 
3269       --     if expression then
3270       --        return false;
3271       --     else
3272       --        return true;
3273       --     end if;
3274 
3275       --  can be changed to:
3276 
3277       --     return not (expression);
3278 
3279       --  Only do these optimizations if we are at least at -O1 level and
3280       --  do not do them if control flow optimizations are suppressed.
3281 
3282       if Optimization_Level > 0
3283         and then not Opt.Suppress_Control_Flow_Optimizations
3284       then
3285          if Nkind (N) = N_If_Statement
3286            and then No (Elsif_Parts (N))
3287            and then Present (Else_Statements (N))
3288            and then List_Length (Then_Statements (N)) = 1
3289            and then List_Length (Else_Statements (N)) = 1
3290          then
3291             declare
3292                Then_Stm : constant Node_Id := First (Then_Statements (N));
3293                Else_Stm : constant Node_Id := First (Else_Statements (N));
3294 
3295             begin
3296                if Nkind (Then_Stm) = N_Simple_Return_Statement
3297                     and then
3298                   Nkind (Else_Stm) = N_Simple_Return_Statement
3299                then
3300                   declare
3301                      Then_Expr : constant Node_Id := Expression (Then_Stm);
3302                      Else_Expr : constant Node_Id := Expression (Else_Stm);
3303 
3304                   begin
3305                      if Nkind (Then_Expr) = N_Identifier
3306                           and then
3307                         Nkind (Else_Expr) = N_Identifier
3308                      then
3309                         if Entity (Then_Expr) = Standard_True
3310                           and then Entity (Else_Expr) = Standard_False
3311                         then
3312                            Rewrite (N,
3313                              Make_Simple_Return_Statement (Loc,
3314                                Expression => Relocate_Node (Condition (N))));
3315                            Analyze (N);
3316                            return;
3317 
3318                         elsif Entity (Then_Expr) = Standard_False
3319                           and then Entity (Else_Expr) = Standard_True
3320                         then
3321                            Rewrite (N,
3322                              Make_Simple_Return_Statement (Loc,
3323                                Expression =>
3324                                  Make_Op_Not (Loc,
3325                                    Right_Opnd =>
3326                                      Relocate_Node (Condition (N)))));
3327                            Analyze (N);
3328                            return;
3329                         end if;
3330                      end if;
3331                   end;
3332                end if;
3333             end;
3334          end if;
3335       end if;
3336    end Expand_N_If_Statement;
3337 
3338    --------------------------
3339    -- Expand_Iterator_Loop --
3340    --------------------------
3341 
3342    procedure Expand_Iterator_Loop (N : Node_Id) is
3343       Isc    : constant Node_Id    := Iteration_Scheme (N);
3344       I_Spec : constant Node_Id    := Iterator_Specification (Isc);
3345 
3346       Container     : constant Node_Id     := Name (I_Spec);
3347       Container_Typ : constant Entity_Id   := Base_Type (Etype (Container));
3348 
3349    begin
3350       --  Processing for arrays
3351 
3352       if Is_Array_Type (Container_Typ) then
3353          pragma Assert (Of_Present (I_Spec));
3354          Expand_Iterator_Loop_Over_Array (N);
3355 
3356       elsif Has_Aspect (Container_Typ, Aspect_Iterable) then
3357          if Of_Present (I_Spec) then
3358             Expand_Formal_Container_Element_Loop (N);
3359          else
3360             Expand_Formal_Container_Loop (N);
3361          end if;
3362 
3363       --  Processing for containers
3364 
3365       else
3366          Expand_Iterator_Loop_Over_Container
3367            (N, Isc, I_Spec, Container, Container_Typ);
3368       end if;
3369    end Expand_Iterator_Loop;
3370 
3371    -------------------------------------
3372    -- Expand_Iterator_Loop_Over_Array --
3373    -------------------------------------
3374 
3375    procedure Expand_Iterator_Loop_Over_Array (N : Node_Id) is
3376       Isc        : constant Node_Id    := Iteration_Scheme (N);
3377       I_Spec     : constant Node_Id    := Iterator_Specification (Isc);
3378       Array_Node : constant Node_Id    := Name (I_Spec);
3379       Array_Typ  : constant Entity_Id  := Base_Type (Etype (Array_Node));
3380       Array_Dim  : constant Pos        := Number_Dimensions (Array_Typ);
3381       Id         : constant Entity_Id  := Defining_Identifier (I_Spec);
3382       Loc        : constant Source_Ptr := Sloc (N);
3383       Stats      : constant List_Id    := Statements (N);
3384       Core_Loop  : Node_Id;
3385       Dim1       : Int;
3386       Ind_Comp   : Node_Id;
3387       Iterator   : Entity_Id;
3388 
3389    --  Start of processing for Expand_Iterator_Loop_Over_Array
3390 
3391    begin
3392       --  for Element of Array loop
3393 
3394       --  It requires an internally generated cursor to iterate over the array
3395 
3396       pragma Assert (Of_Present (I_Spec));
3397 
3398       Iterator := Make_Temporary (Loc, 'C');
3399 
3400       --  Generate:
3401       --    Element : Component_Type renames Array (Iterator);
3402       --    Iterator is the index value, or a list of index values
3403       --    in the case of a multidimensional array.
3404 
3405       Ind_Comp :=
3406         Make_Indexed_Component (Loc,
3407           Prefix      => Relocate_Node (Array_Node),
3408           Expressions => New_List (New_Occurrence_Of (Iterator, Loc)));
3409 
3410       Prepend_To (Stats,
3411         Make_Object_Renaming_Declaration (Loc,
3412           Defining_Identifier => Id,
3413           Subtype_Mark        =>
3414             New_Occurrence_Of (Component_Type (Array_Typ), Loc),
3415           Name                => Ind_Comp));
3416 
3417       --  Mark the loop variable as needing debug info, so that expansion
3418       --  of the renaming will result in Materialize_Entity getting set via
3419       --  Debug_Renaming_Declaration. (This setting is needed here because
3420       --  the setting in Freeze_Entity comes after the expansion, which is
3421       --  too late. ???)
3422 
3423       Set_Debug_Info_Needed (Id);
3424 
3425       --  Generate:
3426 
3427       --    for Iterator in [reverse] Array'Range (Array_Dim) loop
3428       --       Element : Component_Type renames Array (Iterator);
3429       --       <original loop statements>
3430       --    end loop;
3431 
3432       --  If this is an iteration over a multidimensional array, the
3433       --  innermost loop is over the last dimension in Ada, and over
3434       --  the first dimension in Fortran.
3435 
3436       if Convention (Array_Typ) = Convention_Fortran then
3437          Dim1 := 1;
3438       else
3439          Dim1 := Array_Dim;
3440       end if;
3441 
3442       Core_Loop :=
3443         Make_Loop_Statement (Loc,
3444           Iteration_Scheme =>
3445             Make_Iteration_Scheme (Loc,
3446               Loop_Parameter_Specification =>
3447                 Make_Loop_Parameter_Specification (Loc,
3448                   Defining_Identifier         => Iterator,
3449                   Discrete_Subtype_Definition =>
3450                     Make_Attribute_Reference (Loc,
3451                       Prefix         => Relocate_Node (Array_Node),
3452                       Attribute_Name => Name_Range,
3453                       Expressions    => New_List (
3454                         Make_Integer_Literal (Loc, Dim1))),
3455                   Reverse_Present             => Reverse_Present (I_Spec))),
3456            Statements      => Stats,
3457            End_Label       => Empty);
3458 
3459       --  Processing for multidimensional array. The body of each loop is
3460       --  a loop over a previous dimension, going in decreasing order in Ada
3461       --  and in increasing order in Fortran.
3462 
3463       if Array_Dim > 1 then
3464          for Dim in 1 .. Array_Dim - 1 loop
3465             if Convention (Array_Typ) = Convention_Fortran then
3466                Dim1 := Dim + 1;
3467             else
3468                Dim1 := Array_Dim - Dim;
3469             end if;
3470 
3471             Iterator := Make_Temporary (Loc, 'C');
3472 
3473             --  Generate the dimension loops starting from the innermost one
3474 
3475             --    for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
3476             --       <core loop>
3477             --    end loop;
3478 
3479             Core_Loop :=
3480               Make_Loop_Statement (Loc,
3481                 Iteration_Scheme =>
3482                   Make_Iteration_Scheme (Loc,
3483                     Loop_Parameter_Specification =>
3484                       Make_Loop_Parameter_Specification (Loc,
3485                         Defining_Identifier         => Iterator,
3486                         Discrete_Subtype_Definition =>
3487                           Make_Attribute_Reference (Loc,
3488                             Prefix         => Relocate_Node (Array_Node),
3489                             Attribute_Name => Name_Range,
3490                             Expressions    => New_List (
3491                               Make_Integer_Literal (Loc, Dim1))),
3492                     Reverse_Present              => Reverse_Present (I_Spec))),
3493                 Statements       => New_List (Core_Loop),
3494                 End_Label        => Empty);
3495 
3496             --  Update the previously created object renaming declaration with
3497             --  the new iterator, by adding the index of the next loop to the
3498             --  indexed component, in the order that corresponds to the
3499             --  convention.
3500 
3501             if Convention (Array_Typ) = Convention_Fortran then
3502                Append_To (Expressions (Ind_Comp),
3503                  New_Occurrence_Of (Iterator, Loc));
3504             else
3505                Prepend_To (Expressions (Ind_Comp),
3506                  New_Occurrence_Of (Iterator, Loc));
3507             end if;
3508          end loop;
3509       end if;
3510 
3511       --  Inherit the loop identifier from the original loop. This ensures that
3512       --  the scope stack is consistent after the rewriting.
3513 
3514       if Present (Identifier (N)) then
3515          Set_Identifier (Core_Loop, Relocate_Node (Identifier (N)));
3516       end if;
3517 
3518       Rewrite (N, Core_Loop);
3519       Analyze (N);
3520    end Expand_Iterator_Loop_Over_Array;
3521 
3522    -----------------------------------------
3523    -- Expand_Iterator_Loop_Over_Container --
3524    -----------------------------------------
3525 
3526    --  For a 'for ... in' loop, such as:
3527 
3528    --      for Cursor in Iterator_Function (...) loop
3529    --          ...
3530    --      end loop;
3531 
3532    --  we generate:
3533 
3534    --    Iter : Iterator_Type := Iterator_Function (...);
3535    --    Cursor : Cursor_type := First (Iter); -- or Last for "reverse"
3536    --    while Has_Element (Cursor) loop
3537    --       ...
3538    --
3539    --       Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3540    --    end loop;
3541 
3542    --  For a 'for ... of' loop, such as:
3543 
3544    --      for X of Container loop
3545    --          ...
3546    --      end loop;
3547 
3548    --  the RM implies the generation of:
3549 
3550    --    Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator
3551    --    Cursor : Cursor_Type := First (Iter); -- or Last for "reverse"
3552    --    while Has_Element (Cursor) loop
3553    --       declare
3554    --          X : Element_Type renames Element (Cursor).Element.all;
3555    --          --  or Constant_Element
3556    --       begin
3557    --          ...
3558    --       end;
3559    --       Cursor := Iter.Next (Cursor); -- or Prev for "reverse"
3560    --    end loop;
3561 
3562    --  In the general case, we do what the RM says. However, the operations
3563    --  Element and Iter.Next are slow, which is bad inside a loop, because they
3564    --  involve dispatching via interfaces, secondary stack manipulation,
3565    --  Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the
3566    --  predefined containers, we use an equivalent but optimized expansion.
3567 
3568    --  In the optimized case, we make use of these:
3569 
3570    --     procedure Next (Position : in out Cursor); -- instead of Iter.Next
3571 
3572    --     function Pseudo_Reference
3573    --       (Container : aliased Vector'Class) return Reference_Control_Type;
3574 
3575    --     type Element_Access is access all Element_Type;
3576 
3577    --     function Get_Element_Access
3578    --       (Position : Cursor) return not null Element_Access;
3579 
3580    --  Next is declared in the visible part of the container packages.
3581    --  The other three are added in the private part. (We're not supposed to
3582    --  pollute the namespace for clients. The compiler has no trouble breaking
3583    --  privacy to call things in the private part of an instance.)
3584 
3585    --  Source:
3586 
3587    --      for X of My_Vector loop
3588    --          X.Count := X.Count + 1;
3589    --          ...
3590    --      end loop;
3591 
3592    --  The compiler will generate:
3593 
3594    --      Iter : Reversible_Iterator'Class := Iterate (My_Vector);
3595    --      --  Reversible_Iterator is an interface. Iterate is the
3596    --      --  Default_Iterator aspect of Vector. This increments Lock,
3597    --      --  disallowing tampering with cursors. Unfortunately, it does not
3598    --      --  increment Busy. The result of Iterate is Limited_Controlled;
3599    --      --  finalization will decrement Lock.  This is a build-in-place
3600    --      --  dispatching call to Iterate.
3601 
3602    --      Cur : Cursor := First (Iter); -- or Last
3603    --      --  Dispatching call via interface.
3604 
3605    --      Control : Reference_Control_Type := Pseudo_Reference (My_Vector);
3606    --      --  Pseudo_Reference increments Busy, to detect tampering with
3607    --      --  elements, as required by RM. Also redundantly increment
3608    --      --  Lock. Finalization of Control will decrement both Busy and
3609    --      --  Lock. Pseudo_Reference returns a record containing a pointer to
3610    --      --  My_Vector, used by Finalize.
3611    --      --
3612    --      --  Control is not used below, except to finalize it -- it's purely
3613    --      --  an RAII thing. This is needed because we are eliminating the
3614    --      --  call to Reference within the loop.
3615 
3616    --      while Has_Element (Cur) loop
3617    --          declare
3618    --              X : My_Element renames Get_Element_Access (Cur).all;
3619    --              --  Get_Element_Access returns a pointer to the element
3620    --              --  designated by Cur. No dispatching here, and no horsing
3621    --              --  around with access discriminants. This is instead of the
3622    --              --  existing
3623    --              --
3624    --              --    X : My_Element renames Reference (Cur).Element.all;
3625    --              --
3626    --              --  which creates a controlled object.
3627    --          begin
3628    --              --  Any attempt to tamper with My_Vector here in the loop
3629    --              --  will correctly raise Program_Error, because of the
3630    --              --  Control.
3631    --
3632    --              X.Count := X.Count + 1;
3633    --              ...
3634    --
3635    --              Next (Cur); -- or Prev
3636    --              --  This is instead of "Cur := Next (Iter, Cur);"
3637    --          end;
3638    --          --  No finalization here
3639    --      end loop;
3640    --      Finalize Iter and Control here, decrementing Lock twice and Busy
3641    --      once.
3642 
3643    --  This optimization makes "for ... of" loops over 30 times faster in cases
3644    --  measured.
3645 
3646    procedure Expand_Iterator_Loop_Over_Container
3647      (N             : Node_Id;
3648       Isc           : Node_Id;
3649       I_Spec        : Node_Id;
3650       Container     : Node_Id;
3651       Container_Typ : Entity_Id)
3652    is
3653       Id       : constant Entity_Id   := Defining_Identifier (I_Spec);
3654       Elem_Typ : constant Entity_Id   := Etype (Id);
3655       Id_Kind  : constant Entity_Kind := Ekind (Id);
3656       Loc      : constant Source_Ptr  := Sloc (N);
3657       Stats    : constant List_Id     := Statements (N);
3658 
3659       Cursor    : Entity_Id;
3660       Decl      : Node_Id;
3661       Iter_Type : Entity_Id;
3662       Iterator  : Entity_Id;
3663       Name_Init : Name_Id;
3664       Name_Step : Name_Id;
3665       New_Loop  : Node_Id;
3666 
3667       Fast_Element_Access_Op : Entity_Id := Empty;
3668       Fast_Step_Op           : Entity_Id := Empty;
3669       --  Only for optimized version of "for ... of"
3670 
3671       Iter_Pack : Entity_Id;
3672       --  The package in which the iterator interface is instantiated. This is
3673       --  typically an instance within the container package.
3674 
3675       Pack : Entity_Id;
3676       --  The package in which the container type is declared
3677 
3678    begin
3679       --  Determine the advancement and initialization steps for the cursor.
3680       --  Analysis of the expanded loop will verify that the container has a
3681       --  reverse iterator.
3682 
3683       if Reverse_Present (I_Spec) then
3684          Name_Init := Name_Last;
3685          Name_Step := Name_Previous;
3686       else
3687          Name_Init := Name_First;
3688          Name_Step := Name_Next;
3689       end if;
3690 
3691       --  The type of the iterator is the return type of the Iterate function
3692       --  used. For the "of" form this is the default iterator for the type,
3693       --  otherwise it is the type of the explicit function used in the
3694       --  iterator specification. The most common case will be an Iterate
3695       --  function in the container package.
3696 
3697       --  The Iterator type is declared in an instance within the container
3698       --  package itself, for example:
3699 
3700       --    package Vector_Iterator_Interfaces is new
3701       --      Ada.Iterator_Interfaces (Cursor, Has_Element);
3702 
3703       --  If the container type is a derived type, the cursor type is found in
3704       --  the package of the ultimate ancestor type.
3705 
3706       if Is_Derived_Type (Container_Typ) then
3707          Pack := Scope (Root_Type (Container_Typ));
3708       else
3709          Pack := Scope (Container_Typ);
3710       end if;
3711 
3712       if Of_Present (I_Spec) then
3713          Handle_Of : declare
3714             Container_Arg : Node_Id;
3715 
3716             function Get_Default_Iterator
3717               (T : Entity_Id) return Entity_Id;
3718             --  If the container is a derived type, the aspect holds the parent
3719             --  operation. The required one is a primitive of the derived type
3720             --  and is either inherited or overridden. Also sets Container_Arg.
3721 
3722             --------------------------
3723             -- Get_Default_Iterator --
3724             --------------------------
3725 
3726             function Get_Default_Iterator
3727               (T : Entity_Id) return Entity_Id
3728             is
3729                Iter : constant Entity_Id :=
3730                  Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator));
3731                Prim : Elmt_Id;
3732                Op   : Entity_Id;
3733 
3734             begin
3735                Container_Arg := New_Copy_Tree (Container);
3736 
3737                --  A previous version of GNAT allowed indexing aspects to
3738                --  be redefined on derived container types, while the
3739                --  default iterator was inherited from the parent type.
3740                --  This non-standard extension is preserved temporarily for
3741                --  use by the modelling project under debug flag d.X.
3742 
3743                if Debug_Flag_Dot_XX then
3744                   if Base_Type (Etype (Container)) /=
3745                      Base_Type (Etype (First_Formal (Iter)))
3746                   then
3747                      Container_Arg :=
3748                        Make_Type_Conversion (Loc,
3749                          Subtype_Mark =>
3750                            New_Occurrence_Of
3751                              (Etype (First_Formal (Iter)), Loc),
3752                          Expression   => Container_Arg);
3753                   end if;
3754 
3755                   return Iter;
3756 
3757                elsif Is_Derived_Type (T) then
3758 
3759                   --  The default iterator must be a primitive operation of the
3760                   --  type, at the same dispatch slot position.
3761 
3762                   Prim := First_Elmt (Primitive_Operations (T));
3763                   while Present (Prim) loop
3764                      Op := Node (Prim);
3765 
3766                      if Chars (Op) = Chars (Iter)
3767                        and then DT_Position (Op) = DT_Position (Iter)
3768                      then
3769                         return Op;
3770                      end if;
3771 
3772                      Next_Elmt (Prim);
3773                   end loop;
3774 
3775                   --  Default iterator must exist
3776 
3777                   pragma Assert (False);
3778 
3779                --  Otherwise not a derived type
3780 
3781                else
3782                   return Iter;
3783                end if;
3784             end Get_Default_Iterator;
3785 
3786             --  Local variables
3787 
3788             Default_Iter : Entity_Id;
3789             Ent          : Entity_Id;
3790 
3791             Reference_Control_Type : Entity_Id := Empty;
3792             Pseudo_Reference       : Entity_Id := Empty;
3793 
3794          --  Start of processing for Handle_Of
3795 
3796          begin
3797             if Is_Class_Wide_Type (Container_Typ) then
3798                Default_Iter :=
3799                  Get_Default_Iterator (Etype (Base_Type (Container_Typ)));
3800             else
3801                Default_Iter := Get_Default_Iterator (Etype (Container));
3802             end if;
3803 
3804             Cursor := Make_Temporary (Loc, 'C');
3805 
3806             --  For a container element iterator, the iterator type is obtained
3807             --  from the corresponding aspect, whose return type is descended
3808             --  from the corresponding interface type in some instance of
3809             --  Ada.Iterator_Interfaces. The actuals of that instantiation
3810             --  are Cursor and Has_Element.
3811 
3812             Iter_Type := Etype (Default_Iter);
3813 
3814             --  The iterator type, which is a class-wide type, may itself be
3815             --  derived locally, so the desired instantiation is the scope of
3816             --  the root type of the iterator type.
3817 
3818             Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
3819 
3820             --  Find declarations needed for "for ... of" optimization
3821 
3822             Ent := First_Entity (Pack);
3823             while Present (Ent) loop
3824                if Chars (Ent) = Name_Get_Element_Access then
3825                   Fast_Element_Access_Op := Ent;
3826 
3827                elsif Chars (Ent) = Name_Step
3828                  and then Ekind (Ent) = E_Procedure
3829                then
3830                   Fast_Step_Op := Ent;
3831 
3832                elsif Chars (Ent) = Name_Reference_Control_Type then
3833                   Reference_Control_Type := Ent;
3834 
3835                elsif Chars (Ent) = Name_Pseudo_Reference then
3836                   Pseudo_Reference := Ent;
3837                end if;
3838 
3839                Next_Entity (Ent);
3840             end loop;
3841 
3842             if Present (Reference_Control_Type)
3843               and then Present (Pseudo_Reference)
3844             then
3845                Insert_Action (N,
3846                  Make_Object_Declaration (Loc,
3847                    Defining_Identifier => Make_Temporary (Loc, 'D'),
3848                    Object_Definition   =>
3849                      New_Occurrence_Of (Reference_Control_Type, Loc),
3850                    Expression          =>
3851                      Make_Function_Call (Loc,
3852                        Name                   =>
3853                          New_Occurrence_Of (Pseudo_Reference, Loc),
3854                        Parameter_Associations =>
3855                          New_List (New_Copy_Tree (Container_Arg)))));
3856             end if;
3857 
3858             --  Rewrite domain of iteration as a call to the default iterator
3859             --  for the container type. The formal may be an access parameter
3860             --  in which case we must build a reference to the container.
3861 
3862             declare
3863                Arg : Node_Id;
3864             begin
3865                if Is_Access_Type (Etype (First_Entity (Default_Iter))) then
3866                   Arg :=
3867                     Make_Attribute_Reference (Loc,
3868                       Prefix         => Container_Arg,
3869                       Attribute_Name => Name_Unrestricted_Access);
3870                else
3871                   Arg := Container_Arg;
3872                end if;
3873 
3874                Rewrite (Name (I_Spec),
3875                  Make_Function_Call (Loc,
3876                    Name                   =>
3877                      New_Occurrence_Of (Default_Iter, Loc),
3878                    Parameter_Associations => New_List (Arg)));
3879             end;
3880 
3881             Analyze_And_Resolve (Name (I_Spec));
3882 
3883             --  Find cursor type in proper iterator package, which is an
3884             --  instantiation of Iterator_Interfaces.
3885 
3886             Ent := First_Entity (Iter_Pack);
3887             while Present (Ent) loop
3888                if Chars (Ent) = Name_Cursor then
3889                   Set_Etype (Cursor, Etype (Ent));
3890                   exit;
3891                end if;
3892 
3893                Next_Entity (Ent);
3894             end loop;
3895 
3896             if Present (Fast_Element_Access_Op) then
3897                Decl :=
3898                  Make_Object_Renaming_Declaration (Loc,
3899                    Defining_Identifier => Id,
3900                    Subtype_Mark        =>
3901                      New_Occurrence_Of (Elem_Typ, Loc),
3902                    Name                =>
3903                      Make_Explicit_Dereference (Loc,
3904                        Prefix =>
3905                          Make_Function_Call (Loc,
3906                            Name                   =>
3907                              New_Occurrence_Of (Fast_Element_Access_Op, Loc),
3908                            Parameter_Associations =>
3909                              New_List (New_Occurrence_Of (Cursor, Loc)))));
3910 
3911             else
3912                Decl :=
3913                  Make_Object_Renaming_Declaration (Loc,
3914                    Defining_Identifier => Id,
3915                    Subtype_Mark        =>
3916                      New_Occurrence_Of (Elem_Typ, Loc),
3917                    Name                =>
3918                      Make_Indexed_Component (Loc,
3919                        Prefix      => Relocate_Node (Container_Arg),
3920                        Expressions =>
3921                          New_List (New_Occurrence_Of (Cursor, Loc))));
3922             end if;
3923 
3924             --  The defining identifier in the iterator is user-visible and
3925             --  must be visible in the debugger.
3926 
3927             Set_Debug_Info_Needed (Id);
3928 
3929             --  If the container does not have a variable indexing aspect,
3930             --  the element is a constant in the loop. The container itself
3931             --  may be constant, in which case the element is a constant as
3932             --  well. The container has been rewritten as a call to Iterate,
3933             --  so examine original node.
3934 
3935             if No (Find_Value_Of_Aspect
3936                      (Container_Typ, Aspect_Variable_Indexing))
3937               or else not Is_Variable (Original_Node (Container))
3938             then
3939                Set_Ekind (Id, E_Constant);
3940             end if;
3941 
3942             Prepend_To (Stats, Decl);
3943          end Handle_Of;
3944 
3945       --  X in Iterate (S) : type of iterator is type of explicitly given
3946       --  Iterate function, and the loop variable is the cursor. It will be
3947       --  assigned in the loop and must be a variable.
3948 
3949       else
3950          Iter_Type := Etype (Name (I_Spec));
3951 
3952          --  The iterator type, which is a class-wide type, may itself be
3953          --  derived locally, so the desired instantiation is the scope of
3954          --  the root type of the iterator type, as in the "of" case.
3955 
3956          Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
3957          Cursor := Id;
3958       end if;
3959 
3960       Iterator := Make_Temporary (Loc, 'I');
3961 
3962       --  For both iterator forms, add a call to the step operation to advance
3963       --  the cursor. Generate:
3964 
3965       --     Cursor := Iterator.Next (Cursor);
3966 
3967       --   or else
3968 
3969       --     Cursor := Next (Cursor);
3970 
3971       if Present (Fast_Element_Access_Op) and then Present (Fast_Step_Op) then
3972          declare
3973             Curs_Name : constant Node_Id := New_Occurrence_Of (Cursor, Loc);
3974             Step_Call : Node_Id;
3975 
3976          begin
3977             Step_Call :=
3978               Make_Procedure_Call_Statement (Loc,
3979                 Name                   =>
3980                   New_Occurrence_Of (Fast_Step_Op, Loc),
3981                 Parameter_Associations => New_List (Curs_Name));
3982 
3983             Append_To (Stats, Step_Call);
3984             Set_Assignment_OK (Curs_Name);
3985          end;
3986 
3987       else
3988          declare
3989             Rhs : Node_Id;
3990 
3991          begin
3992             Rhs :=
3993               Make_Function_Call (Loc,
3994                 Name                   =>
3995                   Make_Selected_Component (Loc,
3996                     Prefix        => New_Occurrence_Of (Iterator, Loc),
3997                     Selector_Name => Make_Identifier (Loc, Name_Step)),
3998                 Parameter_Associations => New_List (
3999                    New_Occurrence_Of (Cursor, Loc)));
4000 
4001             Append_To (Stats,
4002               Make_Assignment_Statement (Loc,
4003                  Name       => New_Occurrence_Of (Cursor, Loc),
4004                  Expression => Rhs));
4005             Set_Assignment_OK (Name (Last (Stats)));
4006          end;
4007       end if;
4008 
4009       --  Generate:
4010       --    while Has_Element (Cursor) loop
4011       --       <Stats>
4012       --    end loop;
4013 
4014       --   Has_Element is the second actual in the iterator package
4015 
4016       New_Loop :=
4017         Make_Loop_Statement (Loc,
4018           Iteration_Scheme =>
4019             Make_Iteration_Scheme (Loc,
4020               Condition =>
4021                 Make_Function_Call (Loc,
4022                   Name                   =>
4023                     New_Occurrence_Of
4024                       (Next_Entity (First_Entity (Iter_Pack)), Loc),
4025                   Parameter_Associations => New_List (
4026                     New_Occurrence_Of (Cursor, Loc)))),
4027 
4028           Statements => Stats,
4029           End_Label  => Empty);
4030 
4031       --  If present, preserve identifier of loop, which can be used in an exit
4032       --  statement in the body.
4033 
4034       if Present (Identifier (N)) then
4035          Set_Identifier (New_Loop, Relocate_Node (Identifier (N)));
4036       end if;
4037 
4038       --  Create the declarations for Iterator and cursor and insert them
4039       --  before the source loop. Given that the domain of iteration is already
4040       --  an entity, the iterator is just a renaming of that entity. Possible
4041       --  optimization ???
4042 
4043       Insert_Action (N,
4044         Make_Object_Renaming_Declaration (Loc,
4045           Defining_Identifier => Iterator,
4046           Subtype_Mark        => New_Occurrence_Of (Iter_Type, Loc),
4047           Name                => Relocate_Node (Name (I_Spec))));
4048 
4049       --  Create declaration for cursor
4050 
4051       declare
4052          Cursor_Decl : constant Node_Id :=
4053                          Make_Object_Declaration (Loc,
4054                            Defining_Identifier => Cursor,
4055                            Object_Definition   =>
4056                              New_Occurrence_Of (Etype (Cursor), Loc),
4057                            Expression          =>
4058                              Make_Selected_Component (Loc,
4059                                Prefix        =>
4060                                  New_Occurrence_Of (Iterator, Loc),
4061                                Selector_Name =>
4062                                  Make_Identifier (Loc, Name_Init)));
4063 
4064       begin
4065          --  The cursor is only modified in expanded code, so it appears
4066          --  as unassigned to the warning machinery. We must suppress this
4067          --  spurious warning explicitly. The cursor's kind is that of the
4068          --  original loop parameter (it is a constant if the domain of
4069          --  iteration is constant).
4070 
4071          Set_Warnings_Off (Cursor);
4072          Set_Assignment_OK (Cursor_Decl);
4073 
4074          Insert_Action (N, Cursor_Decl);
4075          Set_Ekind (Cursor, Id_Kind);
4076       end;
4077 
4078       --  If the range of iteration is given by a function call that returns
4079       --  a container, the finalization actions have been saved in the
4080       --  Condition_Actions of the iterator. Insert them now at the head of
4081       --  the loop.
4082 
4083       if Present (Condition_Actions (Isc)) then
4084          Insert_List_Before (N, Condition_Actions (Isc));
4085       end if;
4086 
4087       Rewrite (N, New_Loop);
4088       Analyze (N);
4089    end Expand_Iterator_Loop_Over_Container;
4090 
4091    -----------------------------
4092    -- Expand_N_Loop_Statement --
4093    -----------------------------
4094 
4095    --  1. Remove null loop entirely
4096    --  2. Deal with while condition for C/Fortran boolean
4097    --  3. Deal with loops with a non-standard enumeration type range
4098    --  4. Deal with while loops where Condition_Actions is set
4099    --  5. Deal with loops over predicated subtypes
4100    --  6. Deal with loops with iterators over arrays and containers
4101    --  7. Insert polling call if required
4102 
4103    procedure Expand_N_Loop_Statement (N : Node_Id) is
4104       Loc    : constant Source_Ptr := Sloc (N);
4105       Scheme : constant Node_Id    := Iteration_Scheme (N);
4106       Stmt   : Node_Id;
4107 
4108    begin
4109       --  Delete null loop
4110 
4111       if Is_Null_Loop (N) then
4112          Rewrite (N, Make_Null_Statement (Loc));
4113          return;
4114       end if;
4115 
4116       --  Deal with condition for C/Fortran Boolean
4117 
4118       if Present (Scheme) then
4119          Adjust_Condition (Condition (Scheme));
4120       end if;
4121 
4122       --  Generate polling call
4123 
4124       if Is_Non_Empty_List (Statements (N)) then
4125          Generate_Poll_Call (First (Statements (N)));
4126       end if;
4127 
4128       --  Nothing more to do for plain loop with no iteration scheme
4129 
4130       if No (Scheme) then
4131          null;
4132 
4133       --  Case of for loop (Loop_Parameter_Specification present)
4134 
4135       --  Note: we do not have to worry about validity checking of the for loop
4136       --  range bounds here, since they were frozen with constant declarations
4137       --  and it is during that process that the validity checking is done.
4138 
4139       elsif Present (Loop_Parameter_Specification (Scheme)) then
4140          declare
4141             LPS     : constant Node_Id   :=
4142                         Loop_Parameter_Specification (Scheme);
4143             Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
4144             Ltype   : constant Entity_Id := Etype (Loop_Id);
4145             Btype   : constant Entity_Id := Base_Type (Ltype);
4146             Expr    : Node_Id;
4147             Decls   : List_Id;
4148             New_Id  : Entity_Id;
4149 
4150          begin
4151             --  Deal with loop over predicates
4152 
4153             if Is_Discrete_Type (Ltype)
4154               and then Present (Predicate_Function (Ltype))
4155             then
4156                Expand_Predicated_Loop (N);
4157 
4158             --  Handle the case where we have a for loop with the range type
4159             --  being an enumeration type with non-standard representation.
4160             --  In this case we expand:
4161 
4162             --    for x in [reverse] a .. b loop
4163             --       ...
4164             --    end loop;
4165 
4166             --  to
4167 
4168             --    for xP in [reverse] integer
4169             --      range etype'Pos (a) .. etype'Pos (b)
4170             --    loop
4171             --       declare
4172             --          x : constant etype := Pos_To_Rep (xP);
4173             --       begin
4174             --          ...
4175             --       end;
4176             --    end loop;
4177 
4178             elsif Is_Enumeration_Type (Btype)
4179               and then Present (Enum_Pos_To_Rep (Btype))
4180             then
4181                New_Id :=
4182                  Make_Defining_Identifier (Loc,
4183                    Chars => New_External_Name (Chars (Loop_Id), 'P'));
4184 
4185                --  If the type has a contiguous representation, successive
4186                --  values can be generated as offsets from the first literal.
4187 
4188                if Has_Contiguous_Rep (Btype) then
4189                   Expr :=
4190                      Unchecked_Convert_To (Btype,
4191                        Make_Op_Add (Loc,
4192                          Left_Opnd =>
4193                             Make_Integer_Literal (Loc,
4194                               Enumeration_Rep (First_Literal (Btype))),
4195                          Right_Opnd => New_Occurrence_Of (New_Id, Loc)));
4196                else
4197                   --  Use the constructed array Enum_Pos_To_Rep
4198 
4199                   Expr :=
4200                     Make_Indexed_Component (Loc,
4201                       Prefix      =>
4202                         New_Occurrence_Of (Enum_Pos_To_Rep (Btype), Loc),
4203                       Expressions =>
4204                         New_List (New_Occurrence_Of (New_Id, Loc)));
4205                end if;
4206 
4207                --  Build declaration for loop identifier
4208 
4209                Decls :=
4210                  New_List (
4211                    Make_Object_Declaration (Loc,
4212                      Defining_Identifier => Loop_Id,
4213                      Constant_Present    => True,
4214                      Object_Definition   => New_Occurrence_Of (Ltype, Loc),
4215                      Expression          => Expr));
4216 
4217                Rewrite (N,
4218                  Make_Loop_Statement (Loc,
4219                    Identifier => Identifier (N),
4220 
4221                    Iteration_Scheme =>
4222                      Make_Iteration_Scheme (Loc,
4223                        Loop_Parameter_Specification =>
4224                          Make_Loop_Parameter_Specification (Loc,
4225                            Defining_Identifier => New_Id,
4226                            Reverse_Present => Reverse_Present (LPS),
4227 
4228                            Discrete_Subtype_Definition =>
4229                              Make_Subtype_Indication (Loc,
4230 
4231                                Subtype_Mark =>
4232                                  New_Occurrence_Of (Standard_Natural, Loc),
4233 
4234                                Constraint =>
4235                                  Make_Range_Constraint (Loc,
4236                                    Range_Expression =>
4237                                      Make_Range (Loc,
4238 
4239                                        Low_Bound =>
4240                                          Make_Attribute_Reference (Loc,
4241                                            Prefix =>
4242                                              New_Occurrence_Of (Btype, Loc),
4243 
4244                                            Attribute_Name => Name_Pos,
4245 
4246                                            Expressions => New_List (
4247                                              Relocate_Node
4248                                                (Type_Low_Bound (Ltype)))),
4249 
4250                                        High_Bound =>
4251                                          Make_Attribute_Reference (Loc,
4252                                            Prefix =>
4253                                              New_Occurrence_Of (Btype, Loc),
4254 
4255                                            Attribute_Name => Name_Pos,
4256 
4257                                            Expressions => New_List (
4258                                              Relocate_Node
4259                                                (Type_High_Bound
4260                                                   (Ltype))))))))),
4261 
4262                    Statements => New_List (
4263                      Make_Block_Statement (Loc,
4264                        Declarations => Decls,
4265                        Handled_Statement_Sequence =>
4266                          Make_Handled_Sequence_Of_Statements (Loc,
4267                            Statements => Statements (N)))),
4268 
4269                    End_Label => End_Label (N)));
4270 
4271                --  The loop parameter's entity must be removed from the loop
4272                --  scope's entity list and rendered invisible, since it will
4273                --  now be located in the new block scope. Any other entities
4274                --  already associated with the loop scope, such as the loop
4275                --  parameter's subtype, will remain there.
4276 
4277                --  In an element loop, the loop will contain a declaration for
4278                --  a cursor variable; otherwise the loop id is the first entity
4279                --  in the scope constructed for the loop.
4280 
4281                if Comes_From_Source (Loop_Id) then
4282                   pragma Assert (First_Entity (Scope (Loop_Id)) = Loop_Id);
4283                   null;
4284                end if;
4285 
4286                Set_First_Entity (Scope (Loop_Id), Next_Entity (Loop_Id));
4287                Remove_Homonym (Loop_Id);
4288 
4289                if Last_Entity (Scope (Loop_Id)) = Loop_Id then
4290                   Set_Last_Entity (Scope (Loop_Id), Empty);
4291                end if;
4292 
4293                Analyze (N);
4294 
4295             --  Nothing to do with other cases of for loops
4296 
4297             else
4298                null;
4299             end if;
4300          end;
4301 
4302       --  Second case, if we have a while loop with Condition_Actions set, then
4303       --  we change it into a plain loop:
4304 
4305       --    while C loop
4306       --       ...
4307       --    end loop;
4308 
4309       --  changed to:
4310 
4311       --    loop
4312       --       <<condition actions>>
4313       --       exit when not C;
4314       --       ...
4315       --    end loop
4316 
4317       elsif Present (Scheme)
4318         and then Present (Condition_Actions (Scheme))
4319         and then Present (Condition (Scheme))
4320       then
4321          declare
4322             ES : Node_Id;
4323 
4324          begin
4325             ES :=
4326               Make_Exit_Statement (Sloc (Condition (Scheme)),
4327                 Condition =>
4328                   Make_Op_Not (Sloc (Condition (Scheme)),
4329                     Right_Opnd => Condition (Scheme)));
4330 
4331             Prepend (ES, Statements (N));
4332             Insert_List_Before (ES, Condition_Actions (Scheme));
4333 
4334             --  This is not an implicit loop, since it is generated in response
4335             --  to the loop statement being processed. If this is itself
4336             --  implicit, the restriction has already been checked. If not,
4337             --  it is an explicit loop.
4338 
4339             Rewrite (N,
4340               Make_Loop_Statement (Sloc (N),
4341                 Identifier => Identifier (N),
4342                 Statements => Statements (N),
4343                 End_Label  => End_Label  (N)));
4344 
4345             Analyze (N);
4346          end;
4347 
4348       --  Here to deal with iterator case
4349 
4350       elsif Present (Scheme)
4351         and then Present (Iterator_Specification (Scheme))
4352       then
4353          Expand_Iterator_Loop (N);
4354 
4355          --  An iterator loop may generate renaming declarations for elements
4356          --  that require debug information. This is the case in particular
4357          --  with element iterators, where debug information must be generated
4358          --  for the temporary that holds the element value. These temporaries
4359          --  are created within a transient block whose local declarations are
4360          --  transferred to the loop, which now has nontrivial local objects.
4361 
4362          if Nkind (N) = N_Loop_Statement
4363            and then Present (Identifier (N))
4364          then
4365             Qualify_Entity_Names (N);
4366          end if;
4367       end if;
4368 
4369       --  When the iteration scheme mentiones attribute 'Loop_Entry, the loop
4370       --  is transformed into a conditional block where the original loop is
4371       --  the sole statement. Inspect the statements of the nested loop for
4372       --  controlled objects.
4373 
4374       Stmt := N;
4375 
4376       if Subject_To_Loop_Entry_Attributes (Stmt) then
4377          Stmt := Find_Loop_In_Conditional_Block (Stmt);
4378       end if;
4379 
4380       Process_Statements_For_Controlled_Objects (Stmt);
4381    end Expand_N_Loop_Statement;
4382 
4383    ----------------------------
4384    -- Expand_Predicated_Loop --
4385    ----------------------------
4386 
4387    --  Note: the expander can handle generation of loops over predicated
4388    --  subtypes for both the dynamic and static cases. Depending on what
4389    --  we decide is allowed in Ada 2012 mode and/or extensions allowed
4390    --  mode, the semantic analyzer may disallow one or both forms.
4391 
4392    procedure Expand_Predicated_Loop (N : Node_Id) is
4393       Loc     : constant Source_Ptr := Sloc (N);
4394       Isc     : constant Node_Id    := Iteration_Scheme (N);
4395       LPS     : constant Node_Id    := Loop_Parameter_Specification (Isc);
4396       Loop_Id : constant Entity_Id  := Defining_Identifier (LPS);
4397       Ltype   : constant Entity_Id  := Etype (Loop_Id);
4398       Stat    : constant List_Id    := Static_Discrete_Predicate (Ltype);
4399       Stmts   : constant List_Id    := Statements (N);
4400 
4401    begin
4402       --  Case of iteration over non-static predicate, should not be possible
4403       --  since this is not allowed by the semantics and should have been
4404       --  caught during analysis of the loop statement.
4405 
4406       if No (Stat) then
4407          raise Program_Error;
4408 
4409       --  If the predicate list is empty, that corresponds to a predicate of
4410       --  False, in which case the loop won't run at all, and we rewrite the
4411       --  entire loop as a null statement.
4412 
4413       elsif Is_Empty_List (Stat) then
4414          Rewrite (N, Make_Null_Statement (Loc));
4415          Analyze (N);
4416 
4417       --  For expansion over a static predicate we generate the following
4418 
4419       --     declare
4420       --        J : Ltype := min-val;
4421       --     begin
4422       --        loop
4423       --           body
4424       --           case J is
4425       --              when endpoint => J := startpoint;
4426       --              when endpoint => J := startpoint;
4427       --              ...
4428       --              when max-val  => exit;
4429       --              when others   => J := Lval'Succ (J);
4430       --           end case;
4431       --        end loop;
4432       --     end;
4433 
4434       --  with min-val replaced by max-val and Succ replaced by Pred if the
4435       --  loop parameter specification carries a Reverse indicator.
4436 
4437       --  To make this a little clearer, let's take a specific example:
4438 
4439       --        type Int is range 1 .. 10;
4440       --        subtype StaticP is Int with
4441       --          predicate => StaticP in 3 | 10 | 5 .. 7;
4442       --          ...
4443       --        for L in StaticP loop
4444       --           Put_Line ("static:" & J'Img);
4445       --        end loop;
4446 
4447       --  In this case, the loop is transformed into
4448 
4449       --     begin
4450       --        J : L := 3;
4451       --        loop
4452       --           body
4453       --           case J is
4454       --              when 3  => J := 5;
4455       --              when 7  => J := 10;
4456       --              when 10 => exit;
4457       --              when others  => J := L'Succ (J);
4458       --           end case;
4459       --        end loop;
4460       --     end;
4461 
4462       else
4463          Static_Predicate : declare
4464             S    : Node_Id;
4465             D    : Node_Id;
4466             P    : Node_Id;
4467             Alts : List_Id;
4468             Cstm : Node_Id;
4469 
4470             function Lo_Val (N : Node_Id) return Node_Id;
4471             --  Given static expression or static range, returns an identifier
4472             --  whose value is the low bound of the expression value or range.
4473 
4474             function Hi_Val (N : Node_Id) return Node_Id;
4475             --  Given static expression or static range, returns an identifier
4476             --  whose value is the high bound of the expression value or range.
4477 
4478             ------------
4479             -- Hi_Val --
4480             ------------
4481 
4482             function Hi_Val (N : Node_Id) return Node_Id is
4483             begin
4484                if Is_OK_Static_Expression (N) then
4485                   return New_Copy (N);
4486                else
4487                   pragma Assert (Nkind (N) = N_Range);
4488                   return New_Copy (High_Bound (N));
4489                end if;
4490             end Hi_Val;
4491 
4492             ------------
4493             -- Lo_Val --
4494             ------------
4495 
4496             function Lo_Val (N : Node_Id) return Node_Id is
4497             begin
4498                if Is_OK_Static_Expression (N) then
4499                   return New_Copy (N);
4500                else
4501                   pragma Assert (Nkind (N) = N_Range);
4502                   return New_Copy (Low_Bound (N));
4503                end if;
4504             end Lo_Val;
4505 
4506          --  Start of processing for Static_Predicate
4507 
4508          begin
4509             --  Convert loop identifier to normal variable and reanalyze it so
4510             --  that this conversion works. We have to use the same defining
4511             --  identifier, since there may be references in the loop body.
4512 
4513             Set_Analyzed (Loop_Id, False);
4514             Set_Ekind    (Loop_Id, E_Variable);
4515 
4516             --  In most loops the loop variable is assigned in various
4517             --  alternatives in the body. However, in the rare case when
4518             --  the range specifies a single element, the loop variable
4519             --  may trigger a spurious warning that is could be constant.
4520             --  This warning might as well be suppressed.
4521 
4522             Set_Warnings_Off (Loop_Id);
4523 
4524             --  Loop to create branches of case statement
4525 
4526             Alts := New_List;
4527 
4528             if Reverse_Present (LPS) then
4529 
4530                --  Initial value is largest value in predicate.
4531 
4532                D :=
4533                  Make_Object_Declaration (Loc,
4534                    Defining_Identifier => Loop_Id,
4535                    Object_Definition   => New_Occurrence_Of (Ltype, Loc),
4536                    Expression          => Hi_Val (Last (Stat)));
4537 
4538                P := Last (Stat);
4539                while Present (P) loop
4540                   if No (Prev (P)) then
4541                      S := Make_Exit_Statement (Loc);
4542                   else
4543                      S :=
4544                        Make_Assignment_Statement (Loc,
4545                          Name       => New_Occurrence_Of (Loop_Id, Loc),
4546                          Expression => Hi_Val (Prev (P)));
4547                      Set_Suppress_Assignment_Checks (S);
4548                   end if;
4549 
4550                   Append_To (Alts,
4551                     Make_Case_Statement_Alternative (Loc,
4552                       Statements       => New_List (S),
4553                       Discrete_Choices => New_List (Lo_Val (P))));
4554 
4555                   Prev (P);
4556                end loop;
4557 
4558             else
4559 
4560                --  Initial value is smallest value in predicate.
4561 
4562                D :=
4563                  Make_Object_Declaration (Loc,
4564                    Defining_Identifier => Loop_Id,
4565                    Object_Definition   => New_Occurrence_Of (Ltype, Loc),
4566                    Expression          => Lo_Val (First (Stat)));
4567 
4568                P := First (Stat);
4569                while Present (P) loop
4570                   if No (Next (P)) then
4571                      S := Make_Exit_Statement (Loc);
4572                   else
4573                      S :=
4574                        Make_Assignment_Statement (Loc,
4575                          Name       => New_Occurrence_Of (Loop_Id, Loc),
4576                          Expression => Lo_Val (Next (P)));
4577                      Set_Suppress_Assignment_Checks (S);
4578                   end if;
4579 
4580                   Append_To (Alts,
4581                     Make_Case_Statement_Alternative (Loc,
4582                       Statements       => New_List (S),
4583                       Discrete_Choices => New_List (Hi_Val (P))));
4584 
4585                   Next (P);
4586                end loop;
4587             end if;
4588 
4589             --  Add others choice
4590 
4591             declare
4592                Name_Next : Name_Id;
4593 
4594             begin
4595                if Reverse_Present (LPS) then
4596                   Name_Next := Name_Pred;
4597                else
4598                   Name_Next := Name_Succ;
4599                end if;
4600 
4601                S :=
4602                   Make_Assignment_Statement (Loc,
4603                     Name       => New_Occurrence_Of (Loop_Id, Loc),
4604                     Expression =>
4605                       Make_Attribute_Reference (Loc,
4606                         Prefix => New_Occurrence_Of (Ltype, Loc),
4607                         Attribute_Name => Name_Next,
4608                         Expressions    => New_List (
4609                           New_Occurrence_Of (Loop_Id, Loc))));
4610                Set_Suppress_Assignment_Checks (S);
4611             end;
4612 
4613             Append_To (Alts,
4614               Make_Case_Statement_Alternative (Loc,
4615                 Discrete_Choices => New_List (Make_Others_Choice (Loc)),
4616                 Statements       => New_List (S)));
4617 
4618             --  Construct case statement and append to body statements
4619 
4620             Cstm :=
4621               Make_Case_Statement (Loc,
4622                 Expression   => New_Occurrence_Of (Loop_Id, Loc),
4623                 Alternatives => Alts);
4624             Append_To (Stmts, Cstm);
4625 
4626             --  Rewrite the loop
4627 
4628             Set_Suppress_Assignment_Checks (D);
4629 
4630             Rewrite (N,
4631               Make_Block_Statement (Loc,
4632                 Declarations               => New_List (D),
4633                 Handled_Statement_Sequence =>
4634                   Make_Handled_Sequence_Of_Statements (Loc,
4635                     Statements => New_List (
4636                       Make_Loop_Statement (Loc,
4637                         Statements => Stmts,
4638                         End_Label  => Empty)))));
4639 
4640             Analyze (N);
4641          end Static_Predicate;
4642       end if;
4643    end Expand_Predicated_Loop;
4644 
4645    ------------------------------
4646    -- Make_Tag_Ctrl_Assignment --
4647    ------------------------------
4648 
4649    function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is
4650       Asn : constant Node_Id    := Relocate_Node (N);
4651       L   : constant Node_Id    := Name (N);
4652       Loc : constant Source_Ptr := Sloc (N);
4653       Res : constant List_Id    := New_List;
4654       T   : constant Entity_Id  := Underlying_Type (Etype (L));
4655 
4656       Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T);
4657       Ctrl_Act : constant Boolean := Needs_Finalization (T)
4658                                        and then not No_Ctrl_Actions (N);
4659       Save_Tag : constant Boolean := Is_Tagged_Type (T)
4660                                        and then not Comp_Asn
4661                                        and then not No_Ctrl_Actions (N)
4662                                        and then Tagged_Type_Expansion;
4663       Tag_Id  : Entity_Id;
4664 
4665    begin
4666       --  Finalize the target of the assignment when controlled
4667 
4668       --  We have two exceptions here:
4669 
4670       --   1. If we are in an init proc since it is an initialization more
4671       --      than an assignment.
4672 
4673       --   2. If the left-hand side is a temporary that was not initialized
4674       --      (or the parent part of a temporary since it is the case in
4675       --      extension aggregates). Such a temporary does not come from
4676       --      source. We must examine the original node for the prefix, because
4677       --      it may be a component of an entry formal, in which case it has
4678       --      been rewritten and does not appear to come from source either.
4679 
4680       --  Case of init proc
4681 
4682       if not Ctrl_Act then
4683          null;
4684 
4685       --  The left hand side is an uninitialized temporary object
4686 
4687       elsif Nkind (L) = N_Type_Conversion
4688         and then Is_Entity_Name (Expression (L))
4689         and then Nkind (Parent (Entity (Expression (L)))) =
4690                                               N_Object_Declaration
4691         and then No_Initialization (Parent (Entity (Expression (L))))
4692       then
4693          null;
4694 
4695       else
4696          Append_To (Res,
4697            Make_Final_Call
4698              (Obj_Ref => Duplicate_Subexpr_No_Checks (L),
4699               Typ     => Etype (L)));
4700       end if;
4701 
4702       --  Save the Tag in a local variable Tag_Id
4703 
4704       if Save_Tag then
4705          Tag_Id := Make_Temporary (Loc, 'A');
4706 
4707          Append_To (Res,
4708            Make_Object_Declaration (Loc,
4709              Defining_Identifier => Tag_Id,
4710              Object_Definition   => New_Occurrence_Of (RTE (RE_Tag), Loc),
4711              Expression          =>
4712                Make_Selected_Component (Loc,
4713                  Prefix        => Duplicate_Subexpr_No_Checks (L),
4714                  Selector_Name =>
4715                    New_Occurrence_Of (First_Tag_Component (T), Loc))));
4716 
4717       --  Otherwise Tag_Id is not used
4718 
4719       else
4720          Tag_Id := Empty;
4721       end if;
4722 
4723       --  If the tagged type has a full rep clause, expand the assignment into
4724       --  component-wise assignments. Mark the node as unanalyzed in order to
4725       --  generate the proper code and propagate this scenario by setting a
4726       --  flag to avoid infinite recursion.
4727 
4728       if Comp_Asn then
4729          Set_Analyzed (Asn, False);
4730          Set_Componentwise_Assignment (Asn, True);
4731       end if;
4732 
4733       Append_To (Res, Asn);
4734 
4735       --  Restore the tag
4736 
4737       if Save_Tag then
4738          Append_To (Res,
4739            Make_Assignment_Statement (Loc,
4740              Name       =>
4741                Make_Selected_Component (Loc,
4742                  Prefix        => Duplicate_Subexpr_No_Checks (L),
4743                  Selector_Name =>
4744                    New_Occurrence_Of (First_Tag_Component (T), Loc)),
4745              Expression => New_Occurrence_Of (Tag_Id, Loc)));
4746       end if;
4747 
4748       --  Adjust the target after the assignment when controlled (not in the
4749       --  init proc since it is an initialization more than an assignment).
4750 
4751       if Ctrl_Act then
4752          Append_To (Res,
4753            Make_Adjust_Call
4754              (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
4755               Typ     => Etype (L)));
4756       end if;
4757 
4758       return Res;
4759 
4760    exception
4761 
4762       --  Could use comment here ???
4763 
4764       when RE_Not_Available =>
4765          return Empty_List;
4766    end Make_Tag_Ctrl_Assignment;
4767 
4768 end Exp_Ch5;