gcc/ada/exp_ch4.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              E X P _ C H 4                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Aggr; use Exp_Aggr;
  33 with Exp_Ch3;  use Exp_Ch3;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Ch9;  use Exp_Ch9;
  36 with Exp_Disp; use Exp_Disp;
  37 with Exp_Fixd; use Exp_Fixd;
  38 with Exp_Pakd; use Exp_Pakd;
  39 with Exp_Tss;  use Exp_Tss;
  40 with Exp_Util; use Exp_Util;
  41 with Exp_VFpt; use Exp_VFpt;
  42 with Hostparm; use Hostparm;
  43 with Inline;   use Inline;
  44 with Nlists;   use Nlists;
  45 with Nmake;    use Nmake;
  46 with Opt;      use Opt;
  47 with Rtsfind;  use Rtsfind;
  48 with Sem;      use Sem;
  49 with Sem_Cat;  use Sem_Cat;
  50 with Sem_Ch13; use Sem_Ch13;
  51 with Sem_Eval; use Sem_Eval;
  52 with Sem_Res;  use Sem_Res;
  53 with Sem_Type; use Sem_Type;
  54 with Sem_Util; use Sem_Util;
  55 with Sem_Warn; use Sem_Warn;
  56 with Sinfo;    use Sinfo;
  57 with Sinfo.CN; use Sinfo.CN;
  58 with Snames;   use Snames;
  59 with Stand;    use Stand;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Ttypes;   use Ttypes;
  63 with Uintp;    use Uintp;
  64 with Urealp;   use Urealp;
  65 with Validsw;  use Validsw;
  66
  67 package body Exp_Ch4 is
  68
  69    ------------------------
  70    --  Local Subprograms --
  71    ------------------------
  72
  73    procedure Binary_Op_Validity_Checks (N : Node_Id);
  74    pragma Inline (Binary_Op_Validity_Checks);
  75    --  Performs validity checks for a binary operator
  76
  77    procedure Build_Boolean_Array_Proc_Call
  78      (N   : Node_Id;
  79       Op1 : Node_Id;
  80       Op2 : Node_Id);
  81    --  If an boolean array assignment can be done in place, build call to
  82    --  corresponding library procedure.
  83
  84    procedure Expand_Allocator_Expression (N : Node_Id);
  85    --  Subsidiary to Expand_N_Allocator, for the case when the expression
  86    --  is a qualified expression or an aggregate.
  87
  88    procedure Expand_Array_Comparison (N : Node_Id);
  89    --  This routine handles expansion of the comparison operators (N_Op_Lt,
  90    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
  91    --  code for these operators is similar, differing only in the details of
  92    --  the actual comparison call that is made. Special processing (call a
  93    --  run-time routine)
  94
  95    function Expand_Array_Equality
  96      (Nod    : Node_Id;
  97       Typ    : Entity_Id;
  98       A_Typ  : Entity_Id;
  99       Lhs    : Node_Id;
 100       Rhs    : Node_Id;
 101       Bodies : List_Id)
 102       return   Node_Id;
 103    --  Expand an array equality into a call to a function implementing this
 104    --  equality, and a call to it. Loc is the location for the generated
 105    --  nodes. Typ is the type of the array, and Lhs, Rhs are the array
 106    --  expressions to be compared. A_Typ is the type of the arguments,
 107    --  which may be a private type, in which case Typ is its full view.
 108    --  Bodies is a list on which to attach bodies of local functions that
 109    --  are created in the process. This is the responsibility of the
 110    --  caller to insert those bodies at the right place. Nod provides
 111    --  the Sloc value for the generated code.
 112
 113    procedure Expand_Boolean_Operator (N : Node_Id);
 114    --  Common expansion processing for Boolean operators (And, Or, Xor)
 115    --  for the case of array type arguments.
 116
 117    function Expand_Composite_Equality
 118      (Nod    : Node_Id;
 119       Typ    : Entity_Id;
 120       Lhs    : Node_Id;
 121       Rhs    : Node_Id;
 122       Bodies : List_Id)
 123       return   Node_Id;
 124    --  Local recursive function used to expand equality for nested
 125    --  composite types. Used by Expand_Record/Array_Equality, Bodies
 126    --  is a list on which to attach bodies of local functions that are
 127    --  created in the process. This is the responsability of the caller
 128    --  to insert those bodies at the right place. Nod provides the Sloc
 129    --  value for generated code.
 130
 131    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
 132    --  This routine handles expansion of concatenation operations, where
 133    --  N is the N_Op_Concat node being expanded and Operands is the list
 134    --  of operands (at least two are present). The caller has dealt with
 135    --  converting any singleton operands into singleton aggregates.
 136
 137    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
 138    --  Routine to expand concatenation of 2-5 operands (in the list Operands)
 139    --  and replace node Cnode with the result of the contatenation. If there
 140    --  are two operands, they can be string or character. If there are more
 141    --  than two operands, then are always of type string (i.e. the caller has
 142    --  already converted character operands to strings in this case).
 143
 144    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
 145    --  N is either an N_Op_Divide or N_Op_Multiply node whose result is
 146    --  universal fixed. We do not have such a type at runtime, so the
 147    --  purpose of this routine is to find the real type by looking up
 148    --  the tree. We also determine if the operation must be rounded.
 149
 150    function Get_Allocator_Final_List
 151      (N    : Node_Id;
 152       T    : Entity_Id;
 153       PtrT : Entity_Id)
 154       return Entity_Id;
 155    --  If the designated type is controlled, build final_list expression
 156    --  for created object. If context is an access parameter, create a
 157    --  local access type to have a usable finalization list.
 158
 159    procedure Insert_Dereference_Action (N : Node_Id);
 160    --  N is an expression whose type is an access. When the type is derived
 161    --  from Checked_Pool, expands a call to the primitive 'dereference'.
 162
 163    function Make_Array_Comparison_Op
 164      (Typ   : Entity_Id;
 165       Nod   : Node_Id)
 166       return  Node_Id;
 167    --  Comparisons between arrays are expanded in line. This function
 168    --  produces the body of the implementation of (a > b), where a and b
 169    --  are one-dimensional arrays of some discrete type. The original
 170    --  node is then expanded into the appropriate call to this function.
 171    --  Nod provides the Sloc value for the generated code.
 172
 173    function Make_Boolean_Array_Op
 174      (Typ  : Entity_Id;
 175       N    : Node_Id)
 176       return Node_Id;
 177    --  Boolean operations on boolean arrays are expanded in line. This
 178    --  function produce the body for the node N, which is (a and b),
 179    --  (a or b), or (a xor b). It is used only the normal case and not
 180    --  the packed case. The type involved, Typ, is the Boolean array type,
 181    --  and the logical operations in the body are simple boolean operations.
 182    --  Note that Typ is always a constrained type (the caller has ensured
 183    --  this by using Convert_To_Actual_Subtype if necessary).
 184
 185    procedure Rewrite_Comparison (N : Node_Id);
 186    --  N is the node for a compile time comparison. If this outcome of this
 187    --  comparison can be determined at compile time, then the node N can be
 188    --  rewritten with True or False. If the outcome cannot be determined at
 189    --  compile time, the call has no effect.
 190
 191    function Tagged_Membership (N : Node_Id) return Node_Id;
 192    --  Construct the expression corresponding to the tagged membership test.
 193    --  Deals with a second operand being (or not) a class-wide type.
 194
 195    function Safe_In_Place_Array_Op
 196      (Lhs  : Node_Id;
 197       Op1  : Node_Id;
 198       Op2  : Node_Id)
 199       return Boolean;
 200    --  In the context of an assignment, where the right-hand side is a
 201    --  boolean operation on arrays, check whether operation can be performed
 202    --  in place.
 203
 204    procedure Unary_Op_Validity_Checks (N : Node_Id);
 205    pragma Inline (Unary_Op_Validity_Checks);
 206    --  Performs validity checks for a unary operator
 207
 208    -------------------------------
 209    -- Binary_Op_Validity_Checks --
 210    -------------------------------
 211
 212    procedure Binary_Op_Validity_Checks (N : Node_Id) is
 213    begin
 214       if Validity_Checks_On and Validity_Check_Operands then
 215          Ensure_Valid (Left_Opnd (N));
 216          Ensure_Valid (Right_Opnd (N));
 217       end if;
 218    end Binary_Op_Validity_Checks;
 219
 220    ------------------------------------
 221    -- Build_Boolean_Array_Proc_Call --
 222    ------------------------------------
 223
 224    procedure Build_Boolean_Array_Proc_Call
 225      (N   : Node_Id;
 226       Op1 : Node_Id;
 227       Op2 : Node_Id)
 228    is
 229       Loc       : constant Source_Ptr := Sloc (N);
 230       Kind      : constant Node_Kind := Nkind (Expression (N));
 231       Target    : constant Node_Id   :=
 232                     Make_Attribute_Reference (Loc,
 233                       Prefix         => Name (N),
 234                       Attribute_Name => Name_Address);
 235
 236       Arg1      : constant Node_Id := Op1;
 237       Arg2      : Node_Id := Op2;
 238       Call_Node : Node_Id;
 239       Proc_Name : Entity_Id;
 240
 241    begin
 242       if Kind = N_Op_Not then
 243          if Nkind (Op1) in N_Binary_Op then
 244
 245             --  Use negated version of the binary operators.
 246
 247             if Nkind (Op1) = N_Op_And then
 248                Proc_Name := RTE (RE_Vector_Nand);
 249
 250             elsif Nkind (Op1) = N_Op_Or then
 251                Proc_Name := RTE (RE_Vector_Nor);
 252
 253             else pragma Assert (Nkind (Op1) = N_Op_Xor);
 254                Proc_Name := RTE (RE_Vector_Xor);
 255             end if;
 256
 257             Call_Node :=
 258               Make_Procedure_Call_Statement (Loc,
 259                 Name => New_Occurrence_Of (Proc_Name, Loc),
 260
 261                 Parameter_Associations => New_List (
 262                   Target,
 263                   Make_Attribute_Reference (Loc,
 264                     Prefix => Left_Opnd (Op1),
 265                     Attribute_Name => Name_Address),
 266
 267                   Make_Attribute_Reference (Loc,
 268                     Prefix => Right_Opnd (Op1),
 269                     Attribute_Name => Name_Address),
 270
 271                   Make_Attribute_Reference (Loc,
 272                     Prefix => Left_Opnd (Op1),
 273                     Attribute_Name => Name_Length)));
 274
 275          else
 276             Proc_Name := RTE (RE_Vector_Not);
 277
 278             Call_Node :=
 279               Make_Procedure_Call_Statement (Loc,
 280                 Name => New_Occurrence_Of (Proc_Name, Loc),
 281                 Parameter_Associations => New_List (
 282                   Target,
 283
 284                   Make_Attribute_Reference (Loc,
 285                     Prefix => Op1,
 286                     Attribute_Name => Name_Address),
 287
 288                   Make_Attribute_Reference (Loc,
 289                     Prefix => Op1,
 290                      Attribute_Name => Name_Length)));
 291          end if;
 292
 293       else
 294          --  We use the following equivalences:
 295
 296          --   (not X) or  (not Y)  =  not (X and Y)  =  Nand (X, Y)
 297          --   (not X) and (not Y)  =  not (X or Y)   =  Nor  (X, Y)
 298          --   (not X) xor (not Y)  =  X xor Y
 299          --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)
 300
 301          if Nkind (Op1) = N_Op_Not then
 302             if Kind = N_Op_And then
 303                Proc_Name := RTE (RE_Vector_Nor);
 304
 305             elsif Kind = N_Op_Or then
 306                Proc_Name := RTE (RE_Vector_Nand);
 307
 308             else
 309                Proc_Name := RTE (RE_Vector_Xor);
 310             end if;
 311
 312          else
 313             if Kind = N_Op_And then
 314                Proc_Name := RTE (RE_Vector_And);
 315
 316             elsif Kind = N_Op_Or then
 317                Proc_Name := RTE (RE_Vector_Or);
 318
 319             elsif Nkind (Op2) = N_Op_Not then
 320                Proc_Name := RTE (RE_Vector_Nxor);
 321                Arg2 := Right_Opnd (Op2);
 322
 323             else
 324                Proc_Name := RTE (RE_Vector_Xor);
 325             end if;
 326          end if;
 327
 328          Call_Node :=
 329            Make_Procedure_Call_Statement (Loc,
 330              Name => New_Occurrence_Of (Proc_Name, Loc),
 331              Parameter_Associations => New_List (
 332                Target,
 333                   Make_Attribute_Reference (Loc,
 334                     Prefix => Arg1,
 335                     Attribute_Name => Name_Address),
 336                   Make_Attribute_Reference (Loc,
 337                     Prefix => Arg2,
 338                     Attribute_Name => Name_Address),
 339                  Make_Attribute_Reference (Loc,
 340                    Prefix => Op1,
 341                     Attribute_Name => Name_Length)));
 342       end if;
 343
 344       Rewrite (N, Call_Node);
 345       Analyze (N);
 346
 347    exception
 348       when RE_Not_Available =>
 349          return;
 350    end Build_Boolean_Array_Proc_Call;
 351
 352    ---------------------------------
 353    -- Expand_Allocator_Expression --
 354    ---------------------------------
 355
 356    procedure Expand_Allocator_Expression (N : Node_Id) is
 357       Loc   : constant Source_Ptr := Sloc (N);
 358       Exp   : constant Node_Id    := Expression (Expression (N));
 359       Indic : constant Node_Id    := Subtype_Mark (Expression (N));
 360       PtrT  : constant Entity_Id  := Etype (N);
 361       T     : constant Entity_Id  := Entity (Indic);
 362       Flist : Node_Id;
 363       Node  : Node_Id;
 364       Temp  : Entity_Id;
 365
 366       Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
 367
 368       Tag_Assign : Node_Id;
 369       Tmp_Node   : Node_Id;
 370
 371    begin
 372       if Is_Tagged_Type (T) or else Controlled_Type (T) then
 373
 374          --    Actions inserted before:
 375          --              Temp : constant ptr_T := new T'(Expression);
 376          --   <no CW>    Temp._tag := T'tag;
 377          --   <CTRL>     Adjust (Finalizable (Temp.all));
 378          --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
 379
 380          --  We analyze by hand the new internal allocator to avoid
 381          --  any recursion and inappropriate call to Initialize
 382          if not Aggr_In_Place then
 383             Remove_Side_Effects (Exp);
 384          end if;
 385
 386          Temp :=
 387            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 388
 389          --  For a class wide allocation generate the following code:
 390
 391          --    type Equiv_Record is record ... end record;
 392          --    implicit subtype CW is <Class_Wide_Subytpe>;
 393          --    temp : PtrT := new CW'(CW!(expr));
 394
 395          if Is_Class_Wide_Type (T) then
 396             Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
 397
 398             Set_Expression (Expression (N),
 399               Unchecked_Convert_To (Entity (Indic), Exp));
 400
 401             Analyze_And_Resolve (Expression (N), Entity (Indic));
 402          end if;
 403
 404          if Aggr_In_Place then
 405             Tmp_Node :=
 406               Make_Object_Declaration (Loc,
 407                 Defining_Identifier => Temp,
 408                 Object_Definition   => New_Reference_To (PtrT, Loc),
 409                 Expression          =>
 410                   Make_Allocator (Loc,
 411                     New_Reference_To (Etype (Exp), Loc)));
 412
 413             Set_Comes_From_Source
 414               (Expression (Tmp_Node), Comes_From_Source (N));
 415
 416             Set_No_Initialization (Expression (Tmp_Node));
 417             Insert_Action (N, Tmp_Node);
 418
 419             if Controlled_Type (T)
 420               and then Ekind (PtrT) = E_Anonymous_Access_Type
 421             then
 422                --  Create local finalization list for access parameter.
 423
 424                Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 425             end if;
 426
 427             Convert_Aggr_In_Allocator (Tmp_Node, Exp);
 428          else
 429             Node := Relocate_Node (N);
 430             Set_Analyzed (Node);
 431             Insert_Action (N,
 432               Make_Object_Declaration (Loc,
 433                 Defining_Identifier => Temp,
 434                 Constant_Present    => True,
 435                 Object_Definition   => New_Reference_To (PtrT, Loc),
 436                 Expression          => Node));
 437          end if;
 438
 439          --  Suppress the tag assignment when Java_VM because JVM tags
 440          --  are represented implicitly in objects.
 441
 442          if Is_Tagged_Type (T)
 443            and then not Is_Class_Wide_Type (T)
 444            and then not Java_VM
 445          then
 446             Tag_Assign :=
 447               Make_Assignment_Statement (Loc,
 448                 Name =>
 449                   Make_Selected_Component (Loc,
 450                     Prefix => New_Reference_To (Temp, Loc),
 451                     Selector_Name =>
 452                       New_Reference_To (Tag_Component (T), Loc)),
 453
 454                 Expression =>
 455                   Unchecked_Convert_To (RTE (RE_Tag),
 456                     New_Reference_To (Access_Disp_Table (T), Loc)));
 457
 458             --  The previous assignment has to be done in any case
 459
 460             Set_Assignment_OK (Name (Tag_Assign));
 461             Insert_Action (N, Tag_Assign);
 462
 463          elsif Is_Private_Type (T)
 464            and then Is_Tagged_Type (Underlying_Type (T))
 465            and then not Java_VM
 466          then
 467             declare
 468                Utyp : constant Entity_Id := Underlying_Type (T);
 469                Ref  : constant Node_Id :=
 470                         Unchecked_Convert_To (Utyp,
 471                           Make_Explicit_Dereference (Loc,
 472                             New_Reference_To (Temp, Loc)));
 473
 474             begin
 475                Tag_Assign :=
 476                  Make_Assignment_Statement (Loc,
 477                    Name =>
 478                      Make_Selected_Component (Loc,
 479                        Prefix => Ref,
 480                        Selector_Name =>
 481                          New_Reference_To (Tag_Component (Utyp), Loc)),
 482
 483                    Expression =>
 484                      Unchecked_Convert_To (RTE (RE_Tag),
 485                        New_Reference_To (
 486                          Access_Disp_Table (Utyp), Loc)));
 487
 488                Set_Assignment_OK (Name (Tag_Assign));
 489                Insert_Action (N, Tag_Assign);
 490             end;
 491          end if;
 492
 493          if Controlled_Type (Designated_Type (PtrT))
 494             and then Controlled_Type (T)
 495          then
 496             declare
 497                Attach : Node_Id;
 498                Apool  : constant Entity_Id :=
 499                           Associated_Storage_Pool (PtrT);
 500
 501             begin
 502                --  If it is an allocation on the secondary stack
 503                --  (i.e. a value returned from a function), the object
 504                --  is attached on the caller side as soon as the call
 505                --  is completed (see Expand_Ctrl_Function_Call)
 506
 507                if Is_RTE (Apool, RE_SS_Pool) then
 508                   declare
 509                      F : constant Entity_Id :=
 510                            Make_Defining_Identifier (Loc,
 511                              New_Internal_Name ('F'));
 512                   begin
 513                      Insert_Action (N,
 514                        Make_Object_Declaration (Loc,
 515                          Defining_Identifier => F,
 516                          Object_Definition   => New_Reference_To (RTE
 517                           (RE_Finalizable_Ptr), Loc)));
 518
 519                      Flist := New_Reference_To (F, Loc);
 520                      Attach :=  Make_Integer_Literal (Loc, 1);
 521                   end;
 522
 523                --  Normal case, not a secondary stack allocation
 524
 525                else
 526                   Flist := Find_Final_List (PtrT);
 527                   Attach :=  Make_Integer_Literal (Loc, 2);
 528                end if;
 529
 530                if not Aggr_In_Place then
 531                   Insert_Actions (N,
 532                     Make_Adjust_Call (
 533                       Ref          =>
 534
 535                      --  An unchecked conversion is needed in the
 536                      --  classwide case because the designated type
 537                      --  can be an ancestor of the subtype mark of
 538                      --  the allocator.
 539
 540                       Unchecked_Convert_To (T,
 541                         Make_Explicit_Dereference (Loc,
 542                           New_Reference_To (Temp, Loc))),
 543
 544                       Typ          => T,
 545                       Flist_Ref    => Flist,
 546                       With_Attach  => Attach));
 547                end if;
 548             end;
 549          end if;
 550
 551          Rewrite (N, New_Reference_To (Temp, Loc));
 552          Analyze_And_Resolve (N, PtrT);
 553
 554       elsif Aggr_In_Place then
 555          Temp :=
 556            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 557          Tmp_Node :=
 558            Make_Object_Declaration (Loc,
 559              Defining_Identifier => Temp,
 560              Object_Definition   => New_Reference_To (PtrT, Loc),
 561              Expression          => Make_Allocator (Loc,
 562                  New_Reference_To (Etype (Exp), Loc)));
 563
 564          Set_Comes_From_Source
 565            (Expression (Tmp_Node), Comes_From_Source (N));
 566
 567          Set_No_Initialization (Expression (Tmp_Node));
 568          Insert_Action (N, Tmp_Node);
 569          Convert_Aggr_In_Allocator (Tmp_Node, Exp);
 570          Rewrite (N, New_Reference_To (Temp, Loc));
 571          Analyze_And_Resolve (N, PtrT);
 572
 573       elsif Is_Access_Type (Designated_Type (PtrT))
 574         and then Nkind (Exp) = N_Allocator
 575         and then Nkind (Expression (Exp)) /= N_Qualified_Expression
 576       then
 577          --  Apply constraint to designated subtype indication.
 578
 579          Apply_Constraint_Check (Expression (Exp),
 580            Designated_Type (Designated_Type (PtrT)),
 581            No_Sliding => True);
 582
 583          if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
 584
 585             --  Propagate constraint_error to enclosing allocator
 586
 587             Rewrite (Exp, New_Copy (Expression (Exp)));
 588          end if;
 589       else
 590          --  First check against the type of the qualified expression
 591          --
 592          --  NOTE: The commented call should be correct, but for
 593          --  some reason causes the compiler to bomb (sigsegv) on
 594          --  ACVC test c34007g, so for now we just perform the old
 595          --  (incorrect) test against the designated subtype with
 596          --  no sliding in the else part of the if statement below.
 597          --  ???
 598          --
 599          --  Apply_Constraint_Check (Exp, T, No_Sliding => True);
 600
 601          --  A check is also needed in cases where the designated
 602          --  subtype is constrained and differs from the subtype
 603          --  given in the qualified expression. Note that the check
 604          --  on the qualified expression does not allow sliding,
 605          --  but this check does (a relaxation from Ada 83).
 606
 607          if Is_Constrained (Designated_Type (PtrT))
 608            and then not Subtypes_Statically_Match
 609                           (T, Designated_Type (PtrT))
 610          then
 611             Apply_Constraint_Check
 612               (Exp, Designated_Type (PtrT), No_Sliding => False);
 613
 614          --  The nonsliding check should really be performed
 615          --  (unconditionally) against the subtype of the
 616          --  qualified expression, but that causes a problem
 617          --  with c34007g (see above), so for now we retain this.
 618
 619          else
 620             Apply_Constraint_Check
 621               (Exp, Designated_Type (PtrT), No_Sliding => True);
 622          end if;
 623       end if;
 624
 625    exception
 626       when RE_Not_Available =>
 627          return;
 628    end Expand_Allocator_Expression;
 629
 630    -----------------------------
 631    -- Expand_Array_Comparison --
 632    -----------------------------
 633
 634    --  Expansion is only required in the case of array types. For the
 635    --  unpacked case, an appropriate runtime routine is called. For
 636    --  packed cases, and also in some other cases where a runtime
 637    --  routine cannot be called, the form of the expansion is:
 638
 639    --     [body for greater_nn; boolean_expression]
 640
 641    --  The body is built by Make_Array_Comparison_Op, and the form of the
 642    --  Boolean expression depends on the operator involved.
 643
 644    procedure Expand_Array_Comparison (N : Node_Id) is
 645       Loc  : constant Source_Ptr := Sloc (N);
 646       Op1  : Node_Id             := Left_Opnd (N);
 647       Op2  : Node_Id             := Right_Opnd (N);
 648       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
 649       Ctyp : constant Entity_Id  := Component_Type (Typ1);
 650
 651       Expr      : Node_Id;
 652       Func_Body : Node_Id;
 653       Func_Name : Entity_Id;
 654
 655       Comp : RE_Id;
 656
 657       Stg_Unit_Is_Byte : constant Boolean := System_Storage_Unit = Byte'Size;
 658
 659       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
 660       --  Returns True if the length of the given operand is known to be
 661       --  less than 4. Returns False if this length is known to be four
 662       --  or greater or is not known at compile time.
 663
 664       ------------------------
 665       -- Length_Less_Than_4 --
 666       ------------------------
 667
 668       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
 669          Otyp : constant Entity_Id := Etype (Opnd);
 670
 671       begin
 672          if Ekind (Otyp) = E_String_Literal_Subtype then
 673             return String_Literal_Length (Otyp) < 4;
 674
 675          else
 676             declare
 677                Ityp : constant Entity_Id := Etype (First_Index (Otyp));
 678                Lo   : constant Node_Id   := Type_Low_Bound (Ityp);
 679                Hi   : constant Node_Id   := Type_High_Bound (Ityp);
 680                Lov  : Uint;
 681                Hiv  : Uint;
 682
 683             begin
 684                if Compile_Time_Known_Value (Lo) then
 685                   Lov := Expr_Value (Lo);
 686                else
 687                   return False;
 688                end if;
 689
 690                if Compile_Time_Known_Value (Hi) then
 691                   Hiv := Expr_Value (Hi);
 692                else
 693                   return False;
 694                end if;
 695
 696                return Hiv < Lov + 3;
 697             end;
 698          end if;
 699       end Length_Less_Than_4;
 700
 701    --  Start of processing for Expand_Array_Comparison
 702
 703    begin
 704       --  Deal first with unpacked case, where we can call a runtime routine
 705       --  except that we avoid this for targets for which are not addressable
 706       --  by bytes, and for the JVM, since the JVM does not support direct
 707       --  addressing of array components.
 708
 709       if not Is_Bit_Packed_Array (Typ1)
 710         and then Stg_Unit_Is_Byte
 711         and then not Java_VM
 712       then
 713          --  The call we generate is:
 714
 715          --  Compare_Array_xn[_Unaligned]
 716          --    (left'address, right'address, left'length, right'length) <op> 0
 717
 718          --  x = U for unsigned, S for signed
 719          --  n = 8,16,32,64 for component size
 720          --  Add _Unaligned if length < 4 and component size is 8.
 721          --  <op> is the standard comparison operator
 722
 723          if Component_Size (Typ1) = 8 then
 724             if Length_Less_Than_4 (Op1)
 725                  or else
 726                Length_Less_Than_4 (Op2)
 727             then
 728                if Is_Unsigned_Type (Ctyp) then
 729                   Comp := RE_Compare_Array_U8_Unaligned;
 730                else
 731                   Comp := RE_Compare_Array_S8_Unaligned;
 732                end if;
 733
 734             else
 735                if Is_Unsigned_Type (Ctyp) then
 736                   Comp := RE_Compare_Array_U8;
 737                else
 738                   Comp := RE_Compare_Array_S8;
 739                end if;
 740             end if;
 741
 742          elsif Component_Size (Typ1) = 16 then
 743             if Is_Unsigned_Type (Ctyp) then
 744                Comp := RE_Compare_Array_U16;
 745             else
 746                Comp := RE_Compare_Array_S16;
 747             end if;
 748
 749          elsif Component_Size (Typ1) = 32 then
 750             if Is_Unsigned_Type (Ctyp) then
 751                Comp := RE_Compare_Array_U32;
 752             else
 753                Comp := RE_Compare_Array_S32;
 754             end if;
 755
 756          else pragma Assert (Component_Size (Typ1) = 64);
 757             if Is_Unsigned_Type (Ctyp) then
 758                Comp := RE_Compare_Array_U64;
 759             else
 760                Comp := RE_Compare_Array_S64;
 761             end if;
 762          end if;
 763
 764          Remove_Side_Effects (Op1, Name_Req => True);
 765          Remove_Side_Effects (Op2, Name_Req => True);
 766
 767          Rewrite (Op1,
 768            Make_Function_Call (Sloc (Op1),
 769              Name => New_Occurrence_Of (RTE (Comp), Loc),
 770
 771              Parameter_Associations => New_List (
 772                Make_Attribute_Reference (Loc,
 773                  Prefix         => Relocate_Node (Op1),
 774                  Attribute_Name => Name_Address),
 775
 776                Make_Attribute_Reference (Loc,
 777                  Prefix         => Relocate_Node (Op2),
 778                  Attribute_Name => Name_Address),
 779
 780                Make_Attribute_Reference (Loc,
 781                  Prefix         => Relocate_Node (Op1),
 782                  Attribute_Name => Name_Length),
 783
 784                Make_Attribute_Reference (Loc,
 785                  Prefix         => Relocate_Node (Op2),
 786                  Attribute_Name => Name_Length))));
 787
 788          Rewrite (Op2,
 789            Make_Integer_Literal (Sloc (Op2),
 790              Intval => Uint_0));
 791
 792          Analyze_And_Resolve (Op1, Standard_Integer);
 793          Analyze_And_Resolve (Op2, Standard_Integer);
 794          return;
 795       end if;
 796
 797       --  Cases where we cannot make runtime call
 798
 799       --  For (a <= b) we convert to not (a > b)
 800
 801       if Chars (N) = Name_Op_Le then
 802          Rewrite (N,
 803            Make_Op_Not (Loc,
 804              Right_Opnd =>
 805                 Make_Op_Gt (Loc,
 806                  Left_Opnd  => Op1,
 807                  Right_Opnd => Op2)));
 808          Analyze_And_Resolve (N, Standard_Boolean);
 809          return;
 810
 811       --  For < the Boolean expression is
 812       --    greater__nn (op2, op1)
 813
 814       elsif Chars (N) = Name_Op_Lt then
 815          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 816
 817          --  Switch operands
 818
 819          Op1 := Right_Opnd (N);
 820          Op2 := Left_Opnd  (N);
 821
 822       --  For (a >= b) we convert to not (a < b)
 823
 824       elsif Chars (N) = Name_Op_Ge then
 825          Rewrite (N,
 826            Make_Op_Not (Loc,
 827              Right_Opnd =>
 828                Make_Op_Lt (Loc,
 829                  Left_Opnd  => Op1,
 830                  Right_Opnd => Op2)));
 831          Analyze_And_Resolve (N, Standard_Boolean);
 832          return;
 833
 834       --  For > the Boolean expression is
 835       --    greater__nn (op1, op2)
 836
 837       else
 838          pragma Assert (Chars (N) = Name_Op_Gt);
 839          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 840       end if;
 841
 842       Func_Name := Defining_Unit_Name (Specification (Func_Body));
 843       Expr :=
 844         Make_Function_Call (Loc,
 845           Name => New_Reference_To (Func_Name, Loc),
 846           Parameter_Associations => New_List (Op1, Op2));
 847
 848       Insert_Action (N, Func_Body);
 849       Rewrite (N, Expr);
 850       Analyze_And_Resolve (N, Standard_Boolean);
 851
 852    exception
 853       when RE_Not_Available =>
 854          return;
 855    end Expand_Array_Comparison;
 856
 857    ---------------------------
 858    -- Expand_Array_Equality --
 859    ---------------------------
 860
 861    --  Expand an equality function for multi-dimensional arrays. Here is
 862    --  an example of such a function for Nb_Dimension = 2
 863
 864    --  function Enn (A : arr; B : arr) return boolean is
 865    --  begin
 866    --     if (A'length (1) = 0 or else A'length (2) = 0)
 867    --          and then
 868    --        (B'length (1) = 0 or else B'length (2) = 0)
 869    --     then
 870    --        return True;    -- RM 4.5.2(22)
 871    --     end if;
 872    --
 873    --     if A'length (1) /= B'length (1)
 874    --               or else
 875    --           A'length (2) /= B'length (2)
 876    --     then
 877    --        return False;   -- RM 4.5.2(23)
 878    --     end if;
 879    --
 880    --     declare
 881    --        A1 : Index_type_1 := A'first (1)
 882    --        B1 : Index_Type_1 := B'first (1)
 883    --     begin
 884    --        loop
 885    --           declare
 886    --              A2 : Index_type_2 := A'first (2);
 887    --              B2 : Index_type_2 := B'first (2)
 888    --           begin
 889    --              loop
 890    --                 if A (A1, A2) /= B (B1, B2) then
 891    --                    return False;
 892    --                 end if;
 893    --
 894    --                 exit when A2 = A'last (2);
 895    --                 A2 := Index_type2'succ (A2);
 896    --                 B2 := Index_type2'succ (B2);
 897    --              end loop;
 898    --           end;
 899    --
 900    --           exit when A1 = A'last (1);
 901    --           A1 := Index_type1'succ (A1);
 902    --           B1 := Index_type1'succ (B1);
 903    --        end loop;
 904    --     end;
 905    --
 906    --     return true;
 907    --  end Enn;
 908
 909    function Expand_Array_Equality
 910      (Nod    : Node_Id;
 911       Typ    : Entity_Id;
 912       A_Typ  : Entity_Id;
 913       Lhs    : Node_Id;
 914       Rhs    : Node_Id;
 915       Bodies : List_Id)
 916       return   Node_Id
 917    is
 918       Loc         : constant Source_Ptr := Sloc (Nod);
 919       Decls       : constant List_Id    := New_List;
 920       Index_List1 : constant List_Id    := New_List;
 921       Index_List2 : constant List_Id    := New_List;
 922
 923       Actuals   : List_Id;
 924       Formals   : List_Id;
 925       Func_Name : Entity_Id;
 926       Func_Body : Node_Id;
 927
 928       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
 929       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
 930
 931       function Arr_Attr
 932         (Arr : Entity_Id;
 933          Nam : Name_Id;
 934          Num : Int)
 935          return Node_Id;
 936       --  This builds the attribute reference Arr'Nam (Expr).
 937
 938       function Component_Equality (Typ : Entity_Id) return Node_Id;
 939       --  Create one statement to compare corresponding components,
 940       --  designated by a full set of indices.
 941
 942       function Handle_One_Dimension
 943         (N     : Int;
 944          Index : Node_Id)
 945          return  Node_Id;
 946       --  This procedure returns a declare block:
 947       --
 948       --    declare
 949       --       An : Index_Type_n := A'First (n);
 950       --       Bn : Index_Type_n := B'First (n);
 951       --    begin
 952       --       loop
 953       --          xxx
 954       --          exit when An = A'Last (n);
 955       --          An := Index_Type_n'Succ (An)
 956       --          Bn := Index_Type_n'Succ (Bn)
 957       --       end loop;
 958       --    end;
 959       --
 960       --  where N is the value of "n" in the above code. Index is the
 961       --  N'th index node, whose Etype is Index_Type_n in the above code.
 962       --  The xxx statement is either the declare block for the next
 963       --  dimension or if this is the last dimension the comparison
 964       --  of corresponding components of the arrays.
 965       --
 966       --  The actual way the code works is to return the comparison
 967       --  of corresponding components for the N+1 call. That's neater!
 968
 969       function Test_Empty_Arrays return Node_Id;
 970       --  This function constructs the test for both arrays being empty
 971       --    (A'length (1) = 0 or else A'length (2) = 0 or else ...)
 972       --      and then
 973       --    (B'length (1) = 0 or else B'length (2) = 0 or else ...)
 974
 975       function Test_Lengths_Correspond return Node_Id;
 976       --  This function constructs the test for arrays having different
 977       --  lengths in at least one index position, in which case resull
 978
 979       --     A'length (1) /= B'length (1)
 980       --       or else
 981       --     A'length (2) /= B'length (2)
 982       --       or else
 983       --       ...
 984
 985       --------------
 986       -- Arr_Attr --
 987       --------------
 988
 989       function Arr_Attr
 990         (Arr : Entity_Id;
 991          Nam : Name_Id;
 992          Num : Int)
 993          return Node_Id
 994       is
 995       begin
 996          return
 997            Make_Attribute_Reference (Loc,
 998             Attribute_Name => Nam,
 999             Prefix => New_Reference_To (Arr, Loc),
1000             Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1001       end Arr_Attr;
1002
1003       ------------------------
1004       -- Component_Equality --
1005       ------------------------
1006
1007       function Component_Equality (Typ : Entity_Id) return Node_Id is
1008          Test : Node_Id;
1009          L, R : Node_Id;
1010
1011       begin
1012          --  if a(i1...) /= b(j1...) then return false; end if;
1013
1014          L :=
1015            Make_Indexed_Component (Loc,
1016              Prefix => Make_Identifier (Loc, Chars (A)),
1017              Expressions => Index_List1);
1018
1019          R :=
1020            Make_Indexed_Component (Loc,
1021              Prefix => Make_Identifier (Loc, Chars (B)),
1022              Expressions => Index_List2);
1023
1024          Test := Expand_Composite_Equality
1025                    (Nod, Component_Type (Typ), L, R, Decls);
1026
1027          return
1028            Make_Implicit_If_Statement (Nod,
1029              Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1030              Then_Statements => New_List (
1031                Make_Return_Statement (Loc,
1032                  Expression => New_Occurrence_Of (Standard_False, Loc))));
1033       end Component_Equality;
1034
1035       --------------------------
1036       -- Handle_One_Dimension --
1037       ---------------------------
1038
1039       function Handle_One_Dimension
1040         (N     : Int;
1041          Index : Node_Id)
1042          return  Node_Id
1043       is
1044          An : constant Entity_Id := Make_Defining_Identifier (Loc,
1045                                       Chars => New_Internal_Name ('A'));
1046          Bn : constant Entity_Id := Make_Defining_Identifier (Loc,
1047                                       Chars => New_Internal_Name ('B'));
1048          Index_Type_n  : Entity_Id;
1049
1050       begin
1051          if N > Number_Dimensions (Typ) then
1052             return Component_Equality (Typ);
1053          end if;
1054
1055          --  Case where we generate a declare block
1056
1057          Index_Type_n := Base_Type (Etype (Index));
1058          Append (New_Reference_To (An, Loc), Index_List1);
1059          Append (New_Reference_To (Bn, Loc), Index_List2);
1060
1061          return
1062             Make_Block_Statement (Loc,
1063               Declarations => New_List (
1064                  Make_Object_Declaration (Loc,
1065                    Defining_Identifier => An,
1066                    Object_Definition   =>
1067                      New_Reference_To (Index_Type_n, Loc),
1068                    Expression => Arr_Attr (A, Name_First, N)),
1069
1070                  Make_Object_Declaration (Loc,
1071                    Defining_Identifier => Bn,
1072                    Object_Definition   =>
1073                      New_Reference_To (Index_Type_n, Loc),
1074                    Expression => Arr_Attr (B, Name_First, N))),
1075
1076               Handled_Statement_Sequence =>
1077                 Make_Handled_Sequence_Of_Statements (Loc,
1078                   Statements => New_List (
1079                     Make_Implicit_Loop_Statement (Nod,
1080                       Statements => New_List (
1081                         Handle_One_Dimension (N + 1, Next_Index (Index)),
1082
1083                         Make_Exit_Statement (Loc,
1084                           Condition =>
1085                             Make_Op_Eq (Loc,
1086                               Left_Opnd  => New_Reference_To (An, Loc),
1087                               Right_Opnd => Arr_Attr (A, Name_Last, N))),
1088
1089                         Make_Assignment_Statement (Loc,
1090                           Name => New_Reference_To (An, Loc),
1091                           Expression =>
1092                             Make_Attribute_Reference (Loc,
1093                               Prefix =>
1094                                 New_Reference_To (Index_Type_n, Loc),
1095                               Attribute_Name => Name_Succ,
1096                               Expressions => New_List (
1097                                 New_Reference_To (An, Loc)))),
1098
1099                        Make_Assignment_Statement (Loc,
1100                           Name => New_Reference_To (Bn, Loc),
1101                           Expression =>
1102                             Make_Attribute_Reference (Loc,
1103                               Prefix =>
1104                                 New_Reference_To (Index_Type_n, Loc),
1105                               Attribute_Name => Name_Succ,
1106                               Expressions => New_List (
1107                                 New_Reference_To (Bn, Loc)))))))));
1108       end Handle_One_Dimension;
1109
1110       -----------------------
1111       -- Test_Empty_Arrays --
1112       -----------------------
1113
1114       function Test_Empty_Arrays return Node_Id is
1115          Alist : Node_Id;
1116          Blist : Node_Id;
1117
1118          Atest : Node_Id;
1119          Btest : Node_Id;
1120
1121       begin
1122          Alist := Empty;
1123          Blist := Empty;
1124          for J in 1 .. Number_Dimensions (Typ) loop
1125             Atest :=
1126               Make_Op_Eq (Loc,
1127                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1128                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1129
1130             Btest :=
1131               Make_Op_Eq (Loc,
1132                 Left_Opnd  => Arr_Attr (B, Name_Length, J),
1133                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1134
1135             if No (Alist) then
1136                Alist := Atest;
1137                Blist := Btest;
1138
1139             else
1140                Alist :=
1141                  Make_Or_Else (Loc,
1142                    Left_Opnd  => Relocate_Node (Alist),
1143                    Right_Opnd => Atest);
1144
1145                Blist :=
1146                  Make_Or_Else (Loc,
1147                    Left_Opnd  => Relocate_Node (Blist),
1148                    Right_Opnd => Btest);
1149             end if;
1150          end loop;
1151
1152          return
1153            Make_And_Then (Loc,
1154              Left_Opnd  => Alist,
1155              Right_Opnd => Blist);
1156       end Test_Empty_Arrays;
1157
1158       -----------------------------
1159       -- Test_Lengths_Correspond --
1160       -----------------------------
1161
1162       function Test_Lengths_Correspond return Node_Id is
1163          Result : Node_Id;
1164          Rtest  : Node_Id;
1165
1166       begin
1167          Result := Empty;
1168          for J in 1 .. Number_Dimensions (Typ) loop
1169             Rtest :=
1170               Make_Op_Ne (Loc,
1171                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1172                 Right_Opnd => Arr_Attr (B, Name_Length, J));
1173
1174             if No (Result) then
1175                Result := Rtest;
1176             else
1177                Result :=
1178                  Make_Or_Else (Loc,
1179                    Left_Opnd  => Relocate_Node (Result),
1180                    Right_Opnd => Rtest);
1181             end if;
1182          end loop;
1183
1184          return Result;
1185       end Test_Lengths_Correspond;
1186
1187    --  Start of processing for Expand_Array_Equality
1188
1189    begin
1190       Formals := New_List (
1191         Make_Parameter_Specification (Loc,
1192           Defining_Identifier => A,
1193           Parameter_Type      => New_Reference_To (Typ, Loc)),
1194
1195         Make_Parameter_Specification (Loc,
1196           Defining_Identifier => B,
1197           Parameter_Type      => New_Reference_To (Typ, Loc)));
1198
1199       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
1200
1201       --  Build statement sequence for function
1202
1203       Func_Body :=
1204         Make_Subprogram_Body (Loc,
1205           Specification =>
1206             Make_Function_Specification (Loc,
1207               Defining_Unit_Name       => Func_Name,
1208               Parameter_Specifications => Formals,
1209               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
1210
1211           Declarations =>  Decls,
1212
1213           Handled_Statement_Sequence =>
1214             Make_Handled_Sequence_Of_Statements (Loc,
1215               Statements => New_List (
1216
1217                 Make_Implicit_If_Statement (Nod,
1218                   Condition => Test_Empty_Arrays,
1219                   Then_Statements => New_List (
1220                     Make_Return_Statement (Loc,
1221                       Expression =>
1222                         New_Occurrence_Of (Standard_True, Loc)))),
1223
1224                 Make_Implicit_If_Statement (Nod,
1225                   Condition => Test_Lengths_Correspond,
1226                   Then_Statements => New_List (
1227                     Make_Return_Statement (Loc,
1228                       Expression =>
1229                         New_Occurrence_Of (Standard_False, Loc)))),
1230
1231                 Handle_One_Dimension (1, First_Index (Typ)),
1232
1233                 Make_Return_Statement (Loc,
1234                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
1235
1236          Set_Has_Completion (Func_Name, True);
1237
1238          --  If the array type is distinct from the type of the arguments,
1239          --  it is the full view of a private type. Apply an unchecked
1240          --  conversion to insure that analysis of the call succeeds.
1241
1242          if Base_Type (A_Typ) /= Base_Type (Typ) then
1243             Actuals := New_List (
1244               OK_Convert_To (Typ, Lhs),
1245               OK_Convert_To (Typ, Rhs));
1246          else
1247             Actuals := New_List (Lhs, Rhs);
1248          end if;
1249
1250          Append_To (Bodies, Func_Body);
1251
1252          return
1253            Make_Function_Call (Loc,
1254              Name => New_Reference_To (Func_Name, Loc),
1255              Parameter_Associations => Actuals);
1256    end Expand_Array_Equality;
1257
1258    -----------------------------
1259    -- Expand_Boolean_Operator --
1260    -----------------------------
1261
1262    --  Note that we first get the actual subtypes of the operands,
1263    --  since we always want to deal with types that have bounds.
1264
1265    procedure Expand_Boolean_Operator (N : Node_Id) is
1266       Typ : constant Entity_Id  := Etype (N);
1267
1268    begin
1269       if Is_Bit_Packed_Array (Typ) then
1270          Expand_Packed_Boolean_Operator (N);
1271
1272       else
1273          --  For the normal non-packed case, the general expansion is
1274          --  to build a function for carrying out the comparison (using
1275          --  Make_Boolean_Array_Op) and then inserting it into the tree.
1276          --  The original operator node is then rewritten as a call to
1277          --  this function.
1278
1279          declare
1280             Loc       : constant Source_Ptr := Sloc (N);
1281             L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
1282             R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
1283             Func_Body : Node_Id;
1284             Func_Name : Entity_Id;
1285
1286          begin
1287             Convert_To_Actual_Subtype (L);
1288             Convert_To_Actual_Subtype (R);
1289             Ensure_Defined (Etype (L), N);
1290             Ensure_Defined (Etype (R), N);
1291             Apply_Length_Check (R, Etype (L));
1292
1293             if Nkind (Parent (N)) = N_Assignment_Statement
1294                and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
1295             then
1296                Build_Boolean_Array_Proc_Call (Parent (N), L, R);
1297
1298             elsif Nkind (Parent (N)) = N_Op_Not
1299                and then Nkind (N) = N_Op_And
1300                and then
1301                  Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
1302             then
1303                return;
1304             else
1305
1306                Func_Body := Make_Boolean_Array_Op (Etype (L), N);
1307                Func_Name := Defining_Unit_Name (Specification (Func_Body));
1308                Insert_Action (N, Func_Body);
1309
1310                --  Now rewrite the expression with a call
1311
1312                Rewrite (N,
1313                  Make_Function_Call (Loc,
1314                    Name => New_Reference_To (Func_Name, Loc),
1315                    Parameter_Associations =>
1316                      New_List
1317                        (L, Make_Type_Conversion
1318                           (Loc, New_Reference_To (Etype (L), Loc), R))));
1319
1320                Analyze_And_Resolve (N, Typ);
1321             end if;
1322          end;
1323       end if;
1324    end Expand_Boolean_Operator;
1325
1326    -------------------------------
1327    -- Expand_Composite_Equality --
1328    -------------------------------
1329
1330    --  This function is only called for comparing internal fields of composite
1331    --  types when these fields are themselves composites. This is a special
1332    --  case because it is not possible to respect normal Ada visibility rules.
1333
1334    function Expand_Composite_Equality
1335      (Nod    : Node_Id;
1336       Typ    : Entity_Id;
1337       Lhs    : Node_Id;
1338       Rhs    : Node_Id;
1339       Bodies : List_Id)
1340       return   Node_Id
1341    is
1342       Loc       : constant Source_Ptr := Sloc (Nod);
1343       Full_Type : Entity_Id;
1344       Prim      : Elmt_Id;
1345       Eq_Op     : Entity_Id;
1346
1347    begin
1348       if Is_Private_Type (Typ) then
1349          Full_Type := Underlying_Type (Typ);
1350       else
1351          Full_Type := Typ;
1352       end if;
1353
1354       --  Defense against malformed private types with no completion
1355       --  the error will be diagnosed later by check_completion
1356
1357       if No (Full_Type) then
1358          return New_Reference_To (Standard_False, Loc);
1359       end if;
1360
1361       Full_Type := Base_Type (Full_Type);
1362
1363       if Is_Array_Type (Full_Type) then
1364
1365          --  If the operand is an elementary type other than a floating-point
1366          --  type, then we can simply use the built-in block bitwise equality,
1367          --  since the predefined equality operators always apply and bitwise
1368          --  equality is fine for all these cases.
1369
1370          if Is_Elementary_Type (Component_Type (Full_Type))
1371            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
1372          then
1373             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
1374
1375          --  For composite component types, and floating-point types, use
1376          --  the expansion. This deals with tagged component types (where
1377          --  we use the applicable equality routine) and floating-point,
1378          --  (where we need to worry about negative zeroes), and also the
1379          --  case of any composite type recursively containing such fields.
1380
1381          else
1382             return Expand_Array_Equality
1383                      (Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
1384          end if;
1385
1386       elsif Is_Tagged_Type (Full_Type) then
1387
1388          --  Call the primitive operation "=" of this type
1389
1390          if Is_Class_Wide_Type (Full_Type) then
1391             Full_Type := Root_Type (Full_Type);
1392          end if;
1393
1394          --  If this is derived from an untagged private type completed
1395          --  with a tagged type, it does not have a full view, so we
1396          --  use the primitive operations of the private type.
1397          --  This check should no longer be necessary when these
1398          --  types receive their full views ???
1399
1400          if Is_Private_Type (Typ)
1401            and then not Is_Tagged_Type (Typ)
1402            and then not Is_Controlled (Typ)
1403            and then Is_Derived_Type (Typ)
1404            and then No (Full_View (Typ))
1405          then
1406             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
1407          else
1408             Prim := First_Elmt (Primitive_Operations (Full_Type));
1409          end if;
1410
1411          loop
1412             Eq_Op := Node (Prim);
1413             exit when Chars (Eq_Op) = Name_Op_Eq
1414               and then Etype (First_Formal (Eq_Op)) =
1415                        Etype (Next_Formal (First_Formal (Eq_Op)));
1416             Next_Elmt (Prim);
1417             pragma Assert (Present (Prim));
1418          end loop;
1419
1420          Eq_Op := Node (Prim);
1421
1422          return
1423            Make_Function_Call (Loc,
1424              Name => New_Reference_To (Eq_Op, Loc),
1425              Parameter_Associations =>
1426                New_List
1427                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
1428                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
1429
1430       elsif Is_Record_Type (Full_Type) then
1431          Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
1432
1433          if Present (Eq_Op) then
1434             if Etype (First_Formal (Eq_Op)) /= Full_Type then
1435
1436                --  Inherited equality from parent type. Convert the actuals
1437                --  to match signature of operation.
1438
1439                declare
1440                   T : constant Entity_Id := Etype (First_Formal (Eq_Op));
1441
1442                begin
1443                   return
1444                     Make_Function_Call (Loc,
1445                       Name => New_Reference_To (Eq_Op, Loc),
1446                       Parameter_Associations =>
1447                         New_List (OK_Convert_To (T, Lhs),
1448                                   OK_Convert_To (T, Rhs)));
1449                end;
1450
1451             else
1452                return
1453                  Make_Function_Call (Loc,
1454                    Name => New_Reference_To (Eq_Op, Loc),
1455                    Parameter_Associations => New_List (Lhs, Rhs));
1456             end if;
1457
1458          else
1459             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
1460          end if;
1461
1462       else
1463          --  It can be a simple record or the full view of a scalar private
1464
1465          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
1466       end if;
1467    end Expand_Composite_Equality;
1468
1469    ------------------------------
1470    -- Expand_Concatenate_Other --
1471    ------------------------------
1472
1473    --  Let n be the number of array operands to be concatenated, Base_Typ
1474    --  their base type, Ind_Typ their index type, and Arr_Typ the original
1475    --  array type to which the concatenantion operator applies, then the
1476    --  following subprogram is constructed:
1477
1478    --  [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1479    --      L : Ind_Typ;
1480    --   begin
1481    --      if S1'Length /= 0 then
1482    --         L := XXX;   -->  XXX = S1'First       if Arr_Typ is unconstrained
1483    --                          XXX = Arr_Typ'First  otherwise
1484    --      elsif S2'Length /= 0 then
1485    --         L := YYY;   -->  YYY = S2'First       if Arr_Typ is unconstrained
1486    --                          YYY = Arr_Typ'First  otherwise
1487    --      ...
1488    --      elsif Sn-1'Length /= 0 then
1489    --         L := ZZZ;   -->  ZZZ = Sn-1'First     if Arr_Typ is unconstrained
1490    --                          ZZZ = Arr_Typ'First  otherwise
1491    --      else
1492    --         return Sn;
1493    --      end if;
1494
1495    --      declare
1496    --         P : Ind_Typ;
1497    --         H : Ind_Typ :=
1498    --          Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1499    --                       + Ind_Typ'Pos (L));
1500    --         R : Base_Typ (L .. H);
1501    --      begin
1502    --         if S1'Length /= 0 then
1503    --            P := S1'First;
1504    --            loop
1505    --               R (L) := S1 (P);
1506    --               L := Ind_Typ'Succ (L);
1507    --               exit when P = S1'Last;
1508    --               P := Ind_Typ'Succ (P);
1509    --            end loop;
1510    --         end if;
1511    --
1512    --         if S2'Length /= 0 then
1513    --            L := Ind_Typ'Succ (L);
1514    --            loop
1515    --               R (L) := S2 (P);
1516    --               L := Ind_Typ'Succ (L);
1517    --               exit when P = S2'Last;
1518    --               P := Ind_Typ'Succ (P);
1519    --            end loop;
1520    --         end if;
1521
1522    --         ...
1523
1524    --         if Sn'Length /= 0 then
1525    --            P := Sn'First;
1526    --            loop
1527    --               R (L) := Sn (P);
1528    --               L := Ind_Typ'Succ (L);
1529    --               exit when P = Sn'Last;
1530    --               P := Ind_Typ'Succ (P);
1531    --            end loop;
1532    --         end if;
1533
1534    --         return R;
1535    --      end;
1536    --   end Cnn;]
1537
1538    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
1539       Loc      : constant Source_Ptr := Sloc (Cnode);
1540       Nb_Opnds : constant Nat        := List_Length (Opnds);
1541
1542       Arr_Typ  : constant Entity_Id := Etype (Entity (Cnode));
1543       Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
1544       Ind_Typ  : constant Entity_Id := Etype (First_Index (Base_Typ));
1545
1546       Func_Id     : Node_Id;
1547       Func_Spec   : Node_Id;
1548       Param_Specs : List_Id;
1549
1550       Func_Body  : Node_Id;
1551       Func_Decls : List_Id;
1552       Func_Stmts : List_Id;
1553
1554       L_Decl     : Node_Id;
1555
1556       If_Stmt    : Node_Id;
1557       Elsif_List : List_Id;
1558
1559       Declare_Block : Node_Id;
1560       Declare_Decls : List_Id;
1561       Declare_Stmts : List_Id;
1562
1563       H_Decl   : Node_Id;
1564       H_Init   : Node_Id;
1565       P_Decl   : Node_Id;
1566       R_Decl   : Node_Id;
1567       R_Constr : Node_Id;
1568       R_Range  : Node_Id;
1569
1570       Params  : List_Id;
1571       Operand : Node_Id;
1572
1573       function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
1574       --  Builds the sequence of statement:
1575       --    P := Si'First;
1576       --    loop
1577       --       R (L) := Si (P);
1578       --       L := Ind_Typ'Succ (L);
1579       --       exit when P = Si'Last;
1580       --       P := Ind_Typ'Succ (P);
1581       --    end loop;
1582       --
1583       --  where i is the input parameter I given.
1584       --  If the flag Last is true, the exit statement is emitted before
1585       --  incrementing the lower bound, to prevent the creation out of
1586       --  bound values.
1587
1588       function Init_L (I : Nat) return Node_Id;
1589       --  Builds the statement:
1590       --    L := Arr_Typ'First;  If Arr_Typ is constrained
1591       --    L := Si'First;       otherwise (where I is the input param given)
1592
1593       function H return Node_Id;
1594       --  Builds reference to identifier H.
1595
1596       function Ind_Val (E : Node_Id) return Node_Id;
1597       --  Builds expression Ind_Typ'Val (E);
1598
1599       function L return Node_Id;
1600       --  Builds reference to identifier L.
1601
1602       function L_Pos return Node_Id;
1603       --  Builds expression Integer_Type'(Ind_Typ'Pos (L)).
1604       --  We qualify the expression to avoid universal_integer computations
1605       --  whenever possible, in the expression for the upper bound H.
1606
1607       function L_Succ return Node_Id;
1608       --  Builds expression Ind_Typ'Succ (L).
1609
1610       function One return Node_Id;
1611       --  Builds integer literal one.
1612
1613       function P return Node_Id;
1614       --  Builds reference to identifier P.
1615
1616       function P_Succ return Node_Id;
1617       --  Builds expression Ind_Typ'Succ (P).
1618
1619       function R return Node_Id;
1620       --  Builds reference to identifier R.
1621
1622       function S (I : Nat) return Node_Id;
1623       --  Builds reference to identifier Si, where I is the value given.
1624
1625       function S_First (I : Nat) return Node_Id;
1626       --  Builds expression Si'First, where I is the value given.
1627
1628       function S_Last (I : Nat) return Node_Id;
1629       --  Builds expression Si'Last, where I is the value given.
1630
1631       function S_Length (I : Nat) return Node_Id;
1632       --  Builds expression Si'Length, where I is the value given.
1633
1634       function S_Length_Test (I : Nat) return Node_Id;
1635       --  Builds expression Si'Length /= 0, where I is the value given.
1636
1637       -------------------
1638       -- Copy_Into_R_S --
1639       -------------------
1640
1641       function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
1642          Stmts     : constant List_Id := New_List;
1643          P_Start   : Node_Id;
1644          Loop_Stmt : Node_Id;
1645          R_Copy    : Node_Id;
1646          Exit_Stmt : Node_Id;
1647          L_Inc     : Node_Id;
1648          P_Inc     : Node_Id;
1649
1650       begin
1651          --  First construct the initializations
1652
1653          P_Start := Make_Assignment_Statement (Loc,
1654                       Name       => P,
1655                       Expression => S_First (I));
1656          Append_To (Stmts, P_Start);
1657
1658          --  Then build the loop
1659
1660          R_Copy := Make_Assignment_Statement (Loc,
1661                      Name       => Make_Indexed_Component (Loc,
1662                                      Prefix      => R,
1663                                      Expressions => New_List (L)),
1664                      Expression => Make_Indexed_Component (Loc,
1665                                      Prefix      => S (I),
1666                                      Expressions => New_List (P)));
1667
1668          L_Inc := Make_Assignment_Statement (Loc,
1669                     Name       => L,
1670                     Expression => L_Succ);
1671
1672          Exit_Stmt := Make_Exit_Statement (Loc,
1673                         Condition => Make_Op_Eq (Loc, P, S_Last (I)));
1674
1675          P_Inc := Make_Assignment_Statement (Loc,
1676                     Name       => P,
1677                     Expression => P_Succ);
1678
1679          if Last then
1680             Loop_Stmt :=
1681               Make_Implicit_Loop_Statement (Cnode,
1682                 Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
1683          else
1684             Loop_Stmt :=
1685               Make_Implicit_Loop_Statement (Cnode,
1686                 Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
1687          end if;
1688
1689          Append_To (Stmts, Loop_Stmt);
1690
1691          return Stmts;
1692       end Copy_Into_R_S;
1693
1694       -------
1695       -- H --
1696       -------
1697
1698       function H return Node_Id is
1699       begin
1700          return Make_Identifier (Loc, Name_uH);
1701       end H;
1702
1703       -------------
1704       -- Ind_Val --
1705       -------------
1706
1707       function Ind_Val (E : Node_Id) return Node_Id is
1708       begin
1709          return
1710            Make_Attribute_Reference (Loc,
1711              Prefix         => New_Reference_To (Ind_Typ, Loc),
1712              Attribute_Name => Name_Val,
1713              Expressions    => New_List (E));
1714       end Ind_Val;
1715
1716       ------------
1717       -- Init_L --
1718       ------------
1719
1720       function Init_L (I : Nat) return Node_Id is
1721          E : Node_Id;
1722
1723       begin
1724          if Is_Constrained (Arr_Typ) then
1725             E := Make_Attribute_Reference (Loc,
1726                    Prefix         => New_Reference_To (Arr_Typ, Loc),
1727                    Attribute_Name => Name_First);
1728
1729          else
1730             E := S_First (I);
1731          end if;
1732
1733          return Make_Assignment_Statement (Loc, Name => L, Expression => E);
1734       end Init_L;
1735
1736       -------
1737       -- L --
1738       -------
1739
1740       function L return Node_Id is
1741       begin
1742          return Make_Identifier (Loc, Name_uL);
1743       end L;
1744
1745       -----------
1746       -- L_Pos --
1747       -----------
1748
1749       function L_Pos return Node_Id is
1750          Target_Type : Entity_Id;
1751
1752       begin
1753          --  If the index type is an enumeration type, the computation
1754          --  can be done in standard integer. Otherwise, choose a large
1755          --  enough integer type.
1756
1757          if Is_Enumeration_Type (Ind_Typ)
1758            or else Root_Type (Ind_Typ) = Standard_Integer
1759            or else Root_Type (Ind_Typ) = Standard_Short_Integer
1760            or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
1761          then
1762             Target_Type := Standard_Integer;
1763          else
1764             Target_Type := Root_Type (Ind_Typ);
1765          end if;
1766
1767          return
1768            Make_Qualified_Expression (Loc,
1769               Subtype_Mark => New_Reference_To (Target_Type, Loc),
1770               Expression   =>
1771                 Make_Attribute_Reference (Loc,
1772                   Prefix         => New_Reference_To (Ind_Typ, Loc),
1773                   Attribute_Name => Name_Pos,
1774                   Expressions    => New_List (L)));
1775       end L_Pos;
1776
1777       ------------
1778       -- L_Succ --
1779       ------------
1780
1781       function L_Succ return Node_Id is
1782       begin
1783          return
1784            Make_Attribute_Reference (Loc,
1785              Prefix         => New_Reference_To (Ind_Typ, Loc),
1786              Attribute_Name => Name_Succ,
1787              Expressions    => New_List (L));
1788       end L_Succ;
1789
1790       ---------
1791       -- One --
1792       ---------
1793
1794       function One return Node_Id is
1795       begin
1796          return Make_Integer_Literal (Loc, 1);
1797       end One;
1798
1799       -------
1800       -- P --
1801       -------
1802
1803       function P return Node_Id is
1804       begin
1805          return Make_Identifier (Loc, Name_uP);
1806       end P;
1807
1808       ------------
1809       -- P_Succ --
1810       ------------
1811
1812       function P_Succ return Node_Id is
1813       begin
1814          return
1815            Make_Attribute_Reference (Loc,
1816              Prefix         => New_Reference_To (Ind_Typ, Loc),
1817              Attribute_Name => Name_Succ,
1818              Expressions    => New_List (P));
1819       end P_Succ;
1820
1821       -------
1822       -- R --
1823       -------
1824
1825       function R return Node_Id is
1826       begin
1827          return Make_Identifier (Loc, Name_uR);
1828       end R;
1829
1830       -------
1831       -- S --
1832       -------
1833
1834       function S (I : Nat) return Node_Id is
1835       begin
1836          return Make_Identifier (Loc, New_External_Name ('S', I));
1837       end S;
1838
1839       -------------
1840       -- S_First --
1841       -------------
1842
1843       function S_First (I : Nat) return Node_Id is
1844       begin
1845          return Make_Attribute_Reference (Loc,
1846                   Prefix         => S (I),
1847                   Attribute_Name => Name_First);
1848       end S_First;
1849
1850       ------------
1851       -- S_Last --
1852       ------------
1853
1854       function S_Last (I : Nat) return Node_Id is
1855       begin
1856          return Make_Attribute_Reference (Loc,
1857                   Prefix         => S (I),
1858                   Attribute_Name => Name_Last);
1859       end S_Last;
1860
1861       --------------
1862       -- S_Length --
1863       --------------
1864
1865       function S_Length (I : Nat) return Node_Id is
1866       begin
1867          return Make_Attribute_Reference (Loc,
1868                   Prefix         => S (I),
1869                   Attribute_Name => Name_Length);
1870       end S_Length;
1871
1872       -------------------
1873       -- S_Length_Test --
1874       -------------------
1875
1876       function S_Length_Test (I : Nat) return Node_Id is
1877       begin
1878          return
1879            Make_Op_Ne (Loc,
1880              Left_Opnd  => S_Length (I),
1881              Right_Opnd => Make_Integer_Literal (Loc, 0));
1882       end S_Length_Test;
1883
1884    --  Start of processing for Expand_Concatenate_Other
1885
1886    begin
1887       --  Construct the parameter specs and the overall function spec
1888
1889       Param_Specs := New_List;
1890       for I in 1 .. Nb_Opnds loop
1891          Append_To
1892            (Param_Specs,
1893             Make_Parameter_Specification (Loc,
1894               Defining_Identifier =>
1895                 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
1896               Parameter_Type      => New_Reference_To (Base_Typ, Loc)));
1897       end loop;
1898
1899       Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
1900       Func_Spec :=
1901         Make_Function_Specification (Loc,
1902           Defining_Unit_Name       => Func_Id,
1903           Parameter_Specifications => Param_Specs,
1904           Subtype_Mark             => New_Reference_To (Base_Typ, Loc));
1905
1906       --  Construct L's object declaration
1907
1908       L_Decl :=
1909         Make_Object_Declaration (Loc,
1910           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
1911           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
1912
1913       Func_Decls := New_List (L_Decl);
1914
1915       --  Construct the if-then-elsif statements
1916
1917       Elsif_List := New_List;
1918       for I in 2 .. Nb_Opnds - 1 loop
1919          Append_To (Elsif_List, Make_Elsif_Part (Loc,
1920                                   Condition       => S_Length_Test (I),
1921                                   Then_Statements => New_List (Init_L (I))));
1922       end loop;
1923
1924       If_Stmt :=
1925         Make_Implicit_If_Statement (Cnode,
1926           Condition       => S_Length_Test (1),
1927           Then_Statements => New_List (Init_L (1)),
1928           Elsif_Parts     => Elsif_List,
1929           Else_Statements => New_List (Make_Return_Statement (Loc,
1930                                          Expression => S (Nb_Opnds))));
1931
1932       --  Construct the declaration for H
1933
1934       P_Decl :=
1935         Make_Object_Declaration (Loc,
1936           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
1937           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
1938
1939       H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
1940       for I in 2 .. Nb_Opnds loop
1941          H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
1942       end loop;
1943       H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
1944
1945       H_Decl :=
1946         Make_Object_Declaration (Loc,
1947           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
1948           Object_Definition   => New_Reference_To (Ind_Typ, Loc),
1949           Expression          => H_Init);
1950
1951       --  Construct the declaration for R
1952
1953       R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
1954       R_Constr :=
1955         Make_Index_Or_Discriminant_Constraint (Loc,
1956           Constraints => New_List (R_Range));
1957
1958       R_Decl :=
1959         Make_Object_Declaration (Loc,
1960           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
1961           Object_Definition   =>
1962             Make_Subtype_Indication (Loc,
1963                Subtype_Mark => New_Reference_To (Base_Typ, Loc),
1964                Constraint   => R_Constr));
1965
1966       --  Construct the declarations for the declare block
1967
1968       Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
1969
1970       --  Construct list of statements for the declare block
1971
1972       Declare_Stmts := New_List;
1973       for I in 1 .. Nb_Opnds loop
1974          Append_To (Declare_Stmts,
1975                     Make_Implicit_If_Statement (Cnode,
1976                       Condition       => S_Length_Test (I),
1977                       Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
1978       end loop;
1979
1980       Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
1981
1982       --  Construct the declare block
1983
1984       Declare_Block := Make_Block_Statement (Loc,
1985         Declarations               => Declare_Decls,
1986         Handled_Statement_Sequence =>
1987           Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
1988
1989       --  Construct the list of function statements
1990
1991       Func_Stmts := New_List (If_Stmt, Declare_Block);
1992
1993       --  Construct the function body
1994
1995       Func_Body :=
1996         Make_Subprogram_Body (Loc,
1997           Specification              => Func_Spec,
1998           Declarations               => Func_Decls,
1999           Handled_Statement_Sequence =>
2000             Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
2001
2002       --  Insert the newly generated function in the code. This is analyzed
2003       --  with all checks off, since we have completed all the checks.
2004
2005       --  Note that this does *not* fix the array concatenation bug when the
2006       --  low bound is Integer'first sibce that bug comes from the pointer
2007       --  dereferencing an unconstrained array. An there we need a constraint
2008       --  check to make sure the length of the concatenated array is ok. ???
2009
2010       Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
2011
2012       --  Construct list of arguments for the function call
2013
2014       Params := New_List;
2015       Operand  := First (Opnds);
2016       for I in 1 .. Nb_Opnds loop
2017          Append_To (Params, Relocate_Node (Operand));
2018          Next (Operand);
2019       end loop;
2020
2021       --  Insert the function call
2022
2023       Rewrite
2024         (Cnode,
2025          Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
2026
2027       Analyze_And_Resolve (Cnode, Base_Typ);
2028       Set_Is_Inlined (Func_Id);
2029    end Expand_Concatenate_Other;
2030
2031    -------------------------------
2032    -- Expand_Concatenate_String --
2033    -------------------------------
2034
2035    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
2036       Loc   : constant Source_Ptr := Sloc (Cnode);
2037       Opnd1 : constant Node_Id    := First (Opnds);
2038       Opnd2 : constant Node_Id    := Next (Opnd1);
2039       Typ1  : constant Entity_Id  := Base_Type (Etype (Opnd1));
2040       Typ2  : constant Entity_Id  := Base_Type (Etype (Opnd2));
2041
2042       R : RE_Id;
2043       --  RE_Id value for function to be called
2044
2045    begin
2046       --  In all cases, we build a call to a routine giving the list of
2047       --  arguments as the parameter list to the routine.
2048
2049       case List_Length (Opnds) is
2050          when 2 =>
2051             if Typ1 = Standard_Character then
2052                if Typ2 = Standard_Character then
2053                   R := RE_Str_Concat_CC;
2054
2055                else
2056                   pragma Assert (Typ2 = Standard_String);
2057                   R := RE_Str_Concat_CS;
2058                end if;
2059
2060             elsif Typ1 = Standard_String then
2061                if Typ2 = Standard_Character then
2062                   R := RE_Str_Concat_SC;
2063
2064                else
2065                   pragma Assert (Typ2 = Standard_String);
2066                   R := RE_Str_Concat;
2067                end if;
2068
2069             --  If we have anything other than Standard_Character or
2070             --  Standard_String, then we must have had a serious error
2071             --  earlier, so we just abandon the attempt at expansion.
2072
2073             else
2074                pragma Assert (Serious_Errors_Detected > 0);
2075                return;
2076             end if;
2077
2078          when 3 =>
2079             R := RE_Str_Concat_3;
2080
2081          when 4 =>
2082             R := RE_Str_Concat_4;
2083
2084          when 5 =>
2085             R := RE_Str_Concat_5;
2086
2087          when others =>
2088             R := RE_Null;
2089             raise Program_Error;
2090       end case;
2091
2092       --  Now generate the appropriate call
2093
2094       Rewrite (Cnode,
2095         Make_Function_Call (Sloc (Cnode),
2096           Name => New_Occurrence_Of (RTE (R), Loc),
2097           Parameter_Associations => Opnds));
2098
2099       Analyze_And_Resolve (Cnode, Standard_String);
2100
2101    exception
2102       when RE_Not_Available =>
2103          return;
2104    end Expand_Concatenate_String;
2105
2106    ------------------------
2107    -- Expand_N_Allocator --
2108    ------------------------
2109
2110    procedure Expand_N_Allocator (N : Node_Id) is
2111       PtrT  : constant Entity_Id  := Etype (N);
2112       Desig : Entity_Id;
2113       Loc   : constant Source_Ptr := Sloc (N);
2114       Temp  : Entity_Id;
2115       Node  : Node_Id;
2116
2117    begin
2118       --  RM E.2.3(22). We enforce that the expected type of an allocator
2119       --  shall not be a remote access-to-class-wide-limited-private type
2120
2121       --  Why is this being done at expansion time, seems clearly wrong ???
2122
2123       Validate_Remote_Access_To_Class_Wide_Type (N);
2124
2125       --  Set the Storage Pool
2126
2127       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
2128
2129       if Present (Storage_Pool (N)) then
2130          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
2131             if not Java_VM then
2132                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
2133             end if;
2134
2135          elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
2136             Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
2137
2138          else
2139             Set_Procedure_To_Call (N,
2140               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
2141          end if;
2142       end if;
2143
2144       --  Under certain circumstances we can replace an allocator by an
2145       --  access to statically allocated storage. The conditions, as noted
2146       --  in AARM 3.10 (10c) are as follows:
2147
2148       --    Size and initial value is known at compile time
2149       --    Access type is access-to-constant
2150
2151       --  The allocator is not part of a constraint on a record component,
2152       --  because in that case the inserted actions are delayed until the
2153       --  record declaration is fully analyzed, which is too late for the
2154       --  analysis of the rewritten allocator.
2155
2156       if Is_Access_Constant (PtrT)
2157         and then Nkind (Expression (N)) = N_Qualified_Expression
2158         and then Compile_Time_Known_Value (Expression (Expression (N)))
2159         and then Size_Known_At_Compile_Time (Etype (Expression
2160                                                     (Expression (N))))
2161         and then not Is_Record_Type (Current_Scope)
2162       then
2163          --  Here we can do the optimization. For the allocator
2164
2165          --    new x'(y)
2166
2167          --  We insert an object declaration
2168
2169          --    Tnn : aliased x := y;
2170
2171          --  and replace the allocator by Tnn'Unrestricted_Access.
2172          --  Tnn is marked as requiring static allocation.
2173
2174          Temp :=
2175            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2176
2177          Desig := Subtype_Mark (Expression (N));
2178
2179          --  If context is constrained, use constrained subtype directly,
2180          --  so that the constant is not labelled as having a nomimally
2181          --  unconstrained subtype.
2182
2183          if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
2184             Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
2185          end if;
2186
2187          Insert_Action (N,
2188            Make_Object_Declaration (Loc,
2189              Defining_Identifier => Temp,
2190              Aliased_Present     => True,
2191              Constant_Present    => Is_Access_Constant (PtrT),
2192              Object_Definition   => Desig,
2193              Expression          => Expression (Expression (N))));
2194
2195          Rewrite (N,
2196            Make_Attribute_Reference (Loc,
2197              Prefix => New_Occurrence_Of (Temp, Loc),
2198              Attribute_Name => Name_Unrestricted_Access));
2199
2200          Analyze_And_Resolve (N, PtrT);
2201
2202          --  We set the variable as statically allocated, since we don't
2203          --  want it going on the stack of the current procedure!
2204
2205          Set_Is_Statically_Allocated (Temp);
2206          return;
2207       end if;
2208
2209       if Nkind (Expression (N)) = N_Qualified_Expression then
2210          Expand_Allocator_Expression (N);
2211
2212          --  If the allocator is for a type which requires initialization, and
2213          --  there is no initial value (i.e. operand is a subtype indication
2214          --  rather than a qualifed expression), then we must generate a call
2215          --  to the initialization routine. This is done using an expression
2216          --  actions node:
2217          --
2218          --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2219          --
2220          --  Here ptr_T is the pointer type for the allocator, and T is the
2221          --  subtype of the allocator. A special case arises if the designated
2222          --  type of the access type is a task or contains tasks. In this case
2223          --  the call to Init (Temp.all ...) is replaced by code that ensures
2224          --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2225          --  for details). In addition, if the type T is a task T, then the
2226          --  first argument to Init must be converted to the task record type.
2227
2228       else
2229          declare
2230             T         : constant Entity_Id  := Entity (Expression (N));
2231             Init      : Entity_Id;
2232             Arg1      : Node_Id;
2233             Args      : List_Id;
2234             Decls     : List_Id;
2235             Decl      : Node_Id;
2236             Discr     : Elmt_Id;
2237             Flist     : Node_Id;
2238             Temp_Decl : Node_Id;
2239             Temp_Type : Entity_Id;
2240
2241          begin
2242
2243             if No_Initialization (N) then
2244                null;
2245
2246             --  Case of no initialization procedure present
2247
2248             elsif not Has_Non_Null_Base_Init_Proc (T) then
2249
2250                --  Case of simple initialization required
2251
2252                if Needs_Simple_Initialization (T) then
2253                   Rewrite (Expression (N),
2254                     Make_Qualified_Expression (Loc,
2255                       Subtype_Mark => New_Occurrence_Of (T, Loc),
2256                       Expression   => Get_Simple_Init_Val (T, Loc)));
2257
2258                   Analyze_And_Resolve (Expression (Expression (N)), T);
2259                   Analyze_And_Resolve (Expression (N), T);
2260                   Set_Paren_Count (Expression (Expression (N)), 1);
2261                   Expand_N_Allocator (N);
2262
2263                --  No initialization required
2264
2265                else
2266                   null;
2267                end if;
2268
2269             --  Case of initialization procedure present, must be called
2270
2271             else
2272                Init := Base_Init_Proc (T);
2273                Node := N;
2274                Temp :=
2275                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2276
2277                --  Construct argument list for the initialization routine call
2278                --  The CPP constructor needs the address directly
2279
2280                if Is_CPP_Class (T) then
2281                   Arg1 := New_Reference_To (Temp, Loc);
2282                   Temp_Type := T;
2283
2284                else
2285                   Arg1 :=
2286                     Make_Explicit_Dereference (Loc,
2287                       Prefix => New_Reference_To (Temp, Loc));
2288                   Set_Assignment_OK (Arg1);
2289                   Temp_Type := PtrT;
2290
2291                   --  The initialization procedure expects a specific type.
2292                   --  if the context is access to class wide, indicate that
2293                   --  the object being allocated has the right specific type.
2294
2295                   if Is_Class_Wide_Type (Designated_Type (PtrT)) then
2296                      Arg1 := Unchecked_Convert_To (T, Arg1);
2297                   end if;
2298                end if;
2299
2300                --  If designated type is a concurrent type or if it is a
2301                --  private type whose definition is a concurrent type,
2302                --  the first argument in the Init routine has to be
2303                --  unchecked conversion to the corresponding record type.
2304                --  If the designated type is a derived type, we also
2305                --  convert the argument to its root type.
2306
2307                if Is_Concurrent_Type (T) then
2308                   Arg1 :=
2309                     Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
2310
2311                elsif Is_Private_Type (T)
2312                  and then Present (Full_View (T))
2313                  and then Is_Concurrent_Type (Full_View (T))
2314                then
2315                   Arg1 :=
2316                     Unchecked_Convert_To
2317                       (Corresponding_Record_Type (Full_View (T)), Arg1);
2318
2319                elsif Etype (First_Formal (Init)) /= Base_Type (T) then
2320
2321                   declare
2322                      Ftyp : constant Entity_Id := Etype (First_Formal (Init));
2323
2324                   begin
2325                      Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
2326                      Set_Etype (Arg1, Ftyp);
2327                   end;
2328                end if;
2329
2330                Args := New_List (Arg1);
2331
2332                --  For the task case, pass the Master_Id of the access type
2333                --  as the value of the _Master parameter, and _Chain as the
2334                --  value of the _Chain parameter (_Chain will be defined as
2335                --  part of the generated code for the allocator).
2336
2337                if Has_Task (T) then
2338
2339                   if No (Master_Id (Base_Type (PtrT))) then
2340
2341                      --  The designated type was an incomplete type, and
2342                      --  the access type did not get expanded. Salvage
2343                      --  it now.
2344
2345                      Expand_N_Full_Type_Declaration
2346                        (Parent (Base_Type (PtrT)));
2347                   end if;
2348
2349                   --  If the context of the allocator is a declaration or
2350                   --  an assignment, we can generate a meaningful image for
2351                   --  it, even though subsequent assignments might remove
2352                   --  the connection between task and entity. We build this
2353                   --  image when the left-hand side is a simple variable,
2354                   --  a simple indexed assignment or a simple selected
2355                   --  component.
2356
2357                   if Nkind (Parent (N)) = N_Assignment_Statement then
2358                      declare
2359                         Nam : constant Node_Id := Name (Parent (N));
2360
2361                      begin
2362                         if Is_Entity_Name (Nam) then
2363                            Decls :=
2364                              Build_Task_Image_Decls (
2365                                Loc,
2366                                  New_Occurrence_Of
2367                                    (Entity (Nam), Sloc (Nam)), T);
2368
2369                         elsif (Nkind (Nam) = N_Indexed_Component
2370                                 or else Nkind (Nam) = N_Selected_Component)
2371                           and then Is_Entity_Name (Prefix (Nam))
2372                         then
2373                            Decls :=
2374                              Build_Task_Image_Decls
2375                                (Loc, Nam, Etype (Prefix (Nam)));
2376                         else
2377                            Decls := Build_Task_Image_Decls (Loc, T, T);
2378                         end if;
2379                      end;
2380
2381                   elsif Nkind (Parent (N)) = N_Object_Declaration then
2382                      Decls :=
2383                        Build_Task_Image_Decls (
2384                           Loc, Defining_Identifier (Parent (N)), T);
2385
2386                   else
2387                      Decls := Build_Task_Image_Decls (Loc, T, T);
2388                   end if;
2389
2390                   Append_To (Args,
2391                     New_Reference_To
2392                       (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
2393                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
2394
2395                   Decl := Last (Decls);
2396                   Append_To (Args,
2397                     New_Occurrence_Of (Defining_Identifier (Decl), Loc));
2398
2399                --  Has_Task is false, Decls not used
2400
2401                else
2402                   Decls := No_List;
2403                end if;
2404
2405                --  Add discriminants if discriminated type
2406
2407                if Has_Discriminants (T) then
2408                   Discr := First_Elmt (Discriminant_Constraint (T));
2409
2410                   while Present (Discr) loop
2411                      Append (New_Copy_Tree (Elists.Node (Discr)), Args);
2412                      Next_Elmt (Discr);
2413                   end loop;
2414
2415                elsif Is_Private_Type (T)
2416                  and then Present (Full_View (T))
2417                  and then Has_Discriminants (Full_View (T))
2418                then
2419                   Discr :=
2420                     First_Elmt (Discriminant_Constraint (Full_View (T)));
2421
2422                   while Present (Discr) loop
2423                      Append (New_Copy_Tree (Elists.Node (Discr)), Args);
2424                      Next_Elmt (Discr);
2425                   end loop;
2426                end if;
2427
2428                --  We set the allocator as analyzed so that when we analyze the
2429                --  expression actions node, we do not get an unwanted recursive
2430                --  expansion of the allocator expression.
2431
2432                Set_Analyzed (N, True);
2433                Node := Relocate_Node (N);
2434
2435                --  Here is the transformation:
2436                --    input:  new T
2437                --    output: Temp : constant ptr_T := new T;
2438                --            Init (Temp.all, ...);
2439                --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
2440                --    <CTRL>  Initialize (Finalizable (Temp.all));
2441
2442                --  Here ptr_T is the pointer type for the allocator, and T
2443                --  is the subtype of the allocator.
2444
2445                Temp_Decl :=
2446                  Make_Object_Declaration (Loc,
2447                    Defining_Identifier => Temp,
2448                    Constant_Present    => True,
2449                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
2450                    Expression          => Node);
2451
2452                Set_Assignment_OK (Temp_Decl);
2453
2454                if Is_CPP_Class (T) then
2455                   Set_Aliased_Present (Temp_Decl);
2456                end if;
2457
2458                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
2459
2460                --  If the designated type is task type or contains tasks,
2461                --  Create block to activate created tasks, and insert
2462                --  declaration for Task_Image variable ahead of call.
2463
2464                if Has_Task (T) then
2465                   declare
2466                      L   : constant List_Id := New_List;
2467                      Blk : Node_Id;
2468
2469                   begin
2470                      Build_Task_Allocate_Block (L, Node, Args);
2471                      Blk := Last (L);
2472
2473                      Insert_List_Before (First (Declarations (Blk)), Decls);
2474                      Insert_Actions (N, L);
2475                   end;
2476
2477                else
2478                   Insert_Action (N,
2479                     Make_Procedure_Call_Statement (Loc,
2480                       Name => New_Reference_To (Init, Loc),
2481                       Parameter_Associations => Args));
2482                end if;
2483
2484                if Controlled_Type (T) then
2485                   Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
2486
2487                   Insert_Actions (N,
2488                     Make_Init_Call (
2489                       Ref          => New_Copy_Tree (Arg1),
2490                       Typ          => T,
2491                       Flist_Ref    => Flist,
2492                       With_Attach  => Make_Integer_Literal (Loc, 2)));
2493                end if;
2494
2495                if Is_CPP_Class (T) then
2496                   Rewrite (N,
2497                     Make_Attribute_Reference (Loc,
2498                       Prefix => New_Reference_To (Temp, Loc),
2499                       Attribute_Name => Name_Unchecked_Access));
2500                else
2501                   Rewrite (N, New_Reference_To (Temp, Loc));
2502                end if;
2503
2504                Analyze_And_Resolve (N, PtrT);
2505             end if;
2506          end;
2507       end if;
2508
2509    exception
2510       when RE_Not_Available =>
2511          return;
2512    end Expand_N_Allocator;
2513
2514    -----------------------
2515    -- Expand_N_And_Then --
2516    -----------------------
2517
2518    --  Expand into conditional expression if Actions present, and also
2519    --  deal with optimizing case of arguments being True or False.
2520
2521    procedure Expand_N_And_Then (N : Node_Id) is
2522       Loc     : constant Source_Ptr := Sloc (N);
2523       Typ     : constant Entity_Id  := Etype (N);
2524       Left    : constant Node_Id    := Left_Opnd (N);
2525       Right   : constant Node_Id    := Right_Opnd (N);
2526       Actlist : List_Id;
2527
2528    begin
2529       --  Deal with non-standard booleans
2530
2531       if Is_Boolean_Type (Typ) then
2532          Adjust_Condition (Left);
2533          Adjust_Condition (Right);
2534          Set_Etype (N, Standard_Boolean);
2535       end if;
2536
2537       --  Check for cases of left argument is True or False
2538
2539       if Nkind (Left) = N_Identifier then
2540
2541          --  If left argument is True, change (True and then Right) to Right.
2542          --  Any actions associated with Right will be executed unconditionally
2543          --  and can thus be inserted into the tree unconditionally.
2544
2545          if Entity (Left) = Standard_True then
2546             if Present (Actions (N)) then
2547                Insert_Actions (N, Actions (N));
2548             end if;
2549
2550             Rewrite (N, Right);
2551             Adjust_Result_Type (N, Typ);
2552             return;
2553
2554          --  If left argument is False, change (False and then Right) to
2555          --  False. In this case we can forget the actions associated with
2556          --  Right, since they will never be executed.
2557
2558          elsif Entity (Left) = Standard_False then
2559             Kill_Dead_Code (Right);
2560             Kill_Dead_Code (Actions (N));
2561             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2562             Adjust_Result_Type (N, Typ);
2563             return;
2564          end if;
2565       end if;
2566
2567       --  If Actions are present, we expand
2568
2569       --     left and then right
2570
2571       --  into
2572
2573       --     if left then right else false end
2574
2575       --  with the actions becoming the Then_Actions of the conditional
2576       --  expression. This conditional expression is then further expanded
2577       --  (and will eventually disappear)
2578
2579       if Present (Actions (N)) then
2580          Actlist := Actions (N);
2581          Rewrite (N,
2582             Make_Conditional_Expression (Loc,
2583               Expressions => New_List (
2584                 Left,
2585                 Right,
2586                 New_Occurrence_Of (Standard_False, Loc))));
2587
2588          Set_Then_Actions (N, Actlist);
2589          Analyze_And_Resolve (N, Standard_Boolean);
2590          Adjust_Result_Type (N, Typ);
2591          return;
2592       end if;
2593
2594       --  No actions present, check for cases of right argument True/False
2595
2596       if Nkind (Right) = N_Identifier then
2597
2598          --  Change (Left and then True) to Left. Note that we know there
2599          --  are no actions associated with the True operand, since we
2600          --  just checked for this case above.
2601
2602          if Entity (Right) = Standard_True then
2603             Rewrite (N, Left);
2604
2605          --  Change (Left and then False) to False, making sure to preserve
2606          --  any side effects associated with the Left operand.
2607
2608          elsif Entity (Right) = Standard_False then
2609             Remove_Side_Effects (Left);
2610             Rewrite
2611               (N, New_Occurrence_Of (Standard_False, Loc));
2612          end if;
2613       end if;
2614
2615       Adjust_Result_Type (N, Typ);
2616    end Expand_N_And_Then;
2617
2618    -------------------------------------
2619    -- Expand_N_Conditional_Expression --
2620    -------------------------------------
2621
2622    --  Expand into expression actions if then/else actions present
2623
2624    procedure Expand_N_Conditional_Expression (N : Node_Id) is
2625       Loc    : constant Source_Ptr := Sloc (N);
2626       Cond   : constant Node_Id    := First (Expressions (N));
2627       Thenx  : constant Node_Id    := Next (Cond);
2628       Elsex  : constant Node_Id    := Next (Thenx);
2629       Typ    : constant Entity_Id  := Etype (N);
2630       Cnn    : Entity_Id;
2631       New_If : Node_Id;
2632
2633    begin
2634       --  If either then or else actions are present, then given:
2635
2636       --     if cond then then-expr else else-expr end
2637
2638       --  we insert the following sequence of actions (using Insert_Actions):
2639
2640       --      Cnn : typ;
2641       --      if cond then
2642       --         <<then actions>>
2643       --         Cnn := then-expr;
2644       --      else
2645       --         <<else actions>>
2646       --         Cnn := else-expr
2647       --      end if;
2648
2649       --  and replace the conditional expression by a reference to Cnn.
2650
2651       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
2652          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2653
2654          New_If :=
2655            Make_Implicit_If_Statement (N,
2656              Condition => Relocate_Node (Cond),
2657
2658              Then_Statements => New_List (
2659                Make_Assignment_Statement (Sloc (Thenx),
2660                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
2661                  Expression => Relocate_Node (Thenx))),
2662
2663              Else_Statements => New_List (
2664                Make_Assignment_Statement (Sloc (Elsex),
2665                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
2666                  Expression => Relocate_Node (Elsex))));
2667
2668          Set_Assignment_OK (Name (First (Then_Statements (New_If))));
2669          Set_Assignment_OK (Name (First (Else_Statements (New_If))));
2670
2671          if Present (Then_Actions (N)) then
2672             Insert_List_Before
2673               (First (Then_Statements (New_If)), Then_Actions (N));
2674          end if;
2675
2676          if Present (Else_Actions (N)) then
2677             Insert_List_Before
2678               (First (Else_Statements (New_If)), Else_Actions (N));
2679          end if;
2680
2681          Rewrite (N, New_Occurrence_Of (Cnn, Loc));
2682
2683          Insert_Action (N,
2684            Make_Object_Declaration (Loc,
2685              Defining_Identifier => Cnn,
2686              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
2687
2688          Insert_Action (N, New_If);
2689          Analyze_And_Resolve (N, Typ);
2690       end if;
2691    end Expand_N_Conditional_Expression;
2692
2693    -----------------------------------
2694    -- Expand_N_Explicit_Dereference --
2695    -----------------------------------
2696
2697    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
2698    begin
2699       --  The only processing required is an insertion of an explicit
2700       --  dereference call for the checked storage pool case.
2701
2702       Insert_Dereference_Action (Prefix (N));
2703    end Expand_N_Explicit_Dereference;
2704
2705    -----------------
2706    -- Expand_N_In --
2707    -----------------
2708
2709    procedure Expand_N_In (N : Node_Id) is
2710       Loc  : constant Source_Ptr := Sloc (N);
2711       Rtyp : constant Entity_Id  := Etype (N);
2712       Lop  : constant Node_Id    := Left_Opnd (N);
2713       Rop  : constant Node_Id    := Right_Opnd (N);
2714
2715    begin
2716       --  If we have an explicit range, do a bit of optimization based
2717       --  on range analysis (we may be able to kill one or both checks).
2718
2719       if Nkind (Rop) = N_Range then
2720          declare
2721             Lcheck : constant Compare_Result :=
2722                        Compile_Time_Compare (Lop, Low_Bound (Rop));
2723             Ucheck : constant Compare_Result :=
2724                        Compile_Time_Compare (Lop, High_Bound (Rop));
2725
2726          begin
2727             --  If either check is known to fail, replace result
2728             --  by False, since the other check does not matter.
2729
2730             if Lcheck = LT or else Ucheck = GT then
2731                Rewrite (N,
2732                  New_Reference_To (Standard_False, Loc));
2733                Analyze_And_Resolve (N, Rtyp);
2734                return;
2735
2736             --  If both checks are known to succeed, replace result
2737             --  by True, since we know we are in range.
2738
2739             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
2740                Rewrite (N,
2741                  New_Reference_To (Standard_True, Loc));
2742                Analyze_And_Resolve (N, Rtyp);
2743                return;
2744
2745             --  If lower bound check succeeds and upper bound check is
2746             --  not known to succeed or fail, then replace the range check
2747             --  with a comparison against the upper bound.
2748
2749             elsif Lcheck in Compare_GE then
2750                Rewrite (N,
2751                  Make_Op_Le (Loc,
2752                    Left_Opnd  => Lop,
2753                    Right_Opnd => High_Bound (Rop)));
2754                Analyze_And_Resolve (N, Rtyp);
2755                return;
2756
2757             --  If upper bound check succeeds and lower bound check is
2758             --  not known to succeed or fail, then replace the range check
2759             --  with a comparison against the lower bound.
2760
2761             elsif Ucheck in Compare_LE then
2762                Rewrite (N,
2763                  Make_Op_Ge (Loc,
2764                    Left_Opnd  => Lop,
2765                    Right_Opnd => Low_Bound (Rop)));
2766                Analyze_And_Resolve (N, Rtyp);
2767                return;
2768             end if;
2769          end;
2770
2771          --  For all other cases of an explicit range, nothing to be done
2772
2773          return;
2774
2775       --  Here right operand is a subtype mark
2776
2777       else
2778          declare
2779             Typ    : Entity_Id        := Etype (Rop);
2780             Is_Acc : constant Boolean := Is_Access_Type (Typ);
2781             Obj    : Node_Id          := Lop;
2782             Cond   : Node_Id          := Empty;
2783
2784          begin
2785             Remove_Side_Effects (Obj);
2786
2787             --  For tagged type, do tagged membership operation
2788
2789             if Is_Tagged_Type (Typ) then
2790
2791                --  No expansion will be performed when Java_VM, as the
2792                --  JVM back end will handle the membership tests directly
2793                --  (tags are not explicitly represented in Java objects,
2794                --  so the normal tagged membership expansion is not what
2795                --  we want).
2796
2797                if not Java_VM then
2798                   Rewrite (N, Tagged_Membership (N));
2799                   Analyze_And_Resolve (N, Rtyp);
2800                end if;
2801
2802                return;
2803
2804             --  If type is scalar type, rewrite as x in t'first .. t'last
2805             --  This reason we do this is that the bounds may have the wrong
2806             --  type if they come from the original type definition.
2807
2808             elsif Is_Scalar_Type (Typ) then
2809                Rewrite (Rop,
2810                  Make_Range (Loc,
2811                    Low_Bound =>
2812                      Make_Attribute_Reference (Loc,
2813                        Attribute_Name => Name_First,
2814                        Prefix => New_Reference_To (Typ, Loc)),
2815
2816                    High_Bound =>
2817                      Make_Attribute_Reference (Loc,
2818                        Attribute_Name => Name_Last,
2819                        Prefix => New_Reference_To (Typ, Loc))));
2820                Analyze_And_Resolve (N, Rtyp);
2821                return;
2822             end if;
2823
2824             --  Here we have a non-scalar type
2825
2826             if Is_Acc then
2827                Typ := Designated_Type (Typ);
2828             end if;
2829
2830             if not Is_Constrained (Typ) then
2831                Rewrite (N,
2832                  New_Reference_To (Standard_True, Loc));
2833                Analyze_And_Resolve (N, Rtyp);
2834
2835             --  For the constrained array case, we have to check the
2836             --  subscripts for an exact match if the lengths are
2837             --  non-zero (the lengths must match in any case).
2838
2839             elsif Is_Array_Type (Typ) then
2840
2841                Check_Subscripts : declare
2842                   function Construct_Attribute_Reference
2843                     (E    : Node_Id;
2844                      Nam  : Name_Id;
2845                      Dim  : Nat)
2846                      return Node_Id;
2847                   --  Build attribute reference E'Nam(Dim)
2848
2849                   -----------------------------------
2850                   -- Construct_Attribute_Reference --
2851                   -----------------------------------
2852
2853                   function Construct_Attribute_Reference
2854                     (E    : Node_Id;
2855                      Nam  : Name_Id;
2856                      Dim  : Nat)
2857                      return Node_Id
2858                   is
2859                   begin
2860                      return
2861                        Make_Attribute_Reference (Loc,
2862                          Prefix => E,
2863                          Attribute_Name => Nam,
2864                          Expressions => New_List (
2865                            Make_Integer_Literal (Loc, Dim)));
2866                   end Construct_Attribute_Reference;
2867
2868                --  Start processing for Check_Subscripts
2869
2870                begin
2871                   for J in 1 .. Number_Dimensions (Typ) loop
2872                      Evolve_And_Then (Cond,
2873                        Make_Op_Eq (Loc,
2874                          Left_Opnd  =>
2875                            Construct_Attribute_Reference
2876                              (Duplicate_Subexpr_No_Checks (Obj),
2877                               Name_First, J),
2878                          Right_Opnd =>
2879                            Construct_Attribute_Reference
2880                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
2881
2882                      Evolve_And_Then (Cond,
2883                        Make_Op_Eq (Loc,
2884                          Left_Opnd  =>
2885                            Construct_Attribute_Reference
2886                              (Duplicate_Subexpr_No_Checks (Obj),
2887                               Name_Last, J),
2888                          Right_Opnd =>
2889                            Construct_Attribute_Reference
2890                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
2891                   end loop;
2892
2893                   if Is_Acc then
2894                      Cond :=
2895                        Make_Or_Else (Loc,
2896                          Left_Opnd =>
2897                            Make_Op_Eq (Loc,
2898                              Left_Opnd  => Obj,
2899                              Right_Opnd => Make_Null (Loc)),
2900                          Right_Opnd => Cond);
2901                   end if;
2902
2903                   Rewrite (N, Cond);
2904                   Analyze_And_Resolve (N, Rtyp);
2905                end Check_Subscripts;
2906
2907             --  These are the cases where constraint checks may be
2908             --  required, e.g. records with possible discriminants
2909
2910             else
2911                --  Expand the test into a series of discriminant comparisons.
2912                --  The expression that is built is the negation of the one
2913                --  that is used for checking discriminant constraints.
2914
2915                Obj := Relocate_Node (Left_Opnd (N));
2916
2917                if Has_Discriminants (Typ) then
2918                   Cond := Make_Op_Not (Loc,
2919                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
2920
2921                   if Is_Acc then
2922                      Cond := Make_Or_Else (Loc,
2923                        Left_Opnd =>
2924                          Make_Op_Eq (Loc,
2925                            Left_Opnd  => Obj,
2926                            Right_Opnd => Make_Null (Loc)),
2927                        Right_Opnd => Cond);
2928                   end if;
2929
2930                else
2931                   Cond := New_Occurrence_Of (Standard_True, Loc);
2932                end if;
2933
2934                Rewrite (N, Cond);
2935                Analyze_And_Resolve (N, Rtyp);
2936             end if;
2937          end;
2938       end if;
2939    end Expand_N_In;
2940
2941    --------------------------------
2942    -- Expand_N_Indexed_Component --
2943    --------------------------------
2944
2945    procedure Expand_N_Indexed_Component (N : Node_Id) is
2946       Loc : constant Source_Ptr := Sloc (N);
2947       Typ : constant Entity_Id  := Etype (N);
2948       P   : constant Node_Id    := Prefix (N);
2949       T   : constant Entity_Id  := Etype (P);
2950
2951    begin
2952       --  A special optimization, if we have an indexed component that
2953       --  is selecting from a slice, then we can eliminate the slice,
2954       --  since, for example, x (i .. j)(k) is identical to x(k). The
2955       --  only difference is the range check required by the slice. The
2956       --  range check for the slice itself has already been generated.
2957       --  The range check for the subscripting operation is ensured
2958       --  by converting the subject to the subtype of the slice.
2959
2960       --  This optimization not only generates better code, avoiding
2961       --  slice messing especially in the packed case, but more importantly
2962       --  bypasses some problems in handling this peculiar case, for
2963       --  example, the issue of dealing specially with object renamings.
2964
2965       if Nkind (P) = N_Slice then
2966          Rewrite (N,
2967            Make_Indexed_Component (Loc,
2968              Prefix => Prefix (P),
2969              Expressions => New_List (
2970                Convert_To
2971                  (Etype (First_Index (Etype (P))),
2972                   First (Expressions (N))))));
2973          Analyze_And_Resolve (N, Typ);
2974          return;
2975       end if;
2976
2977       --  If the prefix is an access type, then we unconditionally rewrite
2978       --  if as an explicit deference. This simplifies processing for several
2979       --  cases, including packed array cases and certain cases in which
2980       --  checks must be generated. We used to try to do this only when it
2981       --  was necessary, but it cleans up the code to do it all the time.
2982
2983       if Is_Access_Type (T) then
2984
2985          --  Check whether the prefix comes from a debug pool, and generate
2986          --  the check before rewriting.
2987
2988          Insert_Dereference_Action (P);
2989
2990          Rewrite (P,
2991            Make_Explicit_Dereference (Sloc (N),
2992              Prefix => Relocate_Node (P)));
2993          Analyze_And_Resolve (P, Designated_Type (T));
2994       end if;
2995
2996       --  Generate index and validity checks
2997
2998       Generate_Index_Checks (N);
2999
3000       if Validity_Checks_On and then Validity_Check_Subscripts then
3001          Apply_Subscript_Validity_Checks (N);
3002       end if;
3003
3004       --  All done for the non-packed case
3005
3006       if not Is_Packed (Etype (Prefix (N))) then
3007          return;
3008       end if;
3009
3010       --  For packed arrays that are not bit-packed (i.e. the case of an array
3011       --  with one or more index types with a non-coniguous enumeration type),
3012       --  we can always use the normal packed element get circuit.
3013
3014       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
3015          Expand_Packed_Element_Reference (N);
3016          return;
3017       end if;
3018
3019       --  For a reference to a component of a bit packed array, we have to
3020       --  convert it to a reference to the corresponding Packed_Array_Type.
3021       --  We only want to do this for simple references, and not for:
3022
3023       --    Left side of assignment, or prefix of left side of assignment,
3024       --    or prefix of the prefix, to handle packed arrays of packed arrays,
3025       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3026
3027       --    Renaming objects in renaming associations
3028       --      This case is handled when a use of the renamed variable occurs
3029
3030       --    Actual parameters for a procedure call
3031       --      This case is handled in Exp_Ch6.Expand_Actuals
3032
3033       --    The second expression in a 'Read attribute reference
3034
3035       --    The prefix of an address or size attribute reference
3036
3037       --  The following circuit detects these exceptions
3038
3039       declare
3040          Child : Node_Id := N;
3041          Parnt : Node_Id := Parent (N);
3042
3043       begin
3044          loop
3045             if Nkind (Parnt) = N_Unchecked_Expression then
3046                null;
3047
3048             elsif Nkind (Parnt) = N_Object_Renaming_Declaration
3049               or else Nkind (Parnt) = N_Procedure_Call_Statement
3050               or else (Nkind (Parnt) = N_Parameter_Association
3051                         and then
3052                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
3053             then
3054                return;
3055
3056             elsif Nkind (Parnt) = N_Attribute_Reference
3057               and then (Attribute_Name (Parnt) = Name_Address
3058                          or else
3059                         Attribute_Name (Parnt) = Name_Size)
3060               and then Prefix (Parnt) = Child
3061             then
3062                return;
3063
3064             elsif Nkind (Parnt) = N_Assignment_Statement
3065               and then Name (Parnt) = Child
3066             then
3067                return;
3068
3069             --  If the expression is an index of an indexed component,
3070             --  it must be expanded regardless of context.
3071
3072             elsif Nkind (Parnt) = N_Indexed_Component
3073               and then Child /= Prefix (Parnt)
3074             then
3075                Expand_Packed_Element_Reference (N);
3076                return;
3077
3078             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
3079               and then Name (Parent (Parnt)) = Parnt
3080             then
3081                return;
3082
3083             elsif Nkind (Parnt) = N_Attribute_Reference
3084               and then Attribute_Name (Parnt) = Name_Read
3085               and then Next (First (Expressions (Parnt))) = Child
3086             then
3087                return;
3088
3089             elsif (Nkind (Parnt) = N_Indexed_Component
3090                     or else Nkind (Parnt) = N_Selected_Component)
3091                and then Prefix (Parnt) = Child
3092             then
3093                null;
3094
3095             else
3096                Expand_Packed_Element_Reference (N);
3097                return;
3098             end if;
3099
3100             --  Keep looking up tree for unchecked expression, or if we are
3101             --  the prefix of a possible assignment left side.
3102
3103             Child := Parnt;
3104             Parnt := Parent (Child);
3105          end loop;
3106       end;
3107
3108    end Expand_N_Indexed_Component;
3109
3110    ---------------------
3111    -- Expand_N_Not_In --
3112    ---------------------
3113
3114    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
3115    --  can be done. This avoids needing to duplicate this expansion code.
3116
3117    procedure Expand_N_Not_In (N : Node_Id) is
3118       Loc  : constant Source_Ptr := Sloc (N);
3119       Typ  : constant Entity_Id  := Etype (N);
3120
3121    begin
3122       Rewrite (N,
3123         Make_Op_Not (Loc,
3124           Right_Opnd =>
3125             Make_In (Loc,
3126               Left_Opnd  => Left_Opnd (N),
3127               Right_Opnd => Right_Opnd (N))));
3128       Analyze_And_Resolve (N, Typ);
3129    end Expand_N_Not_In;
3130
3131    -------------------
3132    -- Expand_N_Null --
3133    -------------------
3134
3135    --  The only replacement required is for the case of a null of type
3136    --  that is an access to protected subprogram. We represent such
3137    --  access values as a record, and so we must replace the occurrence
3138    --  of null by the equivalent record (with a null address and a null
3139    --  pointer in it), so that the backend creates the proper value.
3140
3141    procedure Expand_N_Null (N : Node_Id) is
3142       Loc : constant Source_Ptr := Sloc (N);
3143       Typ : constant Entity_Id  := Etype (N);
3144       Agg : Node_Id;
3145
3146    begin
3147       if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
3148          Agg :=
3149            Make_Aggregate (Loc,
3150              Expressions => New_List (
3151                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
3152                Make_Null (Loc)));
3153
3154          Rewrite (N, Agg);
3155          Analyze_And_Resolve (N, Equivalent_Type (Typ));
3156
3157          --  For subsequent semantic analysis, the node must retain its
3158          --  type. Gigi in any case replaces this type by the corresponding
3159          --  record type before processing the node.
3160
3161          Set_Etype (N, Typ);
3162       end if;
3163
3164    exception
3165       when RE_Not_Available =>
3166          return;
3167    end Expand_N_Null;
3168
3169    ---------------------
3170    -- Expand_N_Op_Abs --
3171    ---------------------
3172
3173    procedure Expand_N_Op_Abs (N : Node_Id) is
3174       Loc  : constant Source_Ptr := Sloc (N);
3175       Expr : constant Node_Id := Right_Opnd (N);
3176
3177    begin
3178       Unary_Op_Validity_Checks (N);
3179
3180       --  Deal with software overflow checking
3181
3182       if not Backend_Overflow_Checks_On_Target
3183          and then Is_Signed_Integer_Type (Etype (N))
3184          and then Do_Overflow_Check (N)
3185       then
3186          --  The only case to worry about is when the argument is
3187          --  equal to the largest negative number, so what we do is
3188          --  to insert the check:
3189
3190          --     [constraint_error when Expr = typ'Base'First]
3191
3192          --  with the usual Duplicate_Subexpr use coding for expr
3193
3194          Insert_Action (N,
3195            Make_Raise_Constraint_Error (Loc,
3196              Condition =>
3197                Make_Op_Eq (Loc,
3198                  Left_Opnd  => Duplicate_Subexpr (Expr),
3199                  Right_Opnd =>
3200                    Make_Attribute_Reference (Loc,
3201                      Prefix =>
3202                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
3203                      Attribute_Name => Name_First)),
3204              Reason => CE_Overflow_Check_Failed));
3205       end if;
3206
3207       --  Vax floating-point types case
3208
3209       if Vax_Float (Etype (N)) then
3210          Expand_Vax_Arith (N);
3211       end if;
3212    end Expand_N_Op_Abs;
3213
3214    ---------------------
3215    -- Expand_N_Op_Add --
3216    ---------------------
3217
3218    procedure Expand_N_Op_Add (N : Node_Id) is
3219       Typ : constant Entity_Id := Etype (N);
3220
3221    begin
3222       Binary_Op_Validity_Checks (N);
3223
3224       --  N + 0 = 0 + N = N for integer types
3225
3226       if Is_Integer_Type (Typ) then
3227          if Compile_Time_Known_Value (Right_Opnd (N))
3228            and then Expr_Value (Right_Opnd (N)) = Uint_0
3229          then
3230             Rewrite (N, Left_Opnd (N));
3231             return;
3232
3233          elsif Compile_Time_Known_Value (Left_Opnd (N))
3234            and then Expr_Value (Left_Opnd (N)) = Uint_0
3235          then
3236             Rewrite (N, Right_Opnd (N));
3237             return;
3238          end if;
3239       end if;
3240
3241       --  Arithmetic overflow checks for signed integer/fixed point types
3242
3243       if Is_Signed_Integer_Type (Typ)
3244         or else Is_Fixed_Point_Type (Typ)
3245       then
3246          Apply_Arithmetic_Overflow_Check (N);
3247          return;
3248
3249       --  Vax floating-point types case
3250
3251       elsif Vax_Float (Typ) then
3252          Expand_Vax_Arith (N);
3253       end if;
3254    end Expand_N_Op_Add;
3255
3256    ---------------------
3257    -- Expand_N_Op_And --
3258    ---------------------
3259
3260    procedure Expand_N_Op_And (N : Node_Id) is
3261       Typ : constant Entity_Id := Etype (N);
3262
3263    begin
3264       Binary_Op_Validity_Checks (N);
3265
3266       if Is_Array_Type (Etype (N)) then
3267          Expand_Boolean_Operator (N);
3268
3269       elsif Is_Boolean_Type (Etype (N)) then
3270          Adjust_Condition (Left_Opnd (N));
3271          Adjust_Condition (Right_Opnd (N));
3272          Set_Etype (N, Standard_Boolean);
3273          Adjust_Result_Type (N, Typ);
3274       end if;
3275    end Expand_N_Op_And;
3276
3277    ------------------------
3278    -- Expand_N_Op_Concat --
3279    ------------------------
3280
3281    Max_Available_String_Operands : Int := -1;
3282    --  This is initialized the first time this routine is called. It records
3283    --  a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3284    --  available in the run-time:
3285    --
3286    --    0  None available
3287    --    2  RE_Str_Concat available, RE_Str_Concat_3 not available
3288    --    3  RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3289    --    4  RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3290    --    5  All routines including RE_Str_Concat_5 available
3291
3292    Char_Concat_Available : Boolean;
3293    --  Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3294    --  all three are available, False if any one of these is unavailable.
3295
3296    procedure Expand_N_Op_Concat (N : Node_Id) is
3297
3298       Opnds : List_Id;
3299       --  List of operands to be concatenated
3300
3301       Opnd  : Node_Id;
3302       --  Single operand for concatenation
3303
3304       Cnode : Node_Id;
3305       --  Node which is to be replaced by the result of concatenating
3306       --  the nodes in the list Opnds.
3307
3308       Atyp : Entity_Id;
3309       --  Array type of concatenation result type
3310
3311       Ctyp : Entity_Id;
3312       --  Component type of concatenation represented by Cnode
3313
3314    begin
3315       --  Initialize global variables showing run-time status
3316
3317       if Max_Available_String_Operands < 1 then
3318          if not RTE_Available (RE_Str_Concat) then
3319             Max_Available_String_Operands := 0;
3320          elsif not RTE_Available (RE_Str_Concat_3) then
3321             Max_Available_String_Operands := 2;
3322          elsif not RTE_Available (RE_Str_Concat_4) then
3323             Max_Available_String_Operands := 3;
3324          elsif not RTE_Available (RE_Str_Concat_5) then
3325             Max_Available_String_Operands := 4;
3326          else
3327             Max_Available_String_Operands := 5;
3328          end if;
3329
3330          Char_Concat_Available :=
3331            RTE_Available (RE_Str_Concat_CC)
3332              and then
3333            RTE_Available (RE_Str_Concat_CS)
3334              and then
3335            RTE_Available (RE_Str_Concat_SC);
3336       end if;
3337
3338       --  Ensure validity of both operands
3339
3340       Binary_Op_Validity_Checks (N);
3341
3342       --  If we are the left operand of a concatenation higher up the
3343       --  tree, then do nothing for now, since we want to deal with a
3344       --  series of concatenations as a unit.
3345
3346       if Nkind (Parent (N)) = N_Op_Concat
3347         and then N = Left_Opnd (Parent (N))
3348       then
3349          return;
3350       end if;
3351
3352       --  We get here with a concatenation whose left operand may be a
3353       --  concatenation itself with a consistent type. We need to process
3354       --  these concatenation operands from left to right, which means
3355       --  from the deepest node in the tree to the highest node.
3356
3357       Cnode := N;
3358       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
3359          Cnode := Left_Opnd (Cnode);
3360       end loop;
3361
3362       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
3363       --  nodes above, so now we process bottom up, doing the operations. We
3364       --  gather a string that is as long as possible up to five operands
3365
3366       --  The outer loop runs more than once if there are more than five
3367       --  concatenations of type Standard.String, the most we handle for
3368       --  this case, or if more than one concatenation type is involved.
3369
3370       Outer : loop
3371          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
3372          Set_Parent (Opnds, N);
3373
3374          --  The inner loop gathers concatenation operands. We gather any
3375          --  number of these in the non-string case, or if no concatenation
3376          --  routines are available for string (since in that case we will
3377          --  treat string like any other non-string case). Otherwise we only
3378          --  gather as many operands as can be handled by the available
3379          --  procedures in the run-time library (normally 5, but may be
3380          --  less for the configurable run-time case).
3381
3382          Inner : while Cnode /= N
3383                    and then (Base_Type (Etype (Cnode)) /= Standard_String
3384                                or else
3385                              Max_Available_String_Operands = 0
3386                                or else
3387                              List_Length (Opnds) <
3388                                                Max_Available_String_Operands)
3389                    and then Base_Type (Etype (Cnode)) =
3390                             Base_Type (Etype (Parent (Cnode)))
3391          loop
3392             Cnode := Parent (Cnode);
3393             Append (Right_Opnd (Cnode), Opnds);
3394          end loop Inner;
3395
3396          --  Here we process the collected operands. First we convert
3397          --  singleton operands to singleton aggregates. This is skipped
3398          --  however for the case of two operands of type String, since
3399          --  we have special routines for these cases.
3400
3401          Atyp := Base_Type (Etype (Cnode));
3402          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
3403
3404          if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
3405            or else not Char_Concat_Available
3406          then
3407             Opnd := First (Opnds);
3408             loop
3409                if Base_Type (Etype (Opnd)) = Ctyp then
3410                   Rewrite (Opnd,
3411                     Make_Aggregate (Sloc (Cnode),
3412                       Expressions => New_List (Relocate_Node (Opnd))));
3413                   Analyze_And_Resolve (Opnd, Atyp);
3414                end if;
3415
3416                Next (Opnd);
3417                exit when No (Opnd);
3418             end loop;
3419          end if;
3420
3421          --  Now call appropriate continuation routine
3422
3423          if Atyp = Standard_String
3424            and then Max_Available_String_Operands > 0
3425          then
3426             Expand_Concatenate_String (Cnode, Opnds);
3427          else
3428             Expand_Concatenate_Other (Cnode, Opnds);
3429          end if;
3430
3431          exit Outer when Cnode = N;
3432          Cnode := Parent (Cnode);
3433       end loop Outer;
3434    end Expand_N_Op_Concat;
3435
3436    ------------------------
3437    -- Expand_N_Op_Divide --
3438    ------------------------
3439
3440    procedure Expand_N_Op_Divide (N : Node_Id) is
3441       Loc  : constant Source_Ptr := Sloc (N);
3442       Ltyp : constant Entity_Id  := Etype (Left_Opnd (N));
3443       Rtyp : constant Entity_Id  := Etype (Right_Opnd (N));
3444       Typ  : Entity_Id           := Etype (N);
3445
3446    begin
3447       Binary_Op_Validity_Checks (N);
3448
3449       --  Vax_Float is a special case
3450
3451       if Vax_Float (Typ) then
3452          Expand_Vax_Arith (N);
3453          return;
3454       end if;
3455
3456       --  N / 1 = N for integer types
3457
3458       if Is_Integer_Type (Typ)
3459         and then Compile_Time_Known_Value (Right_Opnd (N))
3460         and then Expr_Value (Right_Opnd (N)) = Uint_1
3461       then
3462          Rewrite (N, Left_Opnd (N));
3463          return;
3464       end if;
3465
3466       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3467       --  Is_Power_Of_2_For_Shift is set means that we know that our left
3468       --  operand is an unsigned integer, as required for this to work.
3469
3470       if Nkind (Right_Opnd (N)) = N_Op_Expon
3471         and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
3472
3473       --  We cannot do this transformation in configurable run time mode if we
3474       --  have 64-bit --  integers and long shifts are not available.
3475
3476         and then
3477           (Esize (Ltyp) <= 32
3478              or else Support_Long_Shifts_On_Target)
3479       then
3480          Rewrite (N,
3481            Make_Op_Shift_Right (Loc,
3482              Left_Opnd  => Left_Opnd (N),
3483              Right_Opnd =>
3484                Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
3485          Analyze_And_Resolve (N, Typ);
3486          return;
3487       end if;
3488
3489       --  Do required fixup of universal fixed operation
3490
3491       if Typ = Universal_Fixed then
3492          Fixup_Universal_Fixed_Operation (N);
3493          Typ := Etype (N);
3494       end if;
3495
3496       --  Divisions with fixed-point results
3497
3498       if Is_Fixed_Point_Type (Typ) then
3499
3500          --  No special processing if Treat_Fixed_As_Integer is set,
3501          --  since from a semantic point of view such operations are
3502          --  simply integer operations and will be treated that way.
3503
3504          if not Treat_Fixed_As_Integer (N) then
3505             if Is_Integer_Type (Rtyp) then
3506                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
3507             else
3508                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
3509             end if;
3510          end if;
3511
3512       --  Other cases of division of fixed-point operands. Again we
3513       --  exclude the case where Treat_Fixed_As_Integer is set.
3514
3515       elsif (Is_Fixed_Point_Type (Ltyp) or else
3516              Is_Fixed_Point_Type (Rtyp))
3517         and then not Treat_Fixed_As_Integer (N)
3518       then
3519          if Is_Integer_Type (Typ) then
3520             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
3521          else
3522             pragma Assert (Is_Floating_Point_Type (Typ));
3523             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
3524          end if;
3525
3526       --  Mixed-mode operations can appear in a non-static universal
3527       --  context, in  which case the integer argument must be converted
3528       --  explicitly.
3529
3530       elsif Typ = Universal_Real
3531         and then Is_Integer_Type (Rtyp)
3532       then
3533          Rewrite (Right_Opnd (N),
3534            Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
3535
3536          Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
3537
3538       elsif Typ = Universal_Real
3539         and then Is_Integer_Type (Ltyp)
3540       then
3541          Rewrite (Left_Opnd (N),
3542            Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
3543
3544          Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
3545
3546       --  Non-fixed point cases, do zero divide and overflow checks
3547
3548       elsif Is_Integer_Type (Typ) then
3549          Apply_Divide_Check (N);
3550
3551          --  Check for 64-bit division available
3552
3553          if Esize (Ltyp) > 32
3554            and then not Support_64_Bit_Divides_On_Target
3555          then
3556             Error_Msg_CRT ("64-bit division", N);
3557          end if;
3558       end if;
3559    end Expand_N_Op_Divide;
3560
3561    --------------------
3562    -- Expand_N_Op_Eq --
3563    --------------------
3564
3565    procedure Expand_N_Op_Eq (N : Node_Id) is
3566       Loc    : constant Source_Ptr := Sloc (N);
3567       Typ    : constant Entity_Id  := Etype (N);
3568       Lhs    : constant Node_Id    := Left_Opnd (N);
3569       Rhs    : constant Node_Id    := Right_Opnd (N);
3570       Bodies : constant List_Id    := New_List;
3571       A_Typ  : constant Entity_Id  := Etype (Lhs);
3572
3573       Typl    : Entity_Id := A_Typ;
3574       Op_Name : Entity_Id;
3575       Prim    : Elmt_Id;
3576
3577       procedure Build_Equality_Call (Eq : Entity_Id);
3578       --  If a constructed equality exists for the type or for its parent,
3579       --  build and analyze call, adding conversions if the operation is
3580       --  inherited.
3581
3582       -------------------------
3583       -- Build_Equality_Call --
3584       -------------------------
3585
3586       procedure Build_Equality_Call (Eq : Entity_Id) is
3587          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
3588          L_Exp   : Node_Id := Relocate_Node (Lhs);
3589          R_Exp   : Node_Id := Relocate_Node (Rhs);
3590
3591       begin
3592          if Base_Type (Op_Type) /= Base_Type (A_Typ)
3593            and then not Is_Class_Wide_Type (A_Typ)
3594          then
3595             L_Exp := OK_Convert_To (Op_Type, L_Exp);
3596             R_Exp := OK_Convert_To (Op_Type, R_Exp);
3597          end if;
3598
3599          Rewrite (N,
3600            Make_Function_Call (Loc,
3601              Name => New_Reference_To (Eq, Loc),
3602              Parameter_Associations => New_List (L_Exp, R_Exp)));
3603
3604          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3605       end Build_Equality_Call;
3606
3607    --  Start of processing for Expand_N_Op_Eq
3608
3609    begin
3610       Binary_Op_Validity_Checks (N);
3611
3612       if Ekind (Typl) = E_Private_Type then
3613          Typl := Underlying_Type (Typl);
3614
3615       elsif Ekind (Typl) = E_Private_Subtype then
3616          Typl := Underlying_Type (Base_Type (Typl));
3617       end if;
3618
3619       --  It may happen in error situations that the underlying type is not
3620       --  set. The error will be detected later, here we just defend the
3621       --  expander code.
3622
3623       if No (Typl) then
3624          return;
3625       end if;
3626
3627       Typl := Base_Type (Typl);
3628
3629       --  Vax float types
3630
3631       if Vax_Float (Typl) then
3632          Expand_Vax_Comparison (N);
3633          return;
3634
3635       --  Boolean types (requiring handling of non-standard case)
3636
3637       elsif Is_Boolean_Type (Typl) then
3638          Adjust_Condition (Left_Opnd (N));
3639          Adjust_Condition (Right_Opnd (N));
3640          Set_Etype (N, Standard_Boolean);
3641          Adjust_Result_Type (N, Typ);
3642
3643       --  Array types
3644
3645       elsif Is_Array_Type (Typl) then
3646
3647          --  If we are doing full validity checking, then expand out array
3648          --  comparisons to make sure that we check the array elements.
3649
3650          if Validity_Check_Operands then
3651             declare
3652                Save_Force_Validity_Checks : constant Boolean :=
3653                                               Force_Validity_Checks;
3654             begin
3655                Force_Validity_Checks := True;
3656                Rewrite (N,
3657                  Expand_Array_Equality (N, Typl, A_Typ,
3658                    Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
3659
3660                Insert_Actions      (N, Bodies);
3661                Analyze_And_Resolve (N, Standard_Boolean);
3662                Force_Validity_Checks := Save_Force_Validity_Checks;
3663             end;
3664
3665          --  Packed case
3666
3667          elsif Is_Bit_Packed_Array (Typl) then
3668             Expand_Packed_Eq (N);
3669
3670          --  For non-floating-point elementary types, the primitive equality
3671          --  always applies, and block-bit comparison is fine. Floating-point
3672          --  is an exception because of negative zeroes.
3673
3674          elsif Is_Elementary_Type (Component_Type (Typl))
3675            and then not Is_Floating_Point_Type (Component_Type (Typl))
3676            and then Support_Composite_Compare_On_Target
3677          then
3678             null;
3679
3680          --  For composite and floating-point cases, expand equality loop
3681          --  to make sure of using proper comparisons for tagged types,
3682          --  and correctly handling the floating-point case.
3683
3684          else
3685             Rewrite (N,
3686               Expand_Array_Equality (N, Typl, A_Typ,
3687                 Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
3688
3689             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
3690             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3691          end if;
3692
3693       --  Record Types
3694
3695       elsif Is_Record_Type (Typl) then
3696
3697          --  For tagged types, use the primitive "="
3698
3699          if Is_Tagged_Type (Typl) then
3700
3701             --  If this is derived from an untagged private type completed
3702             --  with a tagged type, it does not have a full view, so we
3703             --  use the primitive operations of the private type.
3704             --  This check should no longer be necessary when these
3705             --  types receive their full views ???
3706
3707             if Is_Private_Type (A_Typ)
3708               and then not Is_Tagged_Type (A_Typ)
3709               and then Is_Derived_Type (A_Typ)
3710               and then No (Full_View (A_Typ))
3711             then
3712                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
3713
3714                while Chars (Node (Prim)) /= Name_Op_Eq loop
3715                   Next_Elmt (Prim);
3716                   pragma Assert (Present (Prim));
3717                end loop;
3718
3719                Op_Name := Node (Prim);
3720
3721             --  Find the type's predefined equality or an overriding
3722             --  user-defined equality. The reason for not simply calling
3723             --  Find_Prim_Op here is that there may be a user-defined
3724             --  overloaded equality op that precedes the equality that
3725             --  we want, so we have to explicitly search (e.g., there
3726             --  could be an equality with two different parameter types).
3727
3728             else
3729                if Is_Class_Wide_Type (Typl) then
3730                   Typl := Root_Type (Typl);
3731                end if;
3732
3733                Prim := First_Elmt (Primitive_Operations (Typl));
3734
3735                while Present (Prim) loop
3736                   exit when Chars (Node (Prim)) = Name_Op_Eq
3737                     and then Etype (First_Formal (Node (Prim))) =
3738                              Etype (Next_Formal (First_Formal (Node (Prim))))
3739                     and then
3740                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
3741
3742                   Next_Elmt (Prim);
3743                   pragma Assert (Present (Prim));
3744                end loop;
3745
3746                Op_Name := Node (Prim);
3747             end if;
3748
3749             Build_Equality_Call (Op_Name);
3750
3751          --  If a type support function is present (for complex cases), use it
3752
3753          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
3754             Build_Equality_Call
3755               (TSS (Root_Type (Typl), TSS_Composite_Equality));
3756
3757          --  Otherwise expand the component by component equality. Note that
3758          --  we never use block-bit coparisons for records, because of the
3759          --  problems with gaps. The backend will often be able to recombine
3760          --  the separate comparisons that we generate here.
3761
3762          else
3763             Remove_Side_Effects (Lhs);
3764             Remove_Side_Effects (Rhs);
3765             Rewrite (N,
3766               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
3767
3768             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
3769             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3770          end if;
3771       end if;
3772
3773       --  If we still have an equality comparison (i.e. it was not rewritten
3774       --  in some way), then we can test if result is needed at compile time).
3775
3776       if Nkind (N) = N_Op_Eq then
3777          Rewrite_Comparison (N);
3778       end if;
3779    end Expand_N_Op_Eq;
3780
3781    -----------------------
3782    -- Expand_N_Op_Expon --
3783    -----------------------
3784
3785    procedure Expand_N_Op_Expon (N : Node_Id) is
3786       Loc    : constant Source_Ptr := Sloc (N);
3787       Typ    : constant Entity_Id  := Etype (N);
3788       Rtyp   : constant Entity_Id  := Root_Type (Typ);
3789       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
3790       Bastyp : constant Node_Id    := Etype (Base);
3791       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
3792       Exptyp : constant Entity_Id  := Etype (Exp);
3793       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
3794       Expv   : Uint;
3795       Xnode  : Node_Id;
3796       Temp   : Node_Id;
3797       Rent   : RE_Id;
3798       Ent    : Entity_Id;
3799       Etyp   : Entity_Id;
3800
3801    begin
3802       Binary_Op_Validity_Checks (N);
3803
3804       --  If either operand is of a private type, then we have the use of
3805       --  an intrinsic operator, and we get rid of the privateness, by using
3806       --  root types of underlying types for the actual operation. Otherwise
3807       --  the private types will cause trouble if we expand multiplications
3808       --  or shifts etc. We also do this transformation if the result type
3809       --  is different from the base type.
3810
3811       if Is_Private_Type (Etype (Base))
3812            or else
3813          Is_Private_Type (Typ)
3814            or else
3815          Is_Private_Type (Exptyp)
3816            or else
3817          Rtyp /= Root_Type (Bastyp)
3818       then
3819          declare
3820             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
3821             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
3822
3823          begin
3824             Rewrite (N,
3825               Unchecked_Convert_To (Typ,
3826                 Make_Op_Expon (Loc,
3827                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
3828                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
3829             Analyze_And_Resolve (N, Typ);
3830             return;
3831          end;
3832       end if;
3833
3834       --  Test for case of known right argument
3835
3836       if Compile_Time_Known_Value (Exp) then
3837          Expv := Expr_Value (Exp);
3838
3839          --  We only fold small non-negative exponents. You might think we
3840          --  could fold small negative exponents for the real case, but we
3841          --  can't because we are required to raise Constraint_Error for
3842          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
3843          --  See ACVC test C4A012B.
3844
3845          if Expv >= 0 and then Expv <= 4 then
3846
3847             --  X ** 0 = 1 (or 1.0)
3848
3849             if Expv = 0 then
3850                if Ekind (Typ) in Integer_Kind then
3851                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
3852                else
3853                   Xnode := Make_Real_Literal (Loc, Ureal_1);
3854                end if;
3855
3856             --  X ** 1 = X
3857
3858             elsif Expv = 1 then
3859                Xnode := Base;
3860
3861             --  X ** 2 = X * X
3862
3863             elsif Expv = 2 then
3864                Xnode :=
3865                  Make_Op_Multiply (Loc,
3866                    Left_Opnd  => Duplicate_Subexpr (Base),
3867                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
3868
3869             --  X ** 3 = X * X * X
3870
3871             elsif Expv = 3 then
3872                Xnode :=
3873                  Make_Op_Multiply (Loc,
3874                    Left_Opnd =>
3875                      Make_Op_Multiply (Loc,
3876                        Left_Opnd  => Duplicate_Subexpr (Base),
3877                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
3878                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
3879
3880             --  X ** 4  ->
3881             --    En : constant base'type := base * base;
3882             --    ...
3883             --    En * En
3884
3885             else -- Expv = 4
3886                Temp :=
3887                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3888
3889                Insert_Actions (N, New_List (
3890                  Make_Object_Declaration (Loc,
3891                    Defining_Identifier => Temp,
3892                    Constant_Present    => True,
3893                    Object_Definition   => New_Reference_To (Typ, Loc),
3894                    Expression =>
3895                      Make_Op_Multiply (Loc,
3896                        Left_Opnd  => Duplicate_Subexpr (Base),
3897                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
3898
3899                Xnode :=
3900                  Make_Op_Multiply (Loc,
3901                    Left_Opnd  => New_Reference_To (Temp, Loc),
3902                    Right_Opnd => New_Reference_To (Temp, Loc));
3903             end if;
3904
3905             Rewrite (N, Xnode);
3906             Analyze_And_Resolve (N, Typ);
3907             return;
3908          end if;
3909       end if;
3910
3911       --  Case of (2 ** expression) appearing as an argument of an integer
3912       --  multiplication, or as the right argument of a division of a non-
3913       --  negative integer. In such cases we leave the node untouched, setting
3914       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
3915       --  of the higher level node converts it into a shift.
3916
3917       if Nkind (Base) = N_Integer_Literal
3918         and then Intval (Base) = 2
3919         and then Is_Integer_Type (Root_Type (Exptyp))
3920         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
3921         and then Is_Unsigned_Type (Exptyp)
3922         and then not Ovflo
3923         and then Nkind (Parent (N)) in N_Binary_Op
3924       then
3925          declare
3926             P : constant Node_Id := Parent (N);
3927             L : constant Node_Id := Left_Opnd (P);
3928             R : constant Node_Id := Right_Opnd (P);
3929
3930          begin
3931             if (Nkind (P) = N_Op_Multiply
3932                  and then
3933                    ((Is_Integer_Type (Etype (L)) and then R = N)
3934                        or else
3935                     (Is_Integer_Type (Etype (R)) and then L = N))
3936                  and then not Do_Overflow_Check (P))
3937
3938               or else
3939                 (Nkind (P) = N_Op_Divide
3940                   and then Is_Integer_Type (Etype (L))
3941                   and then Is_Unsigned_Type (Etype (L))
3942                   and then R = N
3943                   and then not Do_Overflow_Check (P))
3944             then
3945                Set_Is_Power_Of_2_For_Shift (N);
3946                return;
3947             end if;
3948          end;
3949       end if;
3950
3951       --  Fall through if exponentiation must be done using a runtime routine
3952
3953       --  First deal with modular case
3954
3955       if Is_Modular_Integer_Type (Rtyp) then
3956
3957          --  Non-binary case, we call the special exponentiation routine for
3958          --  the non-binary case, converting the argument to Long_Long_Integer
3959          --  and passing the modulus value. Then the result is converted back
3960          --  to the base type.
3961
3962          if Non_Binary_Modulus (Rtyp) then
3963             Rewrite (N,
3964               Convert_To (Typ,
3965                 Make_Function_Call (Loc,
3966                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
3967                   Parameter_Associations => New_List (
3968                     Convert_To (Standard_Integer, Base),
3969                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
3970                     Exp))));
3971
3972          --  Binary case, in this case, we call one of two routines, either
3973          --  the unsigned integer case, or the unsigned long long integer
3974          --  case, with a final "and" operation to do the required mod.
3975
3976          else
3977             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
3978                Ent := RTE (RE_Exp_Unsigned);
3979             else
3980                Ent := RTE (RE_Exp_Long_Long_Unsigned);
3981             end if;
3982
3983             Rewrite (N,
3984               Convert_To (Typ,
3985                 Make_Op_And (Loc,
3986                   Left_Opnd =>
3987                     Make_Function_Call (Loc,
3988                       Name => New_Reference_To (Ent, Loc),
3989                       Parameter_Associations => New_List (
3990                         Convert_To (Etype (First_Formal (Ent)), Base),
3991                         Exp)),
3992                    Right_Opnd =>
3993                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
3994
3995          end if;
3996
3997          --  Common exit point for modular type case
3998
3999          Analyze_And_Resolve (N, Typ);
4000          return;
4001
4002       --  Signed integer cases, done using either Integer or Long_Long_Integer.
4003       --  It is not worth having routines for Short_[Short_]Integer, since for
4004       --  most machines it would not help, and it would generate more code that
4005       --  might need certification in the HI-E case.
4006
4007       --  In the integer cases, we have two routines, one for when overflow
4008       --  checks are required, and one when they are not required, since
4009       --  there is a real gain in ommitting checks on many machines.
4010
4011       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
4012         or else (Rtyp = Base_Type (Standard_Long_Integer)
4013                    and then
4014                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
4015         or else (Rtyp = Universal_Integer)
4016       then
4017          Etyp := Standard_Long_Long_Integer;
4018
4019          if Ovflo then
4020             Rent := RE_Exp_Long_Long_Integer;
4021          else
4022             Rent := RE_Exn_Long_Long_Integer;
4023          end if;
4024
4025       elsif Is_Signed_Integer_Type (Rtyp) then
4026          Etyp := Standard_Integer;
4027
4028          if Ovflo then
4029             Rent := RE_Exp_Integer;
4030          else
4031             Rent := RE_Exn_Integer;
4032          end if;
4033
4034       --  Floating-point cases, always done using Long_Long_Float. We do not
4035       --  need separate routines for the overflow case here, since in the case
4036       --  of floating-point, we generate infinities anyway as a rule (either
4037       --  that or we automatically trap overflow), and if there is an infinity
4038       --  generated and a range check is required, the check will fail anyway.
4039
4040       else
4041          pragma Assert (Is_Floating_Point_Type (Rtyp));
4042          Etyp := Standard_Long_Long_Float;
4043          Rent := RE_Exn_Long_Long_Float;
4044       end if;
4045
4046       --  Common processing for integer cases and floating-point cases.
4047       --  If we are in the right type, we can call runtime routine directly
4048
4049       if Typ = Etyp
4050         and then Rtyp /= Universal_Integer
4051         and then Rtyp /= Universal_Real
4052       then
4053          Rewrite (N,
4054            Make_Function_Call (Loc,
4055              Name => New_Reference_To (RTE (Rent), Loc),
4056              Parameter_Associations => New_List (Base, Exp)));
4057
4058       --  Otherwise we have to introduce conversions (conversions are also
4059       --  required in the universal cases, since the runtime routine is
4060       --  typed using one of the standard types.
4061
4062       else
4063          Rewrite (N,
4064            Convert_To (Typ,
4065              Make_Function_Call (Loc,
4066                Name => New_Reference_To (RTE (Rent), Loc),
4067                Parameter_Associations => New_List (
4068                  Convert_To (Etyp, Base),
4069                  Exp))));
4070       end if;
4071
4072       Analyze_And_Resolve (N, Typ);
4073       return;
4074
4075    exception
4076       when RE_Not_Available =>
4077          return;
4078    end Expand_N_Op_Expon;
4079
4080    --------------------
4081    -- Expand_N_Op_Ge --
4082    --------------------
4083
4084    procedure Expand_N_Op_Ge (N : Node_Id) is
4085       Typ  : constant Entity_Id := Etype (N);
4086       Op1  : constant Node_Id   := Left_Opnd (N);
4087       Op2  : constant Node_Id   := Right_Opnd (N);
4088       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4089
4090    begin
4091       Binary_Op_Validity_Checks (N);
4092
4093       if Vax_Float (Typ1) then
4094          Expand_Vax_Comparison (N);
4095          return;
4096
4097       elsif Is_Array_Type (Typ1) then
4098          Expand_Array_Comparison (N);
4099          return;
4100       end if;
4101
4102       if Is_Boolean_Type (Typ1) then
4103          Adjust_Condition (Op1);
4104          Adjust_Condition (Op2);
4105          Set_Etype (N, Standard_Boolean);
4106          Adjust_Result_Type (N, Typ);
4107       end if;
4108
4109       Rewrite_Comparison (N);
4110    end Expand_N_Op_Ge;
4111
4112    --------------------
4113    -- Expand_N_Op_Gt --
4114    --------------------
4115
4116    procedure Expand_N_Op_Gt (N : Node_Id) is
4117       Typ  : constant Entity_Id := Etype (N);
4118       Op1  : constant Node_Id   := Left_Opnd (N);
4119       Op2  : constant Node_Id   := Right_Opnd (N);
4120       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4121
4122    begin
4123       Binary_Op_Validity_Checks (N);
4124
4125       if Vax_Float (Typ1) then
4126          Expand_Vax_Comparison (N);
4127          return;
4128
4129       elsif Is_Array_Type (Typ1) then
4130          Expand_Array_Comparison (N);
4131          return;
4132       end if;
4133
4134       if Is_Boolean_Type (Typ1) then
4135          Adjust_Condition (Op1);
4136          Adjust_Condition (Op2);
4137          Set_Etype (N, Standard_Boolean);
4138          Adjust_Result_Type (N, Typ);
4139       end if;
4140
4141       Rewrite_Comparison (N);
4142    end Expand_N_Op_Gt;
4143
4144    --------------------
4145    -- Expand_N_Op_Le --
4146    --------------------
4147
4148    procedure Expand_N_Op_Le (N : Node_Id) is
4149       Typ  : constant Entity_Id := Etype (N);
4150       Op1  : constant Node_Id   := Left_Opnd (N);
4151       Op2  : constant Node_Id   := Right_Opnd (N);
4152       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4153
4154    begin
4155       Binary_Op_Validity_Checks (N);
4156
4157       if Vax_Float (Typ1) then
4158          Expand_Vax_Comparison (N);
4159          return;
4160
4161       elsif Is_Array_Type (Typ1) then
4162          Expand_Array_Comparison (N);
4163          return;
4164       end if;
4165
4166       if Is_Boolean_Type (Typ1) then
4167          Adjust_Condition (Op1);
4168          Adjust_Condition (Op2);
4169          Set_Etype (N, Standard_Boolean);
4170          Adjust_Result_Type (N, Typ);
4171       end if;
4172
4173       Rewrite_Comparison (N);
4174    end Expand_N_Op_Le;
4175
4176    --------------------
4177    -- Expand_N_Op_Lt --
4178    --------------------
4179
4180    procedure Expand_N_Op_Lt (N : Node_Id) is
4181       Typ  : constant Entity_Id := Etype (N);
4182       Op1  : constant Node_Id   := Left_Opnd (N);
4183       Op2  : constant Node_Id   := Right_Opnd (N);
4184       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4185
4186    begin
4187       Binary_Op_Validity_Checks (N);
4188
4189       if Vax_Float (Typ1) then
4190          Expand_Vax_Comparison (N);
4191          return;
4192
4193       elsif Is_Array_Type (Typ1) then
4194          Expand_Array_Comparison (N);
4195          return;
4196       end if;
4197
4198       if Is_Boolean_Type (Typ1) then
4199          Adjust_Condition (Op1);
4200          Adjust_Condition (Op2);
4201          Set_Etype (N, Standard_Boolean);
4202          Adjust_Result_Type (N, Typ);
4203       end if;
4204
4205       Rewrite_Comparison (N);
4206    end Expand_N_Op_Lt;
4207
4208    -----------------------
4209    -- Expand_N_Op_Minus --
4210    -----------------------
4211
4212    procedure Expand_N_Op_Minus (N : Node_Id) is
4213       Loc : constant Source_Ptr := Sloc (N);
4214       Typ : constant Entity_Id  := Etype (N);
4215
4216    begin
4217       Unary_Op_Validity_Checks (N);
4218
4219       if not Backend_Overflow_Checks_On_Target
4220          and then Is_Signed_Integer_Type (Etype (N))
4221          and then Do_Overflow_Check (N)
4222       then
4223          --  Software overflow checking expands -expr into (0 - expr)
4224
4225          Rewrite (N,
4226            Make_Op_Subtract (Loc,
4227              Left_Opnd  => Make_Integer_Literal (Loc, 0),
4228              Right_Opnd => Right_Opnd (N)));
4229
4230          Analyze_And_Resolve (N, Typ);
4231
4232       --  Vax floating-point types case
4233
4234       elsif Vax_Float (Etype (N)) then
4235          Expand_Vax_Arith (N);
4236       end if;
4237    end Expand_N_Op_Minus;
4238
4239    ---------------------
4240    -- Expand_N_Op_Mod --
4241    ---------------------
4242
4243    procedure Expand_N_Op_Mod (N : Node_Id) is
4244       Loc   : constant Source_Ptr := Sloc (N);
4245       Typ   : constant Entity_Id  := Etype (N);
4246       Left  : constant Node_Id    := Left_Opnd (N);
4247       Right : constant Node_Id    := Right_Opnd (N);
4248       DOC   : constant Boolean    := Do_Overflow_Check (N);
4249       DDC   : constant Boolean    := Do_Division_Check (N);
4250
4251       LLB : Uint;
4252       Llo : Uint;
4253       Lhi : Uint;
4254       LOK : Boolean;
4255       Rlo : Uint;
4256       Rhi : Uint;
4257       ROK : Boolean;
4258
4259    begin
4260       Binary_Op_Validity_Checks (N);
4261
4262       Determine_Range (Right, ROK, Rlo, Rhi);
4263       Determine_Range (Left,  LOK, Llo, Lhi);
4264
4265       --  Convert mod to rem if operands are known non-negative. We do this
4266       --  since it is quite likely that this will improve the quality of code,
4267       --  (the operation now corresponds to the hardware remainder), and it
4268       --  does not seem likely that it could be harmful.
4269
4270       if LOK and then Llo >= 0
4271            and then
4272          ROK and then Rlo >= 0
4273       then
4274          Rewrite (N,
4275            Make_Op_Rem (Sloc (N),
4276              Left_Opnd  => Left_Opnd (N),
4277              Right_Opnd => Right_Opnd (N)));
4278
4279          --  Instead of reanalyzing the node we do the analysis manually.
4280          --  This avoids anomalies when the replacement is done in an
4281          --  instance and is epsilon more efficient.
4282
4283          Set_Entity            (N, Standard_Entity (S_Op_Rem));
4284          Set_Etype             (N, Typ);
4285          Set_Do_Overflow_Check (N, DOC);
4286          Set_Do_Division_Check (N, DDC);
4287          Expand_N_Op_Rem (N);
4288          Set_Analyzed (N);
4289
4290       --  Otherwise, normal mod processing
4291
4292       else
4293          if Is_Integer_Type (Etype (N)) then
4294             Apply_Divide_Check (N);
4295          end if;
4296
4297          --  Apply optimization x mod 1 = 0. We don't really need that with
4298          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
4299          --  certainly harmless.
4300
4301          if Is_Integer_Type (Etype (N))
4302            and then Compile_Time_Known_Value (Right)
4303            and then Expr_Value (Right) = Uint_1
4304          then
4305             Rewrite (N, Make_Integer_Literal (Loc, 0));
4306             Analyze_And_Resolve (N, Typ);
4307             return;
4308          end if;
4309
4310          --  Deal with annoying case of largest negative number remainder
4311          --  minus one. Gigi does not handle this case correctly, because
4312          --  it generates a divide instruction which may trap in this case.
4313
4314          --  In fact the check is quite easy, if the right operand is -1,
4315          --  then the mod value is always 0, and we can just ignore the
4316          --  left operand completely in this case.
4317
4318          --  The operand type may be private (e.g. in the expansion of an
4319          --  an intrinsic operation) so we must use the underlying type to
4320          --  get the bounds, and convert the literals explicitly.
4321
4322          LLB :=
4323            Expr_Value
4324              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
4325
4326          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4327            and then
4328             ((not LOK) or else (Llo = LLB))
4329          then
4330             Rewrite (N,
4331               Make_Conditional_Expression (Loc,
4332                 Expressions => New_List (
4333                   Make_Op_Eq (Loc,
4334                     Left_Opnd => Duplicate_Subexpr (Right),
4335                     Right_Opnd =>
4336                       Unchecked_Convert_To (Typ,
4337                         Make_Integer_Literal (Loc, -1))),
4338                   Unchecked_Convert_To (Typ,
4339                     Make_Integer_Literal (Loc, Uint_0)),
4340                   Relocate_Node (N))));
4341
4342             Set_Analyzed (Next (Next (First (Expressions (N)))));
4343             Analyze_And_Resolve (N, Typ);
4344          end if;
4345       end if;
4346    end Expand_N_Op_Mod;
4347
4348    --------------------------
4349    -- Expand_N_Op_Multiply --
4350    --------------------------
4351
4352    procedure Expand_N_Op_Multiply (N : Node_Id) is
4353       Loc  : constant Source_Ptr := Sloc (N);
4354       Lop  : constant Node_Id    := Left_Opnd (N);
4355       Rop  : constant Node_Id    := Right_Opnd (N);
4356
4357       Lp2  : constant Boolean :=
4358                Nkind (Lop) = N_Op_Expon
4359                  and then Is_Power_Of_2_For_Shift (Lop);
4360
4361       Rp2  : constant Boolean :=
4362                Nkind (Rop) = N_Op_Expon
4363                  and then Is_Power_Of_2_For_Shift (Rop);
4364
4365       Ltyp : constant Entity_Id  := Etype (Lop);
4366       Rtyp : constant Entity_Id  := Etype (Rop);
4367       Typ  : Entity_Id           := Etype (N);
4368
4369    begin
4370       Binary_Op_Validity_Checks (N);
4371
4372       --  Special optimizations for integer types
4373
4374       if Is_Integer_Type (Typ) then
4375
4376          --  N * 0 = 0 * N = 0 for integer types
4377
4378          if (Compile_Time_Known_Value (Rop)
4379               and then Expr_Value (Rop) = Uint_0)
4380            or else
4381             (Compile_Time_Known_Value (Lop)
4382               and then Expr_Value (Lop) = Uint_0)
4383          then
4384             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
4385             Analyze_And_Resolve (N, Typ);
4386             return;
4387          end if;
4388
4389          --  N * 1 = 1 * N = N for integer types
4390
4391          --  This optimisation is not done if we are going to
4392          --  rewrite the product 1 * 2 ** N to a shift.
4393
4394          if Compile_Time_Known_Value (Rop)
4395            and then Expr_Value (Rop) = Uint_1
4396            and then not Lp2
4397          then
4398             Rewrite (N, Lop);
4399             return;
4400
4401          elsif Compile_Time_Known_Value (Lop)
4402            and then Expr_Value (Lop) = Uint_1
4403            and then not Rp2
4404          then
4405             Rewrite (N, Rop);
4406             return;
4407          end if;
4408       end if;
4409
4410       --  Deal with VAX float case
4411
4412       if Vax_Float (Typ) then
4413          Expand_Vax_Arith (N);
4414          return;
4415       end if;
4416
4417       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
4418       --  Is_Power_Of_2_For_Shift is set means that we know that our left
4419       --  operand is an integer, as required for this to work.
4420
4421       if Rp2 then
4422          if Lp2 then
4423
4424             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
4425
4426             Rewrite (N,
4427               Make_Op_Expon (Loc,
4428                 Left_Opnd => Make_Integer_Literal (Loc, 2),
4429                 Right_Opnd =>
4430                   Make_Op_Add (Loc,
4431                     Left_Opnd  => Right_Opnd (Lop),
4432                     Right_Opnd => Right_Opnd (Rop))));
4433             Analyze_And_Resolve (N, Typ);
4434             return;
4435
4436          else
4437             Rewrite (N,
4438               Make_Op_Shift_Left (Loc,
4439                 Left_Opnd  => Lop,
4440                 Right_Opnd =>
4441                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
4442             Analyze_And_Resolve (N, Typ);
4443             return;
4444          end if;
4445
4446       --  Same processing for the operands the other way round
4447
4448       elsif Lp2 then
4449          Rewrite (N,
4450            Make_Op_Shift_Left (Loc,
4451              Left_Opnd  => Rop,
4452              Right_Opnd =>
4453                Convert_To (Standard_Natural, Right_Opnd (Lop))));
4454          Analyze_And_Resolve (N, Typ);
4455          return;
4456       end if;
4457
4458       --  Do required fixup of universal fixed operation
4459
4460       if Typ = Universal_Fixed then
4461          Fixup_Universal_Fixed_Operation (N);
4462          Typ := Etype (N);
4463       end if;
4464
4465       --  Multiplications with fixed-point results
4466
4467       if Is_Fixed_Point_Type (Typ) then
4468
4469          --  No special processing if Treat_Fixed_As_Integer is set,
4470          --  since from a semantic point of view such operations are
4471          --  simply integer operations and will be treated that way.
4472
4473          if not Treat_Fixed_As_Integer (N) then
4474
4475             --  Case of fixed * integer => fixed
4476
4477             if Is_Integer_Type (Rtyp) then
4478                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
4479
4480             --  Case of integer * fixed => fixed
4481
4482             elsif Is_Integer_Type (Ltyp) then
4483                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
4484
4485             --  Case of fixed * fixed => fixed
4486
4487             else
4488                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
4489             end if;
4490          end if;
4491
4492       --  Other cases of multiplication of fixed-point operands. Again
4493       --  we exclude the cases where Treat_Fixed_As_Integer flag is set.
4494
4495       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
4496         and then not Treat_Fixed_As_Integer (N)
4497       then
4498          if Is_Integer_Type (Typ) then
4499             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
4500          else
4501             pragma Assert (Is_Floating_Point_Type (Typ));
4502             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
4503          end if;
4504
4505       --  Mixed-mode operations can appear in a non-static universal
4506       --  context, in  which case the integer argument must be converted
4507       --  explicitly.
4508
4509       elsif Typ = Universal_Real
4510         and then Is_Integer_Type (Rtyp)
4511       then
4512          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
4513
4514          Analyze_And_Resolve (Rop, Universal_Real);
4515
4516       elsif Typ = Universal_Real
4517         and then Is_Integer_Type (Ltyp)
4518       then
4519          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
4520
4521          Analyze_And_Resolve (Lop, Universal_Real);
4522
4523       --  Non-fixed point cases, check software overflow checking required
4524
4525       elsif Is_Signed_Integer_Type (Etype (N)) then
4526          Apply_Arithmetic_Overflow_Check (N);
4527       end if;
4528    end Expand_N_Op_Multiply;
4529
4530    --------------------
4531    -- Expand_N_Op_Ne --
4532    --------------------
4533
4534    --  Rewrite node as the negation of an equality operation, and reanalyze.
4535    --  The equality to be used is defined in the same scope and has the same
4536    --  signature. It must be set explicitly because in an instance it may not
4537    --  have the same visibility as in the generic unit.
4538
4539    procedure Expand_N_Op_Ne (N : Node_Id) is
4540       Loc : constant Source_Ptr := Sloc (N);
4541       Neg : Node_Id;
4542       Ne  : constant Entity_Id := Entity (N);
4543
4544    begin
4545       Binary_Op_Validity_Checks (N);
4546
4547       Neg :=
4548         Make_Op_Not (Loc,
4549           Right_Opnd =>
4550             Make_Op_Eq (Loc,
4551               Left_Opnd =>  Left_Opnd (N),
4552               Right_Opnd => Right_Opnd (N)));
4553       Set_Paren_Count (Right_Opnd (Neg), 1);
4554
4555       if Scope (Ne) /= Standard_Standard then
4556          Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
4557       end if;
4558
4559       --  For navigation purposes, the inequality is treated as an implicit
4560       --  reference to the corresponding equality. Preserve the Comes_From_
4561       --  source flag so that the proper Xref entry is generated.
4562
4563       Preserve_Comes_From_Source (Neg, N);
4564       Preserve_Comes_From_Source (Right_Opnd (Neg), N);
4565       Rewrite (N, Neg);
4566       Analyze_And_Resolve (N, Standard_Boolean);
4567    end Expand_N_Op_Ne;
4568
4569    ---------------------
4570    -- Expand_N_Op_Not --
4571    ---------------------
4572
4573    --  If the argument is other than a Boolean array type, there is no
4574    --  special expansion required.
4575
4576    --  For the packed case, we call the special routine in Exp_Pakd, except
4577    --  that if the component size is greater than one, we use the standard
4578    --  routine generating a gruesome loop (it is so peculiar to have packed
4579    --  arrays with non-standard Boolean representations anyway, so it does
4580    --  not matter that we do not handle this case efficiently).
4581
4582    --  For the unpacked case (and for the special packed case where we have
4583    --  non standard Booleans, as discussed above), we generate and insert
4584    --  into the tree the following function definition:
4585
4586    --     function Nnnn (A : arr) is
4587    --       B : arr;
4588    --     begin
4589    --       for J in a'range loop
4590    --          B (J) := not A (J);
4591    --       end loop;
4592    --       return B;
4593    --     end Nnnn;
4594
4595    --  Here arr is the actual subtype of the parameter (and hence always
4596    --  constrained). Then we replace the not with a call to this function.
4597
4598    procedure Expand_N_Op_Not (N : Node_Id) is
4599       Loc  : constant Source_Ptr := Sloc (N);
4600       Typ  : constant Entity_Id  := Etype (N);
4601       Opnd : Node_Id;
4602       Arr  : Entity_Id;
4603       A    : Entity_Id;
4604       B    : Entity_Id;
4605       J    : Entity_Id;
4606       A_J  : Node_Id;
4607       B_J  : Node_Id;
4608
4609       Func_Name      : Entity_Id;
4610       Loop_Statement : Node_Id;
4611
4612    begin
4613       Unary_Op_Validity_Checks (N);
4614
4615       --  For boolean operand, deal with non-standard booleans
4616
4617       if Is_Boolean_Type (Typ) then
4618          Adjust_Condition (Right_Opnd (N));
4619          Set_Etype (N, Standard_Boolean);
4620          Adjust_Result_Type (N, Typ);
4621          return;
4622       end if;
4623
4624       --  Only array types need any other processing
4625
4626       if not Is_Array_Type (Typ) then
4627          return;
4628       end if;
4629
4630       --  Case of array operand. If bit packed, handle it in Exp_Pakd
4631
4632       if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
4633          Expand_Packed_Not (N);
4634          return;
4635       end if;
4636
4637       --  Case of array operand which is not bit-packed. If the context is
4638       --  a safe assignment, call in-place operation, If context is a larger
4639       --  boolean expression in the context of a safe assignment, expansion is
4640       --  done by enclosing operation.
4641
4642       Opnd := Relocate_Node (Right_Opnd (N));
4643       Convert_To_Actual_Subtype (Opnd);
4644       Arr := Etype (Opnd);
4645       Ensure_Defined (Arr, N);
4646
4647       if Nkind (Parent (N)) = N_Assignment_Statement then
4648          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
4649             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
4650             return;
4651
4652          --  Special case the negation of a binary operation.
4653
4654          elsif (Nkind (Opnd) = N_Op_And
4655                  or else Nkind (Opnd) = N_Op_Or
4656                  or else Nkind (Opnd) = N_Op_Xor)
4657            and then Safe_In_Place_Array_Op
4658              (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
4659          then
4660             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
4661             return;
4662          end if;
4663
4664       elsif Nkind (Parent (N)) in N_Binary_Op
4665         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
4666       then
4667          declare
4668             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
4669             Op2 : constant Node_Id := Right_Opnd (Parent (N));
4670             Lhs : constant Node_Id := Name (Parent (Parent (N)));
4671
4672          begin
4673             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
4674                if N = Op1
4675                  and then Nkind (Op2) = N_Op_Not
4676                then
4677                   --  (not A) op (not B) can be reduced to a single call.
4678
4679                   return;
4680
4681                elsif N = Op2
4682                  and then Nkind (Parent (N)) = N_Op_Xor
4683                then
4684                   --  A xor (not B) can also be special-cased.
4685
4686                   return;
4687                end if;
4688             end if;
4689          end;
4690       end if;
4691
4692       A := Make_Defining_Identifier (Loc, Name_uA);
4693       B := Make_Defining_Identifier (Loc, Name_uB);
4694       J := Make_Defining_Identifier (Loc, Name_uJ);
4695
4696       A_J :=
4697         Make_Indexed_Component (Loc,
4698           Prefix      => New_Reference_To (A, Loc),
4699           Expressions => New_List (New_Reference_To (J, Loc)));
4700
4701       B_J :=
4702         Make_Indexed_Component (Loc,
4703           Prefix      => New_Reference_To (B, Loc),
4704           Expressions => New_List (New_Reference_To (J, Loc)));
4705
4706       Loop_Statement :=
4707         Make_Implicit_Loop_Statement (N,
4708           Identifier => Empty,
4709
4710           Iteration_Scheme =>
4711             Make_Iteration_Scheme (Loc,
4712               Loop_Parameter_Specification =>
4713                 Make_Loop_Parameter_Specification (Loc,
4714                   Defining_Identifier => J,
4715                   Discrete_Subtype_Definition =>
4716                     Make_Attribute_Reference (Loc,
4717                       Prefix => Make_Identifier (Loc, Chars (A)),
4718                       Attribute_Name => Name_Range))),
4719
4720           Statements => New_List (
4721             Make_Assignment_Statement (Loc,
4722               Name       => B_J,
4723               Expression => Make_Op_Not (Loc, A_J))));
4724
4725       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
4726       Set_Is_Inlined (Func_Name);
4727
4728       Insert_Action (N,
4729         Make_Subprogram_Body (Loc,
4730           Specification =>
4731             Make_Function_Specification (Loc,
4732               Defining_Unit_Name => Func_Name,
4733               Parameter_Specifications => New_List (
4734                 Make_Parameter_Specification (Loc,
4735                   Defining_Identifier => A,
4736                   Parameter_Type      => New_Reference_To (Typ, Loc))),
4737               Subtype_Mark => New_Reference_To (Typ, Loc)),
4738
4739           Declarations => New_List (
4740             Make_Object_Declaration (Loc,
4741               Defining_Identifier => B,
4742               Object_Definition   => New_Reference_To (Arr, Loc))),
4743
4744           Handled_Statement_Sequence =>
4745             Make_Handled_Sequence_Of_Statements (Loc,
4746               Statements => New_List (
4747                 Loop_Statement,
4748                 Make_Return_Statement (Loc,
4749                   Expression =>
4750                     Make_Identifier (Loc, Chars (B)))))));
4751
4752       Rewrite (N,
4753         Make_Function_Call (Loc,
4754           Name => New_Reference_To (Func_Name, Loc),
4755           Parameter_Associations => New_List (Opnd)));
4756
4757       Analyze_And_Resolve (N, Typ);
4758    end Expand_N_Op_Not;
4759
4760    --------------------
4761    -- Expand_N_Op_Or --
4762    --------------------
4763
4764    procedure Expand_N_Op_Or (N : Node_Id) is
4765       Typ : constant Entity_Id := Etype (N);
4766
4767    begin
4768       Binary_Op_Validity_Checks (N);
4769
4770       if Is_Array_Type (Etype (N)) then
4771          Expand_Boolean_Operator (N);
4772
4773       elsif Is_Boolean_Type (Etype (N)) then
4774          Adjust_Condition (Left_Opnd (N));
4775          Adjust_Condition (Right_Opnd (N));
4776          Set_Etype (N, Standard_Boolean);
4777          Adjust_Result_Type (N, Typ);
4778       end if;
4779    end Expand_N_Op_Or;
4780
4781    ----------------------
4782    -- Expand_N_Op_Plus --
4783    ----------------------
4784
4785    procedure Expand_N_Op_Plus (N : Node_Id) is
4786    begin
4787       Unary_Op_Validity_Checks (N);
4788    end Expand_N_Op_Plus;
4789
4790    ---------------------
4791    -- Expand_N_Op_Rem --
4792    ---------------------
4793
4794    procedure Expand_N_Op_Rem (N : Node_Id) is
4795       Loc : constant Source_Ptr := Sloc (N);
4796       Typ : constant Entity_Id  := Etype (N);
4797
4798       Left  : constant Node_Id := Left_Opnd (N);
4799       Right : constant Node_Id := Right_Opnd (N);
4800
4801       LLB : Uint;
4802       Llo : Uint;
4803       Lhi : Uint;
4804       LOK : Boolean;
4805       Rlo : Uint;
4806       Rhi : Uint;
4807       ROK : Boolean;
4808
4809    begin
4810       Binary_Op_Validity_Checks (N);
4811
4812       if Is_Integer_Type (Etype (N)) then
4813          Apply_Divide_Check (N);
4814       end if;
4815
4816       --  Apply optimization x rem 1 = 0. We don't really need that with
4817       --  gcc, but it is useful with other back ends (e.g. AAMP), and is
4818       --  certainly harmless.
4819
4820       if Is_Integer_Type (Etype (N))
4821         and then Compile_Time_Known_Value (Right)
4822         and then Expr_Value (Right) = Uint_1
4823       then
4824          Rewrite (N, Make_Integer_Literal (Loc, 0));
4825          Analyze_And_Resolve (N, Typ);
4826          return;
4827       end if;
4828
4829       --  Deal with annoying case of largest negative number remainder
4830       --  minus one. Gigi does not handle this case correctly, because
4831       --  it generates a divide instruction which may trap in this case.
4832
4833       --  In fact the check is quite easy, if the right operand is -1,
4834       --  then the remainder is always 0, and we can just ignore the
4835       --  left operand completely in this case.
4836
4837       Determine_Range (Right, ROK, Rlo, Rhi);
4838       Determine_Range (Left, LOK, Llo, Lhi);
4839
4840       --  The operand type may be private (e.g. in the expansion of an
4841       --  an intrinsic operation) so we must use the underlying type to
4842       --  get the bounds, and convert the literals explicitly.
4843
4844       LLB :=
4845         Expr_Value
4846           (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
4847
4848       --  Now perform the test, generating code only if needed
4849
4850       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4851         and then
4852          ((not LOK) or else (Llo = LLB))
4853       then
4854          Rewrite (N,
4855            Make_Conditional_Expression (Loc,
4856              Expressions => New_List (
4857                Make_Op_Eq (Loc,
4858                  Left_Opnd => Duplicate_Subexpr (Right),
4859                  Right_Opnd =>
4860                    Unchecked_Convert_To (Typ,
4861                      Make_Integer_Literal (Loc, -1))),
4862
4863                Unchecked_Convert_To (Typ,
4864                  Make_Integer_Literal (Loc, Uint_0)),
4865
4866                Relocate_Node (N))));
4867
4868          Set_Analyzed (Next (Next (First (Expressions (N)))));
4869          Analyze_And_Resolve (N, Typ);
4870       end if;
4871    end Expand_N_Op_Rem;
4872
4873    -----------------------------
4874    -- Expand_N_Op_Rotate_Left --
4875    -----------------------------
4876
4877    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
4878    begin
4879       Binary_Op_Validity_Checks (N);
4880    end Expand_N_Op_Rotate_Left;
4881
4882    ------------------------------
4883    -- Expand_N_Op_Rotate_Right --
4884    ------------------------------
4885
4886    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
4887    begin
4888       Binary_Op_Validity_Checks (N);
4889    end Expand_N_Op_Rotate_Right;
4890
4891    ----------------------------
4892    -- Expand_N_Op_Shift_Left --
4893    ----------------------------
4894
4895    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
4896    begin
4897       Binary_Op_Validity_Checks (N);
4898    end Expand_N_Op_Shift_Left;
4899
4900    -----------------------------
4901    -- Expand_N_Op_Shift_Right --
4902    -----------------------------
4903
4904    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
4905    begin
4906       Binary_Op_Validity_Checks (N);
4907    end Expand_N_Op_Shift_Right;
4908
4909    ----------------------------------------
4910    -- Expand_N_Op_Shift_Right_Arithmetic --
4911    ----------------------------------------
4912
4913    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
4914    begin
4915       Binary_Op_Validity_Checks (N);
4916    end Expand_N_Op_Shift_Right_Arithmetic;
4917
4918    --------------------------
4919    -- Expand_N_Op_Subtract --
4920    --------------------------
4921
4922    procedure Expand_N_Op_Subtract (N : Node_Id) is
4923       Typ : constant Entity_Id := Etype (N);
4924
4925    begin
4926       Binary_Op_Validity_Checks (N);
4927
4928       --  N - 0 = N for integer types
4929
4930       if Is_Integer_Type (Typ)
4931         and then Compile_Time_Known_Value (Right_Opnd (N))
4932         and then Expr_Value (Right_Opnd (N)) = 0
4933       then
4934          Rewrite (N, Left_Opnd (N));
4935          return;
4936       end if;
4937
4938       --  Arithemtic overflow checks for signed integer/fixed point types
4939
4940       if Is_Signed_Integer_Type (Typ)
4941         or else Is_Fixed_Point_Type (Typ)
4942       then
4943          Apply_Arithmetic_Overflow_Check (N);
4944
4945       --  Vax floating-point types case
4946
4947       elsif Vax_Float (Typ) then
4948          Expand_Vax_Arith (N);
4949       end if;
4950    end Expand_N_Op_Subtract;
4951
4952    ---------------------
4953    -- Expand_N_Op_Xor --
4954    ---------------------
4955
4956    procedure Expand_N_Op_Xor (N : Node_Id) is
4957       Typ : constant Entity_Id := Etype (N);
4958
4959    begin
4960       Binary_Op_Validity_Checks (N);
4961
4962       if Is_Array_Type (Etype (N)) then
4963          Expand_Boolean_Operator (N);
4964
4965       elsif Is_Boolean_Type (Etype (N)) then
4966          Adjust_Condition (Left_Opnd (N));
4967          Adjust_Condition (Right_Opnd (N));
4968          Set_Etype (N, Standard_Boolean);
4969          Adjust_Result_Type (N, Typ);
4970       end if;
4971    end Expand_N_Op_Xor;
4972
4973    ----------------------
4974    -- Expand_N_Or_Else --
4975    ----------------------
4976
4977    --  Expand into conditional expression if Actions present, and also
4978    --  deal with optimizing case of arguments being True or False.
4979
4980    procedure Expand_N_Or_Else (N : Node_Id) is
4981       Loc     : constant Source_Ptr := Sloc (N);
4982       Typ     : constant Entity_Id  := Etype (N);
4983       Left    : constant Node_Id    := Left_Opnd (N);
4984       Right   : constant Node_Id    := Right_Opnd (N);
4985       Actlist : List_Id;
4986
4987    begin
4988       --  Deal with non-standard booleans
4989
4990       if Is_Boolean_Type (Typ) then
4991          Adjust_Condition (Left);
4992          Adjust_Condition (Right);
4993          Set_Etype (N, Standard_Boolean);
4994       end if;
4995
4996       --  Check for cases of left argument is True or False
4997
4998       if Nkind (Left) = N_Identifier then
4999
5000          --  If left argument is False, change (False or else Right) to Right.
5001          --  Any actions associated with Right will be executed unconditionally
5002          --  and can thus be inserted into the tree unconditionally.
5003
5004          if Entity (Left) = Standard_False then
5005             if Present (Actions (N)) then
5006                Insert_Actions (N, Actions (N));
5007             end if;
5008
5009             Rewrite (N, Right);
5010             Adjust_Result_Type (N, Typ);
5011             return;
5012
5013          --  If left argument is True, change (True and then Right) to
5014          --  True. In this case we can forget the actions associated with
5015          --  Right, since they will never be executed.
5016
5017          elsif Entity (Left) = Standard_True then
5018             Kill_Dead_Code (Right);
5019             Kill_Dead_Code (Actions (N));
5020             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5021             Adjust_Result_Type (N, Typ);
5022             return;
5023          end if;
5024       end if;
5025
5026       --  If Actions are present, we expand
5027
5028       --     left or else right
5029
5030       --  into
5031
5032       --     if left then True else right end
5033
5034       --  with the actions becoming the Else_Actions of the conditional
5035       --  expression. This conditional expression is then further expanded
5036       --  (and will eventually disappear)
5037
5038       if Present (Actions (N)) then
5039          Actlist := Actions (N);
5040          Rewrite (N,
5041             Make_Conditional_Expression (Loc,
5042               Expressions => New_List (
5043                 Left,
5044                 New_Occurrence_Of (Standard_True, Loc),
5045                 Right)));
5046
5047          Set_Else_Actions (N, Actlist);
5048          Analyze_And_Resolve (N, Standard_Boolean);
5049          Adjust_Result_Type (N, Typ);
5050          return;
5051       end if;
5052
5053       --  No actions present, check for cases of right argument True/False
5054
5055       if Nkind (Right) = N_Identifier then
5056
5057          --  Change (Left or else False) to Left. Note that we know there
5058          --  are no actions associated with the True operand, since we
5059          --  just checked for this case above.
5060
5061          if Entity (Right) = Standard_False then
5062             Rewrite (N, Left);
5063
5064          --  Change (Left or else True) to True, making sure to preserve
5065          --  any side effects associated with the Left operand.
5066
5067          elsif Entity (Right) = Standard_True then
5068             Remove_Side_Effects (Left);
5069             Rewrite
5070               (N, New_Occurrence_Of (Standard_True, Loc));
5071          end if;
5072       end if;
5073
5074       Adjust_Result_Type (N, Typ);
5075    end Expand_N_Or_Else;
5076
5077    -----------------------------------
5078    -- Expand_N_Qualified_Expression --
5079    -----------------------------------
5080
5081    procedure Expand_N_Qualified_Expression (N : Node_Id) is
5082       Operand     : constant Node_Id   := Expression (N);
5083       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
5084
5085    begin
5086       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
5087    end Expand_N_Qualified_Expression;
5088
5089    ---------------------------------
5090    -- Expand_N_Selected_Component --
5091    ---------------------------------
5092
5093    --  If the selector is a discriminant of a concurrent object, rewrite the
5094    --  prefix to denote the corresponding record type.
5095
5096    procedure Expand_N_Selected_Component (N : Node_Id) is
5097       Loc   : constant Source_Ptr := Sloc (N);
5098       Par   : constant Node_Id    := Parent (N);
5099       P     : constant Node_Id    := Prefix (N);
5100       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
5101       Disc  : Entity_Id;
5102       New_N : Node_Id;
5103       Dcon  : Elmt_Id;
5104
5105       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
5106       --  Gigi needs a temporary for prefixes that depend on a discriminant,
5107       --  unless the context of an assignment can provide size information.
5108       --  Don't we have a general routine that does this???
5109
5110       -----------------------
5111       -- In_Left_Hand_Side --
5112       -----------------------
5113
5114       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
5115       begin
5116          return (Nkind (Parent (Comp)) = N_Assignment_Statement
5117                    and then Comp = Name (Parent (Comp)))
5118            or else (Present (Parent (Comp))
5119                       and then Nkind (Parent (Comp)) in N_Subexpr
5120                       and then In_Left_Hand_Side (Parent (Comp)));
5121       end In_Left_Hand_Side;
5122
5123    --  Start of processing for Expand_N_Selected_Component
5124
5125    begin
5126       --  Insert explicit dereference if required
5127
5128       if Is_Access_Type (Ptyp) then
5129          Insert_Explicit_Dereference (P);
5130
5131          if Ekind (Etype (P)) = E_Private_Subtype
5132            and then Is_For_Access_Subtype (Etype (P))
5133          then
5134             Set_Etype (P, Base_Type (Etype (P)));
5135          end if;
5136
5137          Ptyp := Etype (P);
5138       end if;
5139
5140       --  Deal with discriminant check required
5141
5142       if Do_Discriminant_Check (N) then
5143
5144          --  Present the discrminant checking function to the backend,
5145          --  so that it can inline the call to the function.
5146
5147          Add_Inlined_Body
5148            (Discriminant_Checking_Func
5149              (Original_Record_Component (Entity (Selector_Name (N)))));
5150
5151          --  Now reset the flag and generate the call
5152
5153          Set_Do_Discriminant_Check (N, False);
5154          Generate_Discriminant_Check (N);
5155       end if;
5156
5157       --  Gigi cannot handle unchecked conversions that are the prefix of a
5158       --  selected component with discriminants. This must be checked during
5159       --  expansion, because during analysis the type of the selector is not
5160       --  known at the point the prefix is analyzed. If the conversion is the
5161       --  target of an assignment, then we cannot force the evaluation.
5162
5163       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
5164         and then Has_Discriminants (Etype (N))
5165         and then not In_Left_Hand_Side (N)
5166       then
5167          Force_Evaluation (Prefix (N));
5168       end if;
5169
5170       --  Remaining processing applies only if selector is a discriminant
5171
5172       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
5173
5174          --  If the selector is a discriminant of a constrained record type,
5175          --  we may be able to rewrite the expression with the actual value
5176          --  of the discriminant, a useful optimization in some cases.
5177
5178          if Is_Record_Type (Ptyp)
5179            and then Has_Discriminants (Ptyp)
5180            and then Is_Constrained (Ptyp)
5181          then
5182             --  Do this optimization for discrete types only, and not for
5183             --  access types (access discriminants get us into trouble!)
5184
5185             if not Is_Discrete_Type (Etype (N)) then
5186                null;
5187
5188             --  Don't do this on the left hand of an assignment statement.
5189             --  Normally one would think that references like this would
5190             --  not occur, but they do in generated code, and mean that
5191             --  we really do want to assign the discriminant!
5192
5193             elsif Nkind (Par) = N_Assignment_Statement
5194               and then Name (Par) = N
5195             then
5196                null;
5197
5198             --  Don't do this optimization for the prefix of an attribute
5199             --  or the operand of an object renaming declaration since these
5200             --  are contexts where we do not want the value anyway.
5201
5202             elsif (Nkind (Par) = N_Attribute_Reference
5203                      and then Prefix (Par) = N)
5204               or else Is_Renamed_Object (N)
5205             then
5206                null;
5207
5208             --  Don't do this optimization if we are within the code for a
5209             --  discriminant check, since the whole point of such a check may
5210             --  be to verify the condition on which the code below depends!
5211
5212             elsif Is_In_Discriminant_Check (N) then
5213                null;
5214
5215             --  Green light to see if we can do the optimization. There is
5216             --  still one condition that inhibits the optimization below
5217             --  but now is the time to check the particular discriminant.
5218
5219             else
5220                --  Loop through discriminants to find the matching
5221                --  discriminant constraint to see if we can copy it.
5222
5223                Disc := First_Discriminant (Ptyp);
5224                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
5225                Discr_Loop : while Present (Dcon) loop
5226
5227                   --  Check if this is the matching discriminant
5228
5229                   if Disc = Entity (Selector_Name (N)) then
5230
5231                      --  Here we have the matching discriminant. Check for
5232                      --  the case of a discriminant of a component that is
5233                      --  constrained by an outer discriminant, which cannot
5234                      --  be optimized away.
5235
5236                      if
5237                        Denotes_Discriminant
5238                         (Node (Dcon), Check_Protected => True)
5239                      then
5240                         exit Discr_Loop;
5241
5242                      --  In the context of a case statement, the expression
5243                      --  may have the base type of the discriminant, and we
5244                      --  need to preserve the constraint to avoid spurious
5245                      --  errors on missing cases.
5246
5247                      elsif Nkind (Parent (N)) = N_Case_Statement
5248                        and then Etype (Node (Dcon)) /= Etype (Disc)
5249                      then
5250                         --  RBKD is suspicious of the following code. The
5251                         --  call to New_Copy instead of New_Copy_Tree is
5252                         --  suspicious, and the call to Analyze instead
5253                         --  of Analyze_And_Resolve is also suspicious ???
5254
5255                         --  Wouldn't it be good enough to do a perfectly
5256                         --  normal Analyze_And_Resolve call using the
5257                         --  subtype of the discriminant here???
5258
5259                         Rewrite (N,
5260                           Make_Qualified_Expression (Loc,
5261                             Subtype_Mark =>
5262                               New_Occurrence_Of (Etype (Disc), Loc),
5263                             Expression   =>
5264                               New_Copy (Node (Dcon))));
5265                         Analyze (N);
5266
5267                         --  In case that comes out as a static expression,
5268                         --  reset it (a selected component is never static).
5269
5270                         Set_Is_Static_Expression (N, False);
5271                         return;
5272
5273                      --  Otherwise we can just copy the constraint, but the
5274                      --  result is certainly not static!
5275
5276                      --  Again the New_Copy here and the failure to even
5277                      --  to an analyze call is uneasy ???
5278
5279                      else
5280                         Rewrite (N, New_Copy (Node (Dcon)));
5281                         Set_Is_Static_Expression (N, False);
5282                         return;
5283                      end if;
5284                   end if;
5285
5286                   Next_Elmt (Dcon);
5287                   Next_Discriminant (Disc);
5288                end loop Discr_Loop;
5289
5290                --  Note: the above loop should always find a matching
5291                --  discriminant, but if it does not, we just missed an
5292                --  optimization due to some glitch (perhaps a previous
5293                --  error), so ignore.
5294
5295             end if;
5296          end if;
5297
5298          --  The only remaining processing is in the case of a discriminant of
5299          --  a concurrent object, where we rewrite the prefix to denote the
5300          --  corresponding record type. If the type is derived and has renamed
5301          --  discriminants, use corresponding discriminant, which is the one
5302          --  that appears in the corresponding record.
5303
5304          if not Is_Concurrent_Type (Ptyp) then
5305             return;
5306          end if;
5307
5308          Disc := Entity (Selector_Name (N));
5309
5310          if Is_Derived_Type (Ptyp)
5311            and then Present (Corresponding_Discriminant (Disc))
5312          then
5313             Disc := Corresponding_Discriminant (Disc);
5314          end if;
5315
5316          New_N :=
5317            Make_Selected_Component (Loc,
5318              Prefix =>
5319                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
5320                  New_Copy_Tree (P)),
5321              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
5322
5323          Rewrite (N, New_N);
5324          Analyze (N);
5325       end if;
5326    end Expand_N_Selected_Component;
5327
5328    --------------------
5329    -- Expand_N_Slice --
5330    --------------------
5331
5332    procedure Expand_N_Slice (N : Node_Id) is
5333       Loc  : constant Source_Ptr := Sloc (N);
5334       Typ  : constant Entity_Id  := Etype (N);
5335       Pfx  : constant Node_Id    := Prefix (N);
5336       Ptp  : Entity_Id           := Etype (Pfx);
5337
5338       function Is_Procedure_Actual (N : Node_Id) return Boolean;
5339       --  Check whether context is a procedure call, in which case
5340       --  expansion of a bit-packed slice is deferred until the call
5341       --  itself is expanded.
5342
5343       procedure Make_Temporary;
5344       --  Create a named variable for the value of the slice, in
5345       --  cases where the back-end cannot handle it properly, e.g.
5346       --  when packed types or unaligned slices are involved.
5347
5348       -------------------------
5349       -- Is_Procedure_Actual --
5350       -------------------------
5351
5352       function Is_Procedure_Actual (N : Node_Id) return Boolean is
5353          Par : Node_Id := Parent (N);
5354
5355       begin
5356          while Present (Par)
5357            and then Nkind (Par) not in N_Statement_Other_Than_Procedure_Call
5358          loop
5359             if Nkind (Par) = N_Procedure_Call_Statement then
5360                return True;
5361             else
5362                Par := Parent (Par);
5363             end if;
5364          end loop;
5365
5366          return False;
5367       end Is_Procedure_Actual;
5368
5369       --------------------
5370       -- Make_Temporary --
5371       --------------------
5372
5373       procedure Make_Temporary is
5374          Decl : Node_Id;
5375          Ent  : constant Entity_Id :=
5376                   Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
5377       begin
5378          Decl :=
5379            Make_Object_Declaration (Loc,
5380              Defining_Identifier => Ent,
5381              Object_Definition   => New_Occurrence_Of (Typ, Loc));
5382
5383          Set_No_Initialization (Decl);
5384
5385          Insert_Actions (N, New_List (
5386            Decl,
5387            Make_Assignment_Statement (Loc,
5388              Name => New_Occurrence_Of (Ent, Loc),
5389              Expression => Relocate_Node (N))));
5390
5391          Rewrite (N, New_Occurrence_Of (Ent, Loc));
5392          Analyze_And_Resolve (N, Typ);
5393       end Make_Temporary;
5394
5395    --  Start of processing for Expand_N_Slice
5396
5397    begin
5398       --  Special handling for access types
5399
5400       if Is_Access_Type (Ptp) then
5401
5402          --  Check for explicit dereference required for checked pool
5403
5404          Insert_Dereference_Action (Pfx);
5405
5406          --  If we have an access to a packed array type, then put in an
5407          --  explicit dereference. We do this in case the slice must be
5408          --  expanded, and we want to make sure we get an access check.
5409
5410          Ptp := Designated_Type (Ptp);
5411
5412          if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
5413             Rewrite (Pfx,
5414               Make_Explicit_Dereference (Sloc (N),
5415                 Prefix => Relocate_Node (Pfx)));
5416
5417             Analyze_And_Resolve (Pfx, Ptp);
5418          end if;
5419       end if;
5420
5421       --  Range checks are potentially also needed for cases involving
5422       --  a slice indexed by a subtype indication, but Do_Range_Check
5423       --  can currently only be set for expressions ???
5424
5425       if not Index_Checks_Suppressed (Ptp)
5426         and then (not Is_Entity_Name (Pfx)
5427                    or else not Index_Checks_Suppressed (Entity (Pfx)))
5428         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
5429       then
5430          Enable_Range_Check (Discrete_Range (N));
5431       end if;
5432
5433       --  The remaining case to be handled is packed slices. We can leave
5434       --  packed slices as they are in the following situations:
5435
5436       --    1. Right or left side of an assignment (we can handle this
5437       --       situation correctly in the assignment statement expansion).
5438
5439       --    2. Prefix of indexed component (the slide is optimized away
5440       --       in this case, see the start of Expand_N_Slice.
5441
5442       --    3. Object renaming declaration, since we want the name of
5443       --       the slice, not the value.
5444
5445       --    4. Argument to procedure call, since copy-in/copy-out handling
5446       --       may be required, and this is handled in the expansion of
5447       --       call itself.
5448
5449       --    5. Prefix of an address attribute (this is an error which
5450       --       is caught elsewhere, and the expansion would intefere
5451       --       with generating the error message).
5452
5453       if not Is_Packed (Typ) then
5454
5455          --  Apply transformation for actuals of a function call,
5456          --  where Expand_Actuals is not used.
5457
5458          if Nkind (Parent (N)) = N_Function_Call
5459            and then Is_Possibly_Unaligned_Slice (N)
5460          then
5461             Make_Temporary;
5462          end if;
5463
5464       elsif Nkind (Parent (N)) = N_Assignment_Statement
5465         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
5466                    and then Parent (N) = Name (Parent (Parent (N))))
5467       then
5468          return;
5469
5470       elsif Nkind (Parent (N)) = N_Indexed_Component
5471         or else Is_Renamed_Object (N)
5472         or else Is_Procedure_Actual (N)
5473       then
5474          return;
5475
5476       elsif Nkind (Parent (N)) = N_Attribute_Reference
5477         and then Attribute_Name (Parent (N)) = Name_Address
5478       then
5479          return;
5480
5481       else
5482          Make_Temporary;
5483       end if;
5484    end Expand_N_Slice;
5485
5486    ------------------------------
5487    -- Expand_N_Type_Conversion --
5488    ------------------------------
5489
5490    procedure Expand_N_Type_Conversion (N : Node_Id) is
5491       Loc          : constant Source_Ptr := Sloc (N);
5492       Operand      : constant Node_Id    := Expression (N);
5493       Target_Type  : constant Entity_Id  := Etype (N);
5494       Operand_Type : Entity_Id           := Etype (Operand);
5495
5496       procedure Handle_Changed_Representation;
5497       --  This is called in the case of record and array type conversions
5498       --  to see if there is a change of representation to be handled.
5499       --  Change of representation is actually handled at the assignment
5500       --  statement level, and what this procedure does is rewrite node N
5501       --  conversion as an assignment to temporary. If there is no change
5502       --  of representation, then the conversion node is unchanged.
5503
5504       procedure Real_Range_Check;
5505       --  Handles generation of range check for real target value
5506
5507       -----------------------------------
5508       -- Handle_Changed_Representation --
5509       -----------------------------------
5510
5511       procedure Handle_Changed_Representation is
5512          Temp : Entity_Id;
5513          Decl : Node_Id;
5514          Odef : Node_Id;
5515          Disc : Node_Id;
5516          N_Ix : Node_Id;
5517          Cons : List_Id;
5518
5519       begin
5520          --  Nothing to do if no change of representation
5521
5522          if Same_Representation (Operand_Type, Target_Type) then
5523             return;
5524
5525          --  The real change of representation work is done by the assignment
5526          --  statement processing. So if this type conversion is appearing as
5527          --  the expression of an assignment statement, nothing needs to be
5528          --  done to the conversion.
5529
5530          elsif Nkind (Parent (N)) = N_Assignment_Statement then
5531             return;
5532
5533          --  Otherwise we need to generate a temporary variable, and do the
5534          --  change of representation assignment into that temporary variable.
5535          --  The conversion is then replaced by a reference to this variable.
5536
5537          else
5538             Cons := No_List;
5539
5540             --  If type is unconstrained we have to add a constraint,
5541             --  copied from the actual value of the left hand side.
5542
5543             if not Is_Constrained (Target_Type) then
5544                if Has_Discriminants (Operand_Type) then
5545                   Disc := First_Discriminant (Operand_Type);
5546
5547                   if Disc /= First_Stored_Discriminant (Operand_Type) then
5548                      Disc := First_Stored_Discriminant (Operand_Type);
5549                   end if;
5550
5551                   Cons := New_List;
5552                   while Present (Disc) loop
5553                      Append_To (Cons,
5554                        Make_Selected_Component (Loc,
5555                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
5556                          Selector_Name =>
5557                            Make_Identifier (Loc, Chars (Disc))));
5558                      Next_Discriminant (Disc);
5559                   end loop;
5560
5561                elsif Is_Array_Type (Operand_Type) then
5562                   N_Ix := First_Index (Target_Type);
5563                   Cons := New_List;
5564
5565                   for J in 1 .. Number_Dimensions (Operand_Type) loop
5566
5567                      --  We convert the bounds explicitly. We use an unchecked
5568                      --  conversion because bounds checks are done elsewhere.
5569
5570                      Append_To (Cons,
5571                        Make_Range (Loc,
5572                          Low_Bound =>
5573                            Unchecked_Convert_To (Etype (N_Ix),
5574                              Make_Attribute_Reference (Loc,
5575                                Prefix =>
5576                                  Duplicate_Subexpr_No_Checks
5577                                    (Operand, Name_Req => True),
5578                                Attribute_Name => Name_First,
5579                                Expressions    => New_List (
5580                                  Make_Integer_Literal (Loc, J)))),
5581
5582                          High_Bound =>
5583                            Unchecked_Convert_To (Etype (N_Ix),
5584                              Make_Attribute_Reference (Loc,
5585                                Prefix =>
5586                                  Duplicate_Subexpr_No_Checks
5587                                    (Operand, Name_Req => True),
5588                                Attribute_Name => Name_Last,
5589                                Expressions    => New_List (
5590                                  Make_Integer_Literal (Loc, J))))));
5591
5592                      Next_Index (N_Ix);
5593                   end loop;
5594                end if;
5595             end if;
5596
5597             Odef := New_Occurrence_Of (Target_Type, Loc);
5598
5599             if Present (Cons) then
5600                Odef :=
5601                  Make_Subtype_Indication (Loc,
5602                    Subtype_Mark => Odef,
5603                    Constraint =>
5604                      Make_Index_Or_Discriminant_Constraint (Loc,
5605                        Constraints => Cons));
5606             end if;
5607
5608             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
5609             Decl :=
5610               Make_Object_Declaration (Loc,
5611                 Defining_Identifier => Temp,
5612                 Object_Definition   => Odef);
5613
5614             Set_No_Initialization (Decl, True);
5615
5616             --  Insert required actions. It is essential to suppress checks
5617             --  since we have suppressed default initialization, which means
5618             --  that the variable we create may have no discriminants.
5619
5620             Insert_Actions (N,
5621               New_List (
5622                 Decl,
5623                 Make_Assignment_Statement (Loc,
5624                   Name => New_Occurrence_Of (Temp, Loc),
5625                   Expression => Relocate_Node (N))),
5626                 Suppress => All_Checks);
5627
5628             Rewrite (N, New_Occurrence_Of (Temp, Loc));
5629             return;
5630          end if;
5631       end Handle_Changed_Representation;
5632
5633       ----------------------
5634       -- Real_Range_Check --
5635       ----------------------
5636
5637       --  Case of conversions to floating-point or fixed-point. If range
5638       --  checks are enabled and the target type has a range constraint,
5639       --  we convert:
5640
5641       --     typ (x)
5642
5643       --       to
5644
5645       --     Tnn : typ'Base := typ'Base (x);
5646       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
5647       --     Tnn
5648
5649       --  This is necessary when there is a conversion of integer to float
5650       --  or to fixed-point to ensure that the correct checks are made. It
5651       --  is not necessary for float to float where it is enough to simply
5652       --  set the Do_Range_Check flag.
5653
5654       procedure Real_Range_Check is
5655          Btyp : constant Entity_Id := Base_Type (Target_Type);
5656          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
5657          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
5658          Xtyp : constant Entity_Id := Etype (Operand);
5659          Conv : Node_Id;
5660          Tnn  : Entity_Id;
5661
5662       begin
5663          --  Nothing to do if conversion was rewritten
5664
5665          if Nkind (N) /= N_Type_Conversion then
5666             return;
5667          end if;
5668
5669          --  Nothing to do if range checks suppressed, or target has the
5670          --  same range as the base type (or is the base type).
5671
5672          if Range_Checks_Suppressed (Target_Type)
5673            or else (Lo = Type_Low_Bound (Btyp)
5674                       and then
5675                     Hi = Type_High_Bound (Btyp))
5676          then
5677             return;
5678          end if;
5679
5680          --  Nothing to do if expression is an entity on which checks
5681          --  have been suppressed.
5682
5683          if Is_Entity_Name (Operand)
5684            and then Range_Checks_Suppressed (Entity (Operand))
5685          then
5686             return;
5687          end if;
5688
5689          --  Nothing to do if bounds are all static and we can tell that
5690          --  the expression is within the bounds of the target. Note that
5691          --  if the operand is of an unconstrained floating-point type,
5692          --  then we do not trust it to be in range (might be infinite)
5693
5694          declare
5695             S_Lo : constant Node_Id   := Type_Low_Bound (Xtyp);
5696             S_Hi : constant Node_Id   := Type_High_Bound (Xtyp);
5697
5698          begin
5699             if (not Is_Floating_Point_Type (Xtyp)
5700                  or else Is_Constrained (Xtyp))
5701               and then Compile_Time_Known_Value (S_Lo)
5702               and then Compile_Time_Known_Value (S_Hi)
5703               and then Compile_Time_Known_Value (Hi)
5704               and then Compile_Time_Known_Value (Lo)
5705             then
5706                declare
5707                   D_Lov : constant Ureal := Expr_Value_R (Lo);
5708                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
5709                   S_Lov : Ureal;
5710                   S_Hiv : Ureal;
5711
5712                begin
5713                   if Is_Real_Type (Xtyp) then
5714                      S_Lov := Expr_Value_R (S_Lo);
5715                      S_Hiv := Expr_Value_R (S_Hi);
5716                   else
5717                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
5718                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
5719                   end if;
5720
5721                   if D_Hiv > D_Lov
5722                     and then S_Lov >= D_Lov
5723                     and then S_Hiv <= D_Hiv
5724                   then
5725                      Set_Do_Range_Check (Operand, False);
5726                      return;
5727                   end if;
5728                end;
5729             end if;
5730          end;
5731
5732          --  For float to float conversions, we are done
5733
5734          if Is_Floating_Point_Type (Xtyp)
5735               and then
5736             Is_Floating_Point_Type (Btyp)
5737          then
5738             return;
5739          end if;
5740
5741          --  Otherwise rewrite the conversion as described above
5742
5743          Conv := Relocate_Node (N);
5744          Rewrite
5745            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
5746          Set_Etype (Conv, Btyp);
5747
5748          --  Enable overflow except in the case of integer to float
5749          --  conversions, where it is never required, since we can
5750          --  never have overflow in this case.
5751
5752          if not Is_Integer_Type (Etype (Operand)) then
5753             Enable_Overflow_Check (Conv);
5754          end if;
5755
5756          Tnn :=
5757            Make_Defining_Identifier (Loc,
5758              Chars => New_Internal_Name ('T'));
5759
5760          Insert_Actions (N, New_List (
5761            Make_Object_Declaration (Loc,
5762              Defining_Identifier => Tnn,
5763              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
5764              Expression => Conv),
5765
5766            Make_Raise_Constraint_Error (Loc,
5767              Condition =>
5768               Make_Or_Else (Loc,
5769                 Left_Opnd =>
5770                   Make_Op_Lt (Loc,
5771                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
5772                     Right_Opnd =>
5773                       Make_Attribute_Reference (Loc,
5774                         Attribute_Name => Name_First,
5775                         Prefix =>
5776                           New_Occurrence_Of (Target_Type, Loc))),
5777
5778                 Right_Opnd =>
5779                   Make_Op_Gt (Loc,
5780                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
5781                     Right_Opnd =>
5782                       Make_Attribute_Reference (Loc,
5783                         Attribute_Name => Name_Last,
5784                         Prefix =>
5785                           New_Occurrence_Of (Target_Type, Loc)))),
5786              Reason => CE_Range_Check_Failed)));
5787
5788          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
5789          Analyze_And_Resolve (N, Btyp);
5790       end Real_Range_Check;
5791
5792    --  Start of processing for Expand_N_Type_Conversion
5793
5794    begin
5795       --  Nothing at all to do if conversion is to the identical type
5796       --  so remove the conversion completely, it is useless.
5797
5798       if Operand_Type = Target_Type then
5799          Rewrite (N, Relocate_Node (Operand));
5800          return;
5801       end if;
5802
5803       --  Deal with Vax floating-point cases
5804
5805       if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
5806          Expand_Vax_Conversion (N);
5807          return;
5808       end if;
5809
5810       --  Nothing to do if this is the second argument of read. This
5811       --  is a "backwards" conversion that will be handled by the
5812       --  specialized code in attribute processing.
5813
5814       if Nkind (Parent (N)) = N_Attribute_Reference
5815         and then Attribute_Name (Parent (N)) = Name_Read
5816         and then Next (First (Expressions (Parent (N)))) = N
5817       then
5818          return;
5819       end if;
5820
5821       --  Here if we may need to expand conversion
5822
5823       --  Special case of converting from non-standard boolean type
5824
5825       if Is_Boolean_Type (Operand_Type)
5826         and then (Nonzero_Is_True (Operand_Type))
5827       then
5828          Adjust_Condition (Operand);
5829          Set_Etype (Operand, Standard_Boolean);
5830          Operand_Type := Standard_Boolean;
5831       end if;
5832
5833       --  Case of converting to an access type
5834
5835       if Is_Access_Type (Target_Type) then
5836
5837          --  Apply an accessibility check if the operand is an
5838          --  access parameter. Note that other checks may still
5839          --  need to be applied below (such as tagged type checks).
5840
5841          if Is_Entity_Name (Operand)
5842            and then Ekind (Entity (Operand)) in Formal_Kind
5843            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
5844          then
5845             Apply_Accessibility_Check (Operand, Target_Type);
5846
5847          --  If the level of the operand type is statically deeper
5848          --  then the level of the target type, then force Program_Error.
5849          --  Note that this can only occur for cases where the attribute
5850          --  is within the body of an instantiation (otherwise the
5851          --  conversion will already have been rejected as illegal).
5852          --  Note: warnings are issued by the analyzer for the instance
5853          --  cases.
5854
5855          elsif In_Instance_Body
5856            and then Type_Access_Level (Operand_Type) >
5857                     Type_Access_Level (Target_Type)
5858          then
5859             Rewrite (N,
5860               Make_Raise_Program_Error (Sloc (N),
5861                 Reason => PE_Accessibility_Check_Failed));
5862             Set_Etype (N, Target_Type);
5863
5864          --  When the operand is a selected access discriminant
5865          --  the check needs to be made against the level of the
5866          --  object denoted by the prefix of the selected name.
5867          --  Force Program_Error for this case as well (this
5868          --  accessibility violation can only happen if within
5869          --  the body of an instantiation).
5870
5871          elsif In_Instance_Body
5872            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
5873            and then Nkind (Operand) = N_Selected_Component
5874            and then Object_Access_Level (Operand) >
5875                       Type_Access_Level (Target_Type)
5876          then
5877             Rewrite (N,
5878               Make_Raise_Program_Error (Sloc (N),
5879                 Reason => PE_Accessibility_Check_Failed));
5880             Set_Etype (N, Target_Type);
5881          end if;
5882       end if;
5883
5884       --  Case of conversions of tagged types and access to tagged types
5885
5886       --  When needed, that is to say when the expression is class-wide,
5887       --  Add runtime a tag check for (strict) downward conversion by using
5888       --  the membership test, generating:
5889
5890       --      [constraint_error when Operand not in Target_Type'Class]
5891
5892       --  or in the access type case
5893
5894       --      [constraint_error
5895       --        when Operand /= null
5896       --          and then Operand.all not in
5897       --            Designated_Type (Target_Type)'Class]
5898
5899       if (Is_Access_Type (Target_Type)
5900            and then Is_Tagged_Type (Designated_Type (Target_Type)))
5901         or else Is_Tagged_Type (Target_Type)
5902       then
5903          --  Do not do any expansion in the access type case if the
5904          --  parent is a renaming, since this is an error situation
5905          --  which will be caught by Sem_Ch8, and the expansion can
5906          --  intefere with this error check.
5907
5908          if Is_Access_Type (Target_Type)
5909            and then Is_Renamed_Object (N)
5910          then
5911             return;
5912          end if;
5913
5914          --  Oherwise, proceed with processing tagged conversion
5915
5916          declare
5917             Actual_Operand_Type : Entity_Id;
5918             Actual_Target_Type  : Entity_Id;
5919
5920             Cond : Node_Id;
5921
5922          begin
5923             if Is_Access_Type (Target_Type) then
5924                Actual_Operand_Type := Designated_Type (Operand_Type);
5925                Actual_Target_Type  := Designated_Type (Target_Type);
5926
5927             else
5928                Actual_Operand_Type := Operand_Type;
5929                Actual_Target_Type  := Target_Type;
5930             end if;
5931
5932             if Is_Class_Wide_Type (Actual_Operand_Type)
5933               and then Root_Type (Actual_Operand_Type) /=  Actual_Target_Type
5934               and then Is_Ancestor
5935                          (Root_Type (Actual_Operand_Type),
5936                           Actual_Target_Type)
5937               and then not Tag_Checks_Suppressed (Actual_Target_Type)
5938             then
5939                --  The conversion is valid for any descendant of the
5940                --  target type
5941
5942                Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
5943
5944                if Is_Access_Type (Target_Type) then
5945                   Cond :=
5946                      Make_And_Then (Loc,
5947                        Left_Opnd =>
5948                          Make_Op_Ne (Loc,
5949                            Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
5950                            Right_Opnd => Make_Null (Loc)),
5951
5952                        Right_Opnd =>
5953                          Make_Not_In (Loc,
5954                            Left_Opnd  =>
5955                              Make_Explicit_Dereference (Loc,
5956                                Prefix =>
5957                                  Duplicate_Subexpr_No_Checks (Operand)),
5958                            Right_Opnd =>
5959                              New_Reference_To (Actual_Target_Type, Loc)));
5960
5961                else
5962                   Cond :=
5963                     Make_Not_In (Loc,
5964                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
5965                       Right_Opnd =>
5966                         New_Reference_To (Actual_Target_Type, Loc));
5967                end if;
5968
5969                Insert_Action (N,
5970                  Make_Raise_Constraint_Error (Loc,
5971                    Condition => Cond,
5972                    Reason    => CE_Tag_Check_Failed));
5973
5974                Change_Conversion_To_Unchecked (N);
5975                Analyze_And_Resolve (N, Target_Type);
5976             end if;
5977          end;
5978
5979       --  Case of other access type conversions
5980
5981       elsif Is_Access_Type (Target_Type) then
5982          Apply_Constraint_Check (Operand, Target_Type);
5983
5984       --  Case of conversions from a fixed-point type
5985
5986       --  These conversions require special expansion and processing, found
5987       --  in the Exp_Fixd package. We ignore cases where Conversion_OK is
5988       --  set, since from a semantic point of view, these are simple integer
5989       --  conversions, which do not need further processing.
5990
5991       elsif Is_Fixed_Point_Type (Operand_Type)
5992         and then not Conversion_OK (N)
5993       then
5994          --  We should never see universal fixed at this case, since the
5995          --  expansion of the constituent divide or multiply should have
5996          --  eliminated the explicit mention of universal fixed.
5997
5998          pragma Assert (Operand_Type /= Universal_Fixed);
5999
6000          --  Check for special case of the conversion to universal real
6001          --  that occurs as a result of the use of a round attribute.
6002          --  In this case, the real type for the conversion is taken
6003          --  from the target type of the Round attribute and the
6004          --  result must be marked as rounded.
6005
6006          if Target_Type = Universal_Real
6007            and then Nkind (Parent (N)) = N_Attribute_Reference
6008            and then Attribute_Name (Parent (N)) = Name_Round
6009          then
6010             Set_Rounded_Result (N);
6011             Set_Etype (N, Etype (Parent (N)));
6012          end if;
6013
6014          --  Otherwise do correct fixed-conversion, but skip these if the
6015          --  Conversion_OK flag is set, because from a semantic point of
6016          --  view these are simple integer conversions needing no further
6017          --  processing (the backend will simply treat them as integers)
6018
6019          if not Conversion_OK (N) then
6020             if Is_Fixed_Point_Type (Etype (N)) then
6021                Expand_Convert_Fixed_To_Fixed (N);
6022                Real_Range_Check;
6023
6024             elsif Is_Integer_Type (Etype (N)) then
6025                Expand_Convert_Fixed_To_Integer (N);
6026
6027             else
6028                pragma Assert (Is_Floating_Point_Type (Etype (N)));
6029                Expand_Convert_Fixed_To_Float (N);
6030                Real_Range_Check;
6031             end if;
6032          end if;
6033
6034       --  Case of conversions to a fixed-point type
6035
6036       --  These conversions require special expansion and processing, found
6037       --  in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6038       --  is set, since from a semantic point of view, these are simple
6039       --  integer conversions, which do not need further processing.
6040
6041       elsif Is_Fixed_Point_Type (Target_Type)
6042         and then not Conversion_OK (N)
6043       then
6044          if Is_Integer_Type (Operand_Type) then
6045             Expand_Convert_Integer_To_Fixed (N);
6046             Real_Range_Check;
6047          else
6048             pragma Assert (Is_Floating_Point_Type (Operand_Type));
6049             Expand_Convert_Float_To_Fixed (N);
6050             Real_Range_Check;
6051          end if;
6052
6053       --  Case of float-to-integer conversions
6054
6055       --  We also handle float-to-fixed conversions with Conversion_OK set
6056       --  since semantically the fixed-point target is treated as though it
6057       --  were an integer in such cases.
6058
6059       elsif Is_Floating_Point_Type (Operand_Type)
6060         and then
6061           (Is_Integer_Type (Target_Type)
6062             or else
6063           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
6064       then
6065          --  Special processing required if the conversion is the expression
6066          --  of a Truncation attribute reference. In this case we replace:
6067
6068          --     ityp (ftyp'Truncation (x))
6069
6070          --  by
6071
6072          --     ityp (x)
6073
6074          --  with the Float_Truncate flag set. This is clearly more efficient.
6075
6076          if Nkind (Operand) = N_Attribute_Reference
6077            and then Attribute_Name (Operand) = Name_Truncation
6078          then
6079             Rewrite (Operand,
6080               Relocate_Node (First (Expressions (Operand))));
6081             Set_Float_Truncate (N, True);
6082          end if;
6083
6084          --  One more check here, gcc is still not able to do conversions of
6085          --  this type with proper overflow checking, and so gigi is doing an
6086          --  approximation of what is required by doing floating-point compares
6087          --  with the end-point. But that can lose precision in some cases, and
6088          --  give a wrong result. Converting the operand to Long_Long_Float is
6089          --  helpful, but still does not catch all cases with 64-bit integers
6090          --  on targets with only 64-bit floats ???
6091
6092          if Do_Range_Check (Operand) then
6093             Rewrite (Operand,
6094               Make_Type_Conversion (Loc,
6095                 Subtype_Mark =>
6096                   New_Occurrence_Of (Standard_Long_Long_Float, Loc),
6097                 Expression =>
6098                   Relocate_Node (Operand)));
6099
6100             Set_Etype (Operand, Standard_Long_Long_Float);
6101             Enable_Range_Check (Operand);
6102             Set_Do_Range_Check (Expression (Operand), False);
6103          end if;
6104
6105       --  Case of array conversions
6106
6107       --  Expansion of array conversions, add required length/range checks
6108       --  but only do this if there is no change of representation. For
6109       --  handling of this case, see Handle_Changed_Representation.
6110
6111       elsif Is_Array_Type (Target_Type) then
6112
6113          if Is_Constrained (Target_Type) then
6114             Apply_Length_Check (Operand, Target_Type);
6115          else
6116             Apply_Range_Check (Operand, Target_Type);
6117          end if;
6118
6119          Handle_Changed_Representation;
6120
6121       --  Case of conversions of discriminated types
6122
6123       --  Add required discriminant checks if target is constrained. Again
6124       --  this change is skipped if we have a change of representation.
6125
6126       elsif Has_Discriminants (Target_Type)
6127         and then Is_Constrained (Target_Type)
6128       then
6129          Apply_Discriminant_Check (Operand, Target_Type);
6130          Handle_Changed_Representation;
6131
6132       --  Case of all other record conversions. The only processing required
6133       --  is to check for a change of representation requiring the special
6134       --  assignment processing.
6135
6136       elsif Is_Record_Type (Target_Type) then
6137          Handle_Changed_Representation;
6138
6139       --  Case of conversions of enumeration types
6140
6141       elsif Is_Enumeration_Type (Target_Type) then
6142
6143          --  Special processing is required if there is a change of
6144          --  representation (from enumeration representation clauses)
6145
6146          if not Same_Representation (Target_Type, Operand_Type) then
6147
6148             --  Convert: x(y) to x'val (ytyp'val (y))
6149
6150             Rewrite (N,
6151                Make_Attribute_Reference (Loc,
6152                  Prefix => New_Occurrence_Of (Target_Type, Loc),
6153                  Attribute_Name => Name_Val,
6154                  Expressions => New_List (
6155                    Make_Attribute_Reference (Loc,
6156                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
6157                      Attribute_Name => Name_Pos,
6158                      Expressions => New_List (Operand)))));
6159
6160             Analyze_And_Resolve (N, Target_Type);
6161          end if;
6162
6163       --  Case of conversions to floating-point
6164
6165       elsif Is_Floating_Point_Type (Target_Type) then
6166          Real_Range_Check;
6167
6168       --  The remaining cases require no front end processing
6169
6170       else
6171          null;
6172       end if;
6173
6174       --  At this stage, either the conversion node has been transformed
6175       --  into some other equivalent expression, or left as a conversion
6176       --  that can be handled by Gigi. The conversions that Gigi can handle
6177       --  are the following:
6178
6179       --    Conversions with no change of representation or type
6180
6181       --    Numeric conversions involving integer values, floating-point
6182       --    values, and fixed-point values. Fixed-point values are allowed
6183       --    only if Conversion_OK is set, i.e. if the fixed-point values
6184       --    are to be treated as integers.
6185
6186       --  No other conversions should be passed to Gigi.
6187
6188       --  The only remaining step is to generate a range check if we still
6189       --  have a type conversion at this stage and Do_Range_Check is set.
6190       --  For now we do this only for conversions of discrete types.
6191
6192       if Nkind (N) = N_Type_Conversion
6193         and then Is_Discrete_Type (Etype (N))
6194       then
6195          declare
6196             Expr : constant Node_Id := Expression (N);
6197             Ftyp : Entity_Id;
6198             Ityp : Entity_Id;
6199
6200          begin
6201             if Do_Range_Check (Expr)
6202               and then Is_Discrete_Type (Etype (Expr))
6203             then
6204                Set_Do_Range_Check (Expr, False);
6205
6206                --  Before we do a range check, we have to deal with treating
6207                --  a fixed-point operand as an integer. The way we do this
6208                --  is simply to do an unchecked conversion to an appropriate
6209                --  integer type large enough to hold the result.
6210
6211                --  This code is not active yet, because we are only dealing
6212                --  with discrete types so far ???
6213
6214                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
6215                  and then Treat_Fixed_As_Integer (Expr)
6216                then
6217                   Ftyp := Base_Type (Etype (Expr));
6218
6219                   if Esize (Ftyp) >= Esize (Standard_Integer) then
6220                      Ityp := Standard_Long_Long_Integer;
6221                   else
6222                      Ityp := Standard_Integer;
6223                   end if;
6224
6225                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
6226                end if;
6227
6228                --  Reset overflow flag, since the range check will include
6229                --  dealing with possible overflow, and generate the check
6230
6231                Set_Do_Overflow_Check (N, False);
6232                Generate_Range_Check
6233                  (Expr, Target_Type, CE_Range_Check_Failed);
6234             end if;
6235          end;
6236       end if;
6237    end Expand_N_Type_Conversion;
6238
6239    -----------------------------------
6240    -- Expand_N_Unchecked_Expression --
6241    -----------------------------------
6242
6243    --  Remove the unchecked expression node from the tree. It's job was simply
6244    --  to make sure that its constituent expression was handled with checks
6245    --  off, and now that that is done, we can remove it from the tree, and
6246    --  indeed must, since gigi does not expect to see these nodes.
6247
6248    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
6249       Exp : constant Node_Id := Expression (N);
6250
6251    begin
6252       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
6253       Rewrite (N, Exp);
6254    end Expand_N_Unchecked_Expression;
6255
6256    ----------------------------------------
6257    -- Expand_N_Unchecked_Type_Conversion --
6258    ----------------------------------------
6259
6260    --  If this cannot be handled by Gigi and we haven't already made
6261    --  a temporary for it, do it now.
6262
6263    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
6264       Target_Type  : constant Entity_Id := Etype (N);
6265       Operand      : constant Node_Id   := Expression (N);
6266       Operand_Type : constant Entity_Id := Etype (Operand);
6267
6268    begin
6269       --  If we have a conversion of a compile time known value to a target
6270       --  type and the value is in range of the target type, then we can simply
6271       --  replace the construct by an integer literal of the correct type. We
6272       --  only apply this to integer types being converted. Possibly it may
6273       --  apply in other cases, but it is too much trouble to worry about.
6274
6275       --  Note that we do not do this transformation if the Kill_Range_Check
6276       --  flag is set, since then the value may be outside the expected range.
6277       --  This happens in the Normalize_Scalars case.
6278
6279       if Is_Integer_Type (Target_Type)
6280         and then Is_Integer_Type (Operand_Type)
6281         and then Compile_Time_Known_Value (Operand)
6282         and then not Kill_Range_Check (N)
6283       then
6284          declare
6285             Val : constant Uint := Expr_Value (Operand);
6286
6287          begin
6288             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
6289                  and then
6290                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
6291                  and then
6292                Val >= Expr_Value (Type_Low_Bound (Target_Type))
6293                  and then
6294                Val <= Expr_Value (Type_High_Bound (Target_Type))
6295             then
6296                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
6297                Analyze_And_Resolve (N, Target_Type);
6298                return;
6299             end if;
6300          end;
6301       end if;
6302
6303       --  Nothing to do if conversion is safe
6304
6305       if Safe_Unchecked_Type_Conversion (N) then
6306          return;
6307       end if;
6308
6309       --  Otherwise force evaluation unless Assignment_OK flag is set (this
6310       --  flag indicates ??? -- more comments needed here)
6311
6312       if Assignment_OK (N) then
6313          null;
6314       else
6315          Force_Evaluation (N);
6316       end if;
6317    end Expand_N_Unchecked_Type_Conversion;
6318
6319    ----------------------------
6320    -- Expand_Record_Equality --
6321    ----------------------------
6322
6323    --  For non-variant records, Equality is expanded when needed into:
6324
6325    --      and then Lhs.Discr1 = Rhs.Discr1
6326    --      and then ...
6327    --      and then Lhs.Discrn = Rhs.Discrn
6328    --      and then Lhs.Cmp1 = Rhs.Cmp1
6329    --      and then ...
6330    --      and then Lhs.Cmpn = Rhs.Cmpn
6331
6332    --  The expression is folded by the back-end for adjacent fields. This
6333    --  function is called for tagged record in only one occasion: for imple-
6334    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
6335    --  otherwise the primitive "=" is used directly.
6336
6337    function Expand_Record_Equality
6338      (Nod    : Node_Id;
6339       Typ    : Entity_Id;
6340       Lhs    : Node_Id;
6341       Rhs    : Node_Id;
6342       Bodies : List_Id)
6343       return   Node_Id
6344    is
6345       Loc : constant Source_Ptr := Sloc (Nod);
6346
6347       function Suitable_Element (C : Entity_Id) return Entity_Id;
6348       --  Return the first field to compare beginning with C, skipping the
6349       --  inherited components
6350
6351       function Suitable_Element (C : Entity_Id) return Entity_Id is
6352       begin
6353          if No (C) then
6354             return Empty;
6355
6356          elsif Ekind (C) /= E_Discriminant
6357            and then Ekind (C) /= E_Component
6358          then
6359             return Suitable_Element (Next_Entity (C));
6360
6361          elsif Is_Tagged_Type (Typ)
6362            and then C /= Original_Record_Component (C)
6363          then
6364             return Suitable_Element (Next_Entity (C));
6365
6366          elsif Chars (C) = Name_uController
6367            or else Chars (C) = Name_uTag
6368          then
6369             return Suitable_Element (Next_Entity (C));
6370
6371          else
6372             return C;
6373          end if;
6374       end Suitable_Element;
6375
6376       Result : Node_Id;
6377       C      : Entity_Id;
6378
6379       First_Time : Boolean := True;
6380
6381    --  Start of processing for Expand_Record_Equality
6382
6383    begin
6384       --  Special processing for the unchecked union case, which will occur
6385       --  only in the context of tagged types and dynamic dispatching, since
6386       --  other cases are handled statically. We return True, but insert a
6387       --  raise Program_Error statement.
6388
6389       if Is_Unchecked_Union (Typ) then
6390
6391          --  If this is a component of an enclosing record, return the Raise
6392          --  statement directly.
6393
6394          if No (Parent (Lhs)) then
6395             Result :=
6396               Make_Raise_Program_Error (Loc,
6397                 Reason => PE_Unchecked_Union_Restriction);
6398             Set_Etype (Result, Standard_Boolean);
6399             return Result;
6400
6401          else
6402             Insert_Action (Lhs,
6403               Make_Raise_Program_Error (Loc,
6404                 Reason => PE_Unchecked_Union_Restriction));
6405             return New_Occurrence_Of (Standard_True, Loc);
6406          end if;
6407       end if;
6408
6409       --  Generates the following code: (assuming that Typ has one Discr and
6410       --  component C2 is also a record)
6411
6412       --   True
6413       --     and then Lhs.Discr1 = Rhs.Discr1
6414       --     and then Lhs.C1 = Rhs.C1
6415       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
6416       --     and then ...
6417       --     and then Lhs.Cmpn = Rhs.Cmpn
6418
6419       Result := New_Reference_To (Standard_True, Loc);
6420       C := Suitable_Element (First_Entity (Typ));
6421
6422       while Present (C) loop
6423
6424          declare
6425             New_Lhs : Node_Id;
6426             New_Rhs : Node_Id;
6427
6428          begin
6429             if First_Time then
6430                First_Time := False;
6431                New_Lhs := Lhs;
6432                New_Rhs := Rhs;
6433
6434             else
6435                New_Lhs := New_Copy_Tree (Lhs);
6436                New_Rhs := New_Copy_Tree (Rhs);
6437             end if;
6438
6439             Result :=
6440               Make_And_Then (Loc,
6441                 Left_Opnd  => Result,
6442                 Right_Opnd =>
6443                   Expand_Composite_Equality (Nod, Etype (C),
6444                     Lhs =>
6445                       Make_Selected_Component (Loc,
6446                         Prefix => New_Lhs,
6447                         Selector_Name => New_Reference_To (C, Loc)),
6448                     Rhs =>
6449                       Make_Selected_Component (Loc,
6450                         Prefix => New_Rhs,
6451                         Selector_Name => New_Reference_To (C, Loc)),
6452                     Bodies => Bodies));
6453          end;
6454
6455          C := Suitable_Element (Next_Entity (C));
6456       end loop;
6457
6458       return Result;
6459    end Expand_Record_Equality;
6460
6461    -------------------------------------
6462    -- Fixup_Universal_Fixed_Operation --
6463    -------------------------------------
6464
6465    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
6466       Conv : constant Node_Id := Parent (N);
6467
6468    begin
6469       --  We must have a type conversion immediately above us
6470
6471       pragma Assert (Nkind (Conv) = N_Type_Conversion);
6472
6473       --  Normally the type conversion gives our target type. The exception
6474       --  occurs in the case of the Round attribute, where the conversion
6475       --  will be to universal real, and our real type comes from the Round
6476       --  attribute (as well as an indication that we must round the result)
6477
6478       if Nkind (Parent (Conv)) = N_Attribute_Reference
6479         and then Attribute_Name (Parent (Conv)) = Name_Round
6480       then
6481          Set_Etype (N, Etype (Parent (Conv)));
6482          Set_Rounded_Result (N);
6483
6484       --  Normal case where type comes from conversion above us
6485
6486       else
6487          Set_Etype (N, Etype (Conv));
6488       end if;
6489    end Fixup_Universal_Fixed_Operation;
6490
6491    ------------------------------
6492    -- Get_Allocator_Final_List --
6493    ------------------------------
6494
6495    function Get_Allocator_Final_List
6496      (N    : Node_Id;
6497       T    : Entity_Id;
6498       PtrT : Entity_Id)
6499       return Entity_Id
6500    is
6501       Loc : constant Source_Ptr := Sloc (N);
6502       Acc : Entity_Id;
6503
6504    begin
6505       --  If the context is an access parameter, we need to create
6506       --  a non-anonymous access type in order to have a usable
6507       --  final list, because there is otherwise no pool to which
6508       --  the allocated object can belong. We create both the type
6509       --  and the finalization chain here, because freezing an
6510       --  internal type does not create such a chain. The Final_Chain
6511       --  that is thus created is shared by the access parameter.
6512
6513       if Ekind (PtrT) = E_Anonymous_Access_Type then
6514          Acc := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
6515          Insert_Action (N,
6516            Make_Full_Type_Declaration (Loc,
6517              Defining_Identifier => Acc,
6518              Type_Definition =>
6519                 Make_Access_To_Object_Definition (Loc,
6520                   Subtype_Indication =>
6521                     New_Occurrence_Of (T, Loc))));
6522
6523          Build_Final_List (N, Acc);
6524          Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc));
6525          return Find_Final_List (Acc);
6526
6527       else
6528          return Find_Final_List (PtrT);
6529       end if;
6530    end Get_Allocator_Final_List;
6531
6532    -------------------------------
6533    -- Insert_Dereference_Action --
6534    -------------------------------
6535
6536    procedure Insert_Dereference_Action (N : Node_Id) is
6537       Loc  : constant Source_Ptr := Sloc (N);
6538       Typ  : constant Entity_Id  := Etype (N);
6539       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
6540
6541       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
6542       --  return true if type of P is derived from Checked_Pool;
6543
6544       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
6545          T : Entity_Id;
6546
6547       begin
6548          if No (P) then
6549             return False;
6550          end if;
6551
6552          T := Etype (P);
6553          while T /= Etype (T) loop
6554             if Is_RTE (T, RE_Checked_Pool) then
6555                return True;
6556             else
6557                T := Etype (T);
6558             end if;
6559          end loop;
6560
6561          return False;
6562       end Is_Checked_Storage_Pool;
6563
6564    --  Start of processing for Insert_Dereference_Action
6565
6566    begin
6567       if not Comes_From_Source (Parent (N)) then
6568          return;
6569
6570       elsif not Is_Checked_Storage_Pool (Pool) then
6571          return;
6572       end if;
6573
6574       Insert_Action (N,
6575         Make_Procedure_Call_Statement (Loc,
6576           Name => New_Reference_To (
6577             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
6578
6579           Parameter_Associations => New_List (
6580
6581             --  Pool
6582
6583              New_Reference_To (Pool, Loc),
6584
6585             --  Storage_Address. We use the attribute Pool_Address,
6586             --  which uses the pointer itself to find the address of
6587             --  the object, and which handles unconstrained arrays
6588             --  properly by computing the address of the template.
6589             --  i.e. the correct address of the corresponding allocation.
6590
6591              Make_Attribute_Reference (Loc,
6592                Prefix         => Duplicate_Subexpr_Move_Checks (N),
6593                Attribute_Name => Name_Pool_Address),
6594
6595             --  Size_In_Storage_Elements
6596
6597              Make_Op_Divide (Loc,
6598                Left_Opnd  =>
6599                 Make_Attribute_Reference (Loc,
6600                   Prefix         =>
6601                     Make_Explicit_Dereference (Loc,
6602                       Duplicate_Subexpr_Move_Checks (N)),
6603                   Attribute_Name => Name_Size),
6604                Right_Opnd =>
6605                  Make_Integer_Literal (Loc, System_Storage_Unit)),
6606
6607             --  Alignment
6608
6609              Make_Attribute_Reference (Loc,
6610                Prefix         =>
6611                  Make_Explicit_Dereference (Loc,
6612                    Duplicate_Subexpr_Move_Checks (N)),
6613                Attribute_Name => Name_Alignment))));
6614
6615    exception
6616       when RE_Not_Available =>
6617          return;
6618    end Insert_Dereference_Action;
6619
6620    ------------------------------
6621    -- Make_Array_Comparison_Op --
6622    ------------------------------
6623
6624    --  This is a hand-coded expansion of the following generic function:
6625
6626    --  generic
6627    --    type elem is  (<>);
6628    --    type index is (<>);
6629    --    type a is array (index range <>) of elem;
6630    --
6631    --  function Gnnn (X : a; Y: a) return boolean is
6632    --    J : index := Y'first;
6633    --
6634    --  begin
6635    --    if X'length = 0 then
6636    --       return false;
6637    --
6638    --    elsif Y'length = 0 then
6639    --       return true;
6640    --
6641    --    else
6642    --      for I in X'range loop
6643    --        if X (I) = Y (J) then
6644    --          if J = Y'last then
6645    --            exit;
6646    --          else
6647    --            J := index'succ (J);
6648    --          end if;
6649    --
6650    --        else
6651    --           return X (I) > Y (J);
6652    --        end if;
6653    --      end loop;
6654    --
6655    --      return X'length > Y'length;
6656    --    end if;
6657    --  end Gnnn;
6658
6659    --  Note that since we are essentially doing this expansion by hand, we
6660    --  do not need to generate an actual or formal generic part, just the
6661    --  instantiated function itself.
6662
6663    function Make_Array_Comparison_Op
6664      (Typ   : Entity_Id;
6665       Nod   : Node_Id)
6666       return  Node_Id
6667    is
6668       Loc : constant Source_Ptr := Sloc (Nod);
6669
6670       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
6671       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
6672       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
6673       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
6674
6675       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
6676
6677       Loop_Statement : Node_Id;
6678       Loop_Body      : Node_Id;
6679       If_Stat        : Node_Id;
6680       Inner_If       : Node_Id;
6681       Final_Expr     : Node_Id;
6682       Func_Body      : Node_Id;
6683       Func_Name      : Entity_Id;
6684       Formals        : List_Id;
6685       Length1        : Node_Id;
6686       Length2        : Node_Id;
6687
6688    begin
6689       --  if J = Y'last then
6690       --     exit;
6691       --  else
6692       --     J := index'succ (J);
6693       --  end if;
6694
6695       Inner_If :=
6696         Make_Implicit_If_Statement (Nod,
6697           Condition =>
6698             Make_Op_Eq (Loc,
6699               Left_Opnd => New_Reference_To (J, Loc),
6700               Right_Opnd =>
6701                 Make_Attribute_Reference (Loc,
6702                   Prefix => New_Reference_To (Y, Loc),
6703                   Attribute_Name => Name_Last)),
6704
6705           Then_Statements => New_List (
6706                 Make_Exit_Statement (Loc)),
6707
6708           Else_Statements =>
6709             New_List (
6710               Make_Assignment_Statement (Loc,
6711                 Name => New_Reference_To (J, Loc),
6712                 Expression =>
6713                   Make_Attribute_Reference (Loc,
6714                     Prefix => New_Reference_To (Index, Loc),
6715                     Attribute_Name => Name_Succ,
6716                     Expressions => New_List (New_Reference_To (J, Loc))))));
6717
6718       --  if X (I) = Y (J) then
6719       --     if ... end if;
6720       --  else
6721       --     return X (I) > Y (J);
6722       --  end if;
6723
6724       Loop_Body :=
6725         Make_Implicit_If_Statement (Nod,
6726           Condition =>
6727             Make_Op_Eq (Loc,
6728               Left_Opnd =>
6729                 Make_Indexed_Component (Loc,
6730                   Prefix      => New_Reference_To (X, Loc),
6731                   Expressions => New_List (New_Reference_To (I, Loc))),
6732
6733               Right_Opnd =>
6734                 Make_Indexed_Component (Loc,
6735                   Prefix      => New_Reference_To (Y, Loc),
6736                   Expressions => New_List (New_Reference_To (J, Loc)))),
6737
6738           Then_Statements => New_List (Inner_If),
6739
6740           Else_Statements => New_List (
6741             Make_Return_Statement (Loc,
6742               Expression =>
6743                 Make_Op_Gt (Loc,
6744                   Left_Opnd =>
6745                     Make_Indexed_Component (Loc,
6746                       Prefix      => New_Reference_To (X, Loc),
6747                       Expressions => New_List (New_Reference_To (I, Loc))),
6748
6749                   Right_Opnd =>
6750                     Make_Indexed_Component (Loc,
6751                       Prefix      => New_Reference_To (Y, Loc),
6752                       Expressions => New_List (
6753                         New_Reference_To (J, Loc)))))));
6754
6755       --  for I in X'range loop
6756       --     if ... end if;
6757       --  end loop;
6758
6759       Loop_Statement :=
6760         Make_Implicit_Loop_Statement (Nod,
6761           Identifier => Empty,
6762
6763           Iteration_Scheme =>
6764             Make_Iteration_Scheme (Loc,
6765               Loop_Parameter_Specification =>
6766                 Make_Loop_Parameter_Specification (Loc,
6767                   Defining_Identifier => I,
6768                   Discrete_Subtype_Definition =>
6769                     Make_Attribute_Reference (Loc,
6770                       Prefix => New_Reference_To (X, Loc),
6771                       Attribute_Name => Name_Range))),
6772
6773           Statements => New_List (Loop_Body));
6774
6775       --    if X'length = 0 then
6776       --       return false;
6777       --    elsif Y'length = 0 then
6778       --       return true;
6779       --    else
6780       --      for ... loop ... end loop;
6781       --      return X'length > Y'length;
6782       --    end if;
6783
6784       Length1 :=
6785         Make_Attribute_Reference (Loc,
6786           Prefix => New_Reference_To (X, Loc),
6787           Attribute_Name => Name_Length);
6788
6789       Length2 :=
6790         Make_Attribute_Reference (Loc,
6791           Prefix => New_Reference_To (Y, Loc),
6792           Attribute_Name => Name_Length);
6793
6794       Final_Expr :=
6795         Make_Op_Gt (Loc,
6796           Left_Opnd  => Length1,
6797           Right_Opnd => Length2);
6798
6799       If_Stat :=
6800         Make_Implicit_If_Statement (Nod,
6801           Condition =>
6802             Make_Op_Eq (Loc,
6803               Left_Opnd =>
6804                 Make_Attribute_Reference (Loc,
6805                   Prefix => New_Reference_To (X, Loc),
6806                   Attribute_Name => Name_Length),
6807               Right_Opnd =>
6808                 Make_Integer_Literal (Loc, 0)),
6809
6810           Then_Statements =>
6811             New_List (
6812               Make_Return_Statement (Loc,
6813                 Expression => New_Reference_To (Standard_False, Loc))),
6814
6815           Elsif_Parts => New_List (
6816             Make_Elsif_Part (Loc,
6817               Condition =>
6818                 Make_Op_Eq (Loc,
6819                   Left_Opnd =>
6820                     Make_Attribute_Reference (Loc,
6821                       Prefix => New_Reference_To (Y, Loc),
6822                       Attribute_Name => Name_Length),
6823                   Right_Opnd =>
6824                     Make_Integer_Literal (Loc, 0)),
6825
6826               Then_Statements =>
6827                 New_List (
6828                   Make_Return_Statement (Loc,
6829                      Expression => New_Reference_To (Standard_True, Loc))))),
6830
6831           Else_Statements => New_List (
6832             Loop_Statement,
6833             Make_Return_Statement (Loc,
6834               Expression => Final_Expr)));
6835
6836       --  (X : a; Y: a)
6837
6838       Formals := New_List (
6839         Make_Parameter_Specification (Loc,
6840           Defining_Identifier => X,
6841           Parameter_Type      => New_Reference_To (Typ, Loc)),
6842
6843         Make_Parameter_Specification (Loc,
6844           Defining_Identifier => Y,
6845           Parameter_Type      => New_Reference_To (Typ, Loc)));
6846
6847       --  function Gnnn (...) return boolean is
6848       --    J : index := Y'first;
6849       --  begin
6850       --    if ... end if;
6851       --  end Gnnn;
6852
6853       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
6854
6855       Func_Body :=
6856         Make_Subprogram_Body (Loc,
6857           Specification =>
6858             Make_Function_Specification (Loc,
6859               Defining_Unit_Name       => Func_Name,
6860               Parameter_Specifications => Formals,
6861               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
6862
6863           Declarations => New_List (
6864             Make_Object_Declaration (Loc,
6865               Defining_Identifier => J,
6866               Object_Definition   => New_Reference_To (Index, Loc),
6867               Expression =>
6868                 Make_Attribute_Reference (Loc,
6869                   Prefix => New_Reference_To (Y, Loc),
6870                   Attribute_Name => Name_First))),
6871
6872           Handled_Statement_Sequence =>
6873             Make_Handled_Sequence_Of_Statements (Loc,
6874               Statements => New_List (If_Stat)));
6875
6876       return Func_Body;
6877
6878    end Make_Array_Comparison_Op;
6879
6880    ---------------------------
6881    -- Make_Boolean_Array_Op --
6882    ---------------------------
6883
6884    --  For logical operations on boolean arrays, expand in line the
6885    --  following, replacing 'and' with 'or' or 'xor' where needed:
6886
6887    --    function Annn (A : typ; B: typ) return typ is
6888    --       C : typ;
6889    --    begin
6890    --       for J in A'range loop
6891    --          C (J) := A (J) op B (J);
6892    --       end loop;
6893    --       return C;
6894    --    end Annn;
6895
6896    --  Here typ is the boolean array type
6897
6898    function Make_Boolean_Array_Op
6899      (Typ  : Entity_Id;
6900       N    : Node_Id)
6901       return Node_Id
6902    is
6903       Loc : constant Source_Ptr := Sloc (N);
6904
6905       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
6906       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
6907       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
6908       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
6909
6910       A_J : Node_Id;
6911       B_J : Node_Id;
6912       C_J : Node_Id;
6913       Op  : Node_Id;
6914
6915       Formals        : List_Id;
6916       Func_Name      : Entity_Id;
6917       Func_Body      : Node_Id;
6918       Loop_Statement : Node_Id;
6919
6920    begin
6921       A_J :=
6922         Make_Indexed_Component (Loc,
6923           Prefix      => New_Reference_To (A, Loc),
6924           Expressions => New_List (New_Reference_To (J, Loc)));
6925
6926       B_J :=
6927         Make_Indexed_Component (Loc,
6928           Prefix      => New_Reference_To (B, Loc),
6929           Expressions => New_List (New_Reference_To (J, Loc)));
6930
6931       C_J :=
6932         Make_Indexed_Component (Loc,
6933           Prefix      => New_Reference_To (C, Loc),
6934           Expressions => New_List (New_Reference_To (J, Loc)));
6935
6936       if Nkind (N) = N_Op_And then
6937          Op :=
6938            Make_Op_And (Loc,
6939              Left_Opnd  => A_J,
6940              Right_Opnd => B_J);
6941
6942       elsif Nkind (N) = N_Op_Or then
6943          Op :=
6944            Make_Op_Or (Loc,
6945              Left_Opnd  => A_J,
6946              Right_Opnd => B_J);
6947
6948       else
6949          Op :=
6950            Make_Op_Xor (Loc,
6951              Left_Opnd  => A_J,
6952              Right_Opnd => B_J);
6953       end if;
6954
6955       Loop_Statement :=
6956         Make_Implicit_Loop_Statement (N,
6957           Identifier => Empty,
6958
6959           Iteration_Scheme =>
6960             Make_Iteration_Scheme (Loc,
6961               Loop_Parameter_Specification =>
6962                 Make_Loop_Parameter_Specification (Loc,
6963                   Defining_Identifier => J,
6964                   Discrete_Subtype_Definition =>
6965                     Make_Attribute_Reference (Loc,
6966                       Prefix => New_Reference_To (A, Loc),
6967                       Attribute_Name => Name_Range))),
6968
6969           Statements => New_List (
6970             Make_Assignment_Statement (Loc,
6971               Name       => C_J,
6972               Expression => Op)));
6973
6974       Formals := New_List (
6975         Make_Parameter_Specification (Loc,
6976           Defining_Identifier => A,
6977           Parameter_Type      => New_Reference_To (Typ, Loc)),
6978
6979         Make_Parameter_Specification (Loc,
6980           Defining_Identifier => B,
6981           Parameter_Type      => New_Reference_To (Typ, Loc)));
6982
6983       Func_Name :=
6984         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
6985       Set_Is_Inlined (Func_Name);
6986
6987       Func_Body :=
6988         Make_Subprogram_Body (Loc,
6989           Specification =>
6990             Make_Function_Specification (Loc,
6991               Defining_Unit_Name       => Func_Name,
6992               Parameter_Specifications => Formals,
6993               Subtype_Mark             => New_Reference_To (Typ, Loc)),
6994
6995           Declarations => New_List (
6996             Make_Object_Declaration (Loc,
6997               Defining_Identifier => C,
6998               Object_Definition   => New_Reference_To (Typ, Loc))),
6999
7000           Handled_Statement_Sequence =>
7001             Make_Handled_Sequence_Of_Statements (Loc,
7002               Statements => New_List (
7003                 Loop_Statement,
7004                 Make_Return_Statement (Loc,
7005                   Expression => New_Reference_To (C, Loc)))));
7006
7007       return Func_Body;
7008    end Make_Boolean_Array_Op;
7009
7010    ------------------------
7011    -- Rewrite_Comparison --
7012    ------------------------
7013
7014    procedure Rewrite_Comparison (N : Node_Id) is
7015       Typ : constant Entity_Id := Etype (N);
7016       Op1 : constant Node_Id   := Left_Opnd (N);
7017       Op2 : constant Node_Id   := Right_Opnd (N);
7018
7019       Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
7020       --  Res indicates if compare outcome can be determined at compile time
7021
7022       True_Result  : Boolean;
7023       False_Result : Boolean;
7024
7025    begin
7026       case N_Op_Compare (Nkind (N)) is
7027          when N_Op_Eq =>
7028             True_Result  := Res = EQ;
7029             False_Result := Res = LT or else Res = GT or else Res = NE;
7030
7031          when N_Op_Ge =>
7032             True_Result  := Res in Compare_GE;
7033             False_Result := Res = LT;
7034
7035          when N_Op_Gt =>
7036             True_Result  := Res = GT;
7037             False_Result := Res in Compare_LE;
7038
7039          when N_Op_Lt =>
7040             True_Result  := Res = LT;
7041             False_Result := Res in Compare_GE;
7042
7043          when N_Op_Le =>
7044             True_Result  := Res in Compare_LE;
7045             False_Result := Res = GT;
7046
7047          when N_Op_Ne =>
7048             True_Result  := Res = NE;
7049             False_Result := Res = LT or else Res = GT or else Res = EQ;
7050       end case;
7051
7052       if True_Result then
7053          Rewrite (N,
7054            Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
7055          Analyze_And_Resolve (N, Typ);
7056          Warn_On_Known_Condition (N);
7057
7058       elsif False_Result then
7059          Rewrite (N,
7060            Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
7061          Analyze_And_Resolve (N, Typ);
7062          Warn_On_Known_Condition (N);
7063       end if;
7064    end Rewrite_Comparison;
7065
7066    ----------------------------
7067    -- Safe_In_Place_Array_Op --
7068    ----------------------------
7069
7070    function Safe_In_Place_Array_Op
7071      (Lhs  : Node_Id;
7072       Op1  : Node_Id;
7073       Op2  : Node_Id)
7074       return Boolean
7075    is
7076       Target : Entity_Id;
7077
7078       function Is_Safe_Operand (Op : Node_Id) return Boolean;
7079       --  Operand is safe if it cannot overlap part of the target of the
7080       --  operation. If the operand and the target are identical, the operand
7081       --  is safe. The operand can be empty in the case of negation.
7082
7083       function Is_Unaliased (N : Node_Id) return Boolean;
7084       --  Check that N is a stand-alone entity.
7085
7086       ------------------
7087       -- Is_Unaliased --
7088       ------------------
7089
7090       function Is_Unaliased (N : Node_Id) return Boolean is
7091       begin
7092          return
7093            Is_Entity_Name (N)
7094              and then No (Address_Clause (Entity (N)))
7095              and then No (Renamed_Object (Entity (N)));
7096       end Is_Unaliased;
7097
7098       ---------------------
7099       -- Is_Safe_Operand --
7100       ---------------------
7101
7102       function Is_Safe_Operand (Op : Node_Id) return Boolean is
7103       begin
7104          if No (Op) then
7105             return True;
7106
7107          elsif Is_Entity_Name (Op) then
7108             return Is_Unaliased (Op);
7109
7110          elsif Nkind (Op) = N_Indexed_Component
7111            or else Nkind (Op) = N_Selected_Component
7112          then
7113             return Is_Unaliased (Prefix (Op));
7114
7115          elsif Nkind (Op) = N_Slice then
7116             return
7117               Is_Unaliased (Prefix (Op))
7118                 and then Entity (Prefix (Op)) /= Target;
7119
7120          elsif Nkind (Op) = N_Op_Not then
7121             return Is_Safe_Operand (Right_Opnd (Op));
7122
7123          else
7124             return False;
7125          end if;
7126       end Is_Safe_Operand;
7127
7128       --  Start of processing for Is_Safe_In_Place_Array_Op
7129
7130    begin
7131       --  We skip this processing if the component size is not the
7132       --  same as a system storage unit (since at least for NOT
7133       --  this would cause problems).
7134
7135       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
7136          return False;
7137
7138       --  Cannot do in place stuff on Java_VM since cannot pass addresses
7139
7140       elsif Java_VM then
7141          return False;
7142
7143       --  Cannot do in place stuff if non-standard Boolean representation
7144
7145       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
7146          return False;
7147
7148       elsif not Is_Unaliased (Lhs) then
7149          return False;
7150       else
7151          Target := Entity (Lhs);
7152
7153          return
7154            Is_Safe_Operand (Op1)
7155              and then Is_Safe_Operand (Op2);
7156       end if;
7157    end Safe_In_Place_Array_Op;
7158
7159    -----------------------
7160    -- Tagged_Membership --
7161    -----------------------
7162
7163    --  There are two different cases to consider depending on whether
7164    --  the right operand is a class-wide type or not. If not we just
7165    --  compare the actual tag of the left expr to the target type tag:
7166    --
7167    --     Left_Expr.Tag = Right_Type'Tag;
7168    --
7169    --  If it is a class-wide type we use the RT function CW_Membership which
7170    --  is usually implemented by looking in the ancestor tables contained in
7171    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7172
7173    function Tagged_Membership (N : Node_Id) return Node_Id is
7174       Left  : constant Node_Id    := Left_Opnd  (N);
7175       Right : constant Node_Id    := Right_Opnd (N);
7176       Loc   : constant Source_Ptr := Sloc (N);
7177
7178       Left_Type  : Entity_Id;
7179       Right_Type : Entity_Id;
7180       Obj_Tag    : Node_Id;
7181
7182    begin
7183       Left_Type  := Etype (Left);
7184       Right_Type := Etype (Right);
7185
7186       if Is_Class_Wide_Type (Left_Type) then
7187          Left_Type := Root_Type (Left_Type);
7188       end if;
7189
7190       Obj_Tag :=
7191         Make_Selected_Component (Loc,
7192           Prefix        => Relocate_Node (Left),
7193           Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
7194
7195       if Is_Class_Wide_Type (Right_Type) then
7196          return
7197            Make_DT_Access_Action (Left_Type,
7198              Action => CW_Membership,
7199              Args   => New_List (
7200                Obj_Tag,
7201                New_Reference_To (
7202                  Access_Disp_Table (Root_Type (Right_Type)), Loc)));
7203       else
7204          return
7205            Make_Op_Eq (Loc,
7206            Left_Opnd  => Obj_Tag,
7207            Right_Opnd =>
7208              New_Reference_To (Access_Disp_Table (Right_Type), Loc));
7209       end if;
7210
7211    end Tagged_Membership;
7212
7213    ------------------------------
7214    -- Unary_Op_Validity_Checks --
7215    ------------------------------
7216
7217    procedure Unary_Op_Validity_Checks (N : Node_Id) is
7218    begin
7219       if Validity_Checks_On and Validity_Check_Operands then
7220          Ensure_Valid (Right_Opnd (N));
7221       end if;
7222    end Unary_Op_Validity_Checks;
7223
7224 end Exp_Ch4;