gcc/ada/exp_ch4.adb

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