gcc/ada/exp_ch4.adb

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