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