gcc/ada/exp_ch4.adb

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