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