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