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-2008, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Aggr; use Exp_Aggr;
  32 with Exp_Atag; use Exp_Atag;
  33 with Exp_Ch3;  use Exp_Ch3;
  34 with Exp_Ch6;  use Exp_Ch6;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Disp; use Exp_Disp;
  38 with Exp_Fixd; use Exp_Fixd;
  39 with Exp_Pakd; use Exp_Pakd;
  40 with Exp_Tss;  use Exp_Tss;
  41 with Exp_Util; use Exp_Util;
  42 with Exp_VFpt; use Exp_VFpt;
  43 with Freeze;   use Freeze;
  44 with Inline;   use Inline;
  45 with Namet;    use Namet;
  46 with Nlists;   use Nlists;
  47 with Nmake;    use Nmake;
  48 with Opt;      use Opt;
  49 with Restrict; use Restrict;
  50 with Rident;   use Rident;
  51 with Rtsfind;  use Rtsfind;
  52 with Sem;      use Sem;
  53 with Sem_Cat;  use Sem_Cat;
  54 with Sem_Ch3;  use Sem_Ch3;
  55 with Sem_Ch8;  use Sem_Ch8;
  56 with Sem_Ch13; use Sem_Ch13;
  57 with Sem_Eval; use Sem_Eval;
  58 with Sem_Res;  use Sem_Res;
  59 with Sem_Type; use Sem_Type;
  60 with Sem_Util; use Sem_Util;
  61 with Sem_Warn; use Sem_Warn;
  62 with Sinfo;    use Sinfo;
  63 with Snames;   use Snames;
  64 with Stand;    use Stand;
  65 with Targparm; use Targparm;
  66 with Tbuild;   use Tbuild;
  67 with Ttypes;   use Ttypes;
  68 with Uintp;    use Uintp;
  69 with Urealp;   use Urealp;
  70 with Validsw;  use Validsw;
  71
  72 package body Exp_Ch4 is
  73
  74    -----------------------
  75    -- Local Subprograms --
  76    -----------------------
  77
  78    procedure Binary_Op_Validity_Checks (N : Node_Id);
  79    pragma Inline (Binary_Op_Validity_Checks);
  80    --  Performs validity checks for a binary operator
  81
  82    procedure Build_Boolean_Array_Proc_Call
  83      (N   : Node_Id;
  84       Op1 : Node_Id;
  85       Op2 : Node_Id);
  86    --  If a boolean array assignment can be done in place, build call to
  87    --  corresponding library procedure.
  88
  89    procedure Displace_Allocator_Pointer (N : Node_Id);
  90    --  Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
  91    --  Expand_Allocator_Expression. Allocating class-wide interface objects
  92    --  this routine displaces the pointer to the allocated object to reference
  93    --  the component referencing the corresponding secondary dispatch table.
  94
  95    procedure Expand_Allocator_Expression (N : Node_Id);
  96    --  Subsidiary to Expand_N_Allocator, for the case when the expression
  97    --  is a qualified expression or an aggregate.
  98
  99    procedure Expand_Array_Comparison (N : Node_Id);
 100    --  This routine handles expansion of the comparison operators (N_Op_Lt,
 101    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
 102    --  code for these operators is similar, differing only in the details of
 103    --  the actual comparison call that is made. Special processing (call a
 104    --  run-time routine)
 105
 106    function Expand_Array_Equality
 107      (Nod    : Node_Id;
 108       Lhs    : Node_Id;
 109       Rhs    : Node_Id;
 110       Bodies : List_Id;
 111       Typ    : Entity_Id) return Node_Id;
 112    --  Expand an array equality into a call to a function implementing this
 113    --  equality, and a call to it. Loc is the location for the generated nodes.
 114    --  Lhs and Rhs are the array expressions to be compared. Bodies is a list
 115    --  on which to attach bodies of local functions that are created in the
 116    --  process. It is the responsibility of the caller to insert those bodies
 117    --  at the right place. Nod provides the Sloc value for the generated code.
 118    --  Normally the types used for the generated equality routine are taken
 119    --  from Lhs and Rhs. However, in some situations of generated code, the
 120    --  Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
 121    --  the type to be used for the formal parameters.
 122
 123    procedure Expand_Boolean_Operator (N : Node_Id);
 124    --  Common expansion processing for Boolean operators (And, Or, Xor) for the
 125    --  case of array type arguments.
 126
 127    function Expand_Composite_Equality
 128      (Nod    : Node_Id;
 129       Typ    : Entity_Id;
 130       Lhs    : Node_Id;
 131       Rhs    : Node_Id;
 132       Bodies : List_Id) return Node_Id;
 133    --  Local recursive function used to expand equality for nested composite
 134    --  types. Used by Expand_Record/Array_Equality, Bodies is a list on which
 135    --  to attach bodies of local functions that are created in the process.
 136    --  This is the responsibility of the caller to insert those bodies at the
 137    --  right place. Nod provides the Sloc value for generated code. Lhs and Rhs
 138    --  are the left and right sides for the comparison, and Typ is the type of
 139    --  the arrays to compare.
 140
 141    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
 142    --  This routine handles expansion of concatenation operations, where N is
 143    --  the N_Op_Concat node being expanded and Operands is the list of operands
 144    --  (at least two are present). The caller has dealt with converting any
 145    --  singleton operands into singleton aggregates.
 146
 147    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
 148    --  Routine to expand concatenation of 2-5 operands (in the list Operands)
 149    --  and replace node Cnode with the result of the concatenation. If there
 150    --  are two operands, they can be string or character. If there are more
 151    --  than two operands, then are always of type string (i.e. the caller has
 152    --  already converted character operands to strings in this case).
 153
 154    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
 155    --  N is a N_Op_Divide or N_Op_Multiply node whose result is universal
 156    --  fixed. We do not have such a type at runtime, so the purpose of this
 157    --  routine is to find the real type by looking up the tree. We also
 158    --  determine if the operation must be rounded.
 159
 160    function Get_Allocator_Final_List
 161      (N    : Node_Id;
 162       T    : Entity_Id;
 163       PtrT : Entity_Id) return Entity_Id;
 164    --  If the designated type is controlled, build final_list expression for
 165    --  created object. If context is an access parameter, create a local access
 166    --  type to have a usable finalization list.
 167
 168    function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
 169    --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
 170    --  discriminants if it has a constrained nominal type, unless the object
 171    --  is a component of an enclosing Unchecked_Union object that is subject
 172    --  to a per-object constraint and the enclosing object lacks inferable
 173    --  discriminants.
 174    --
 175    --  An expression of an Unchecked_Union type has inferable discriminants
 176    --  if it is either a name of an object with inferable discriminants or a
 177    --  qualified expression whose subtype mark denotes a constrained subtype.
 178
 179    procedure Insert_Dereference_Action (N : Node_Id);
 180    --  N is an expression whose type is an access. When the type of the
 181    --  associated storage pool is derived from Checked_Pool, generate a
 182    --  call to the 'Dereference' primitive operation.
 183
 184    function Make_Array_Comparison_Op
 185      (Typ : Entity_Id;
 186       Nod : Node_Id) return Node_Id;
 187    --  Comparisons between arrays are expanded in line. This function produces
 188    --  the body of the implementation of (a > b), where a and b are one-
 189    --  dimensional arrays of some discrete type. The original node is then
 190    --  expanded into the appropriate call to this function. Nod provides the
 191    --  Sloc value for the generated code.
 192
 193    function Make_Boolean_Array_Op
 194      (Typ : Entity_Id;
 195       N   : Node_Id) return Node_Id;
 196    --  Boolean operations on boolean arrays are expanded in line. This function
 197    --  produce the body for the node N, which is (a and b), (a or b), or (a xor
 198    --  b). It is used only the normal case and not the packed case. The type
 199    --  involved, Typ, is the Boolean array type, and the logical operations in
 200    --  the body are simple boolean operations. Note that Typ is always a
 201    --  constrained type (the caller has ensured this by using
 202    --  Convert_To_Actual_Subtype if necessary).
 203
 204    procedure Rewrite_Comparison (N : Node_Id);
 205    --  If N is the node for a comparison whose outcome can be determined at
 206    --  compile time, then the node N can be rewritten with True or False. If
 207    --  the outcome cannot be determined at compile time, the call has no
 208    --  effect. If N is a type conversion, then this processing is applied to
 209    --  its expression. If N is neither comparison nor a type conversion, the
 210    --  call has no effect.
 211
 212    function Tagged_Membership (N : Node_Id) return Node_Id;
 213    --  Construct the expression corresponding to the tagged membership test.
 214    --  Deals with a second operand being (or not) a class-wide type.
 215
 216    function Safe_In_Place_Array_Op
 217      (Lhs : Node_Id;
 218       Op1 : Node_Id;
 219       Op2 : Node_Id) return Boolean;
 220    --  In the context of an assignment, where the right-hand side is a boolean
 221    --  operation on arrays, check whether operation can be performed in place.
 222
 223    procedure Unary_Op_Validity_Checks (N : Node_Id);
 224    pragma Inline (Unary_Op_Validity_Checks);
 225    --  Performs validity checks for a unary operator
 226
 227    -------------------------------
 228    -- Binary_Op_Validity_Checks --
 229    -------------------------------
 230
 231    procedure Binary_Op_Validity_Checks (N : Node_Id) is
 232    begin
 233       if Validity_Checks_On and Validity_Check_Operands then
 234          Ensure_Valid (Left_Opnd (N));
 235          Ensure_Valid (Right_Opnd (N));
 236       end if;
 237    end Binary_Op_Validity_Checks;
 238
 239    ------------------------------------
 240    -- Build_Boolean_Array_Proc_Call --
 241    ------------------------------------
 242
 243    procedure Build_Boolean_Array_Proc_Call
 244      (N   : Node_Id;
 245       Op1 : Node_Id;
 246       Op2 : Node_Id)
 247    is
 248       Loc       : constant Source_Ptr := Sloc (N);
 249       Kind      : constant Node_Kind := Nkind (Expression (N));
 250       Target    : constant Node_Id   :=
 251                     Make_Attribute_Reference (Loc,
 252                       Prefix         => Name (N),
 253                       Attribute_Name => Name_Address);
 254
 255       Arg1      : constant Node_Id := Op1;
 256       Arg2      : Node_Id := Op2;
 257       Call_Node : Node_Id;
 258       Proc_Name : Entity_Id;
 259
 260    begin
 261       if Kind = N_Op_Not then
 262          if Nkind (Op1) in N_Binary_Op then
 263
 264             --  Use negated version of the binary operators
 265
 266             if Nkind (Op1) = N_Op_And then
 267                Proc_Name := RTE (RE_Vector_Nand);
 268
 269             elsif Nkind (Op1) = N_Op_Or then
 270                Proc_Name := RTE (RE_Vector_Nor);
 271
 272             else pragma Assert (Nkind (Op1) = N_Op_Xor);
 273                Proc_Name := RTE (RE_Vector_Xor);
 274             end if;
 275
 276             Call_Node :=
 277               Make_Procedure_Call_Statement (Loc,
 278                 Name => New_Occurrence_Of (Proc_Name, Loc),
 279
 280                 Parameter_Associations => New_List (
 281                   Target,
 282                   Make_Attribute_Reference (Loc,
 283                     Prefix => Left_Opnd (Op1),
 284                     Attribute_Name => Name_Address),
 285
 286                   Make_Attribute_Reference (Loc,
 287                     Prefix => Right_Opnd (Op1),
 288                     Attribute_Name => Name_Address),
 289
 290                   Make_Attribute_Reference (Loc,
 291                     Prefix => Left_Opnd (Op1),
 292                     Attribute_Name => Name_Length)));
 293
 294          else
 295             Proc_Name := RTE (RE_Vector_Not);
 296
 297             Call_Node :=
 298               Make_Procedure_Call_Statement (Loc,
 299                 Name => New_Occurrence_Of (Proc_Name, Loc),
 300                 Parameter_Associations => New_List (
 301                   Target,
 302
 303                   Make_Attribute_Reference (Loc,
 304                     Prefix => Op1,
 305                     Attribute_Name => Name_Address),
 306
 307                   Make_Attribute_Reference (Loc,
 308                     Prefix => Op1,
 309                      Attribute_Name => Name_Length)));
 310          end if;
 311
 312       else
 313          --  We use the following equivalences:
 314
 315          --   (not X) or  (not Y)  =  not (X and Y)  =  Nand (X, Y)
 316          --   (not X) and (not Y)  =  not (X or Y)   =  Nor  (X, Y)
 317          --   (not X) xor (not Y)  =  X xor Y
 318          --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)
 319
 320          if Nkind (Op1) = N_Op_Not then
 321             if Kind = N_Op_And then
 322                Proc_Name := RTE (RE_Vector_Nor);
 323
 324             elsif Kind = N_Op_Or then
 325                Proc_Name := RTE (RE_Vector_Nand);
 326
 327             else
 328                Proc_Name := RTE (RE_Vector_Xor);
 329             end if;
 330
 331          else
 332             if Kind = N_Op_And then
 333                Proc_Name := RTE (RE_Vector_And);
 334
 335             elsif Kind = N_Op_Or then
 336                Proc_Name := RTE (RE_Vector_Or);
 337
 338             elsif Nkind (Op2) = N_Op_Not then
 339                Proc_Name := RTE (RE_Vector_Nxor);
 340                Arg2 := Right_Opnd (Op2);
 341
 342             else
 343                Proc_Name := RTE (RE_Vector_Xor);
 344             end if;
 345          end if;
 346
 347          Call_Node :=
 348            Make_Procedure_Call_Statement (Loc,
 349              Name => New_Occurrence_Of (Proc_Name, Loc),
 350              Parameter_Associations => New_List (
 351                Target,
 352                   Make_Attribute_Reference (Loc,
 353                     Prefix => Arg1,
 354                     Attribute_Name => Name_Address),
 355                   Make_Attribute_Reference (Loc,
 356                     Prefix => Arg2,
 357                     Attribute_Name => Name_Address),
 358                  Make_Attribute_Reference (Loc,
 359                    Prefix => Op1,
 360                     Attribute_Name => Name_Length)));
 361       end if;
 362
 363       Rewrite (N, Call_Node);
 364       Analyze (N);
 365
 366    exception
 367       when RE_Not_Available =>
 368          return;
 369    end Build_Boolean_Array_Proc_Call;
 370
 371    --------------------------------
 372    -- Displace_Allocator_Pointer --
 373    --------------------------------
 374
 375    procedure Displace_Allocator_Pointer (N : Node_Id) is
 376       Loc       : constant Source_Ptr := Sloc (N);
 377       Orig_Node : constant Node_Id := Original_Node (N);
 378       Dtyp      : Entity_Id;
 379       Etyp      : Entity_Id;
 380       PtrT      : Entity_Id;
 381
 382    begin
 383       --  Do nothing in case of VM targets: the virtual machine will handle
 384       --  interfaces directly.
 385
 386       if VM_Target /= No_VM then
 387          return;
 388       end if;
 389
 390       pragma Assert (Nkind (N) = N_Identifier
 391         and then Nkind (Orig_Node) = N_Allocator);
 392
 393       PtrT := Etype (Orig_Node);
 394       Dtyp := Designated_Type (PtrT);
 395       Etyp := Etype (Expression (Orig_Node));
 396
 397       if Is_Class_Wide_Type (Dtyp)
 398         and then Is_Interface (Dtyp)
 399       then
 400          --  If the type of the allocator expression is not an interface type
 401          --  we can generate code to reference the record component containing
 402          --  the pointer to the secondary dispatch table.
 403
 404          if not Is_Interface (Etyp) then
 405             declare
 406                Saved_Typ : constant Entity_Id := Etype (Orig_Node);
 407
 408             begin
 409                --  1) Get access to the allocated object
 410
 411                Rewrite (N,
 412                  Make_Explicit_Dereference (Loc,
 413                    Relocate_Node (N)));
 414                Set_Etype (N, Etyp);
 415                Set_Analyzed (N);
 416
 417                --  2) Add the conversion to displace the pointer to reference
 418                --     the secondary dispatch table.
 419
 420                Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
 421                Analyze_And_Resolve (N, Dtyp);
 422
 423                --  3) The 'access to the secondary dispatch table will be used
 424                --     as the value returned by the allocator.
 425
 426                Rewrite (N,
 427                  Make_Attribute_Reference (Loc,
 428                    Prefix         => Relocate_Node (N),
 429                    Attribute_Name => Name_Access));
 430                Set_Etype (N, Saved_Typ);
 431                Set_Analyzed (N);
 432             end;
 433
 434          --  If the type of the allocator expression is an interface type we
 435          --  generate a run-time call to displace "this" to reference the
 436          --  component containing the pointer to the secondary dispatch table
 437          --  or else raise Constraint_Error if the actual object does not
 438          --  implement the target interface. This case corresponds with the
 439          --  following example:
 440
 441          --   function Op (Obj : Iface_1'Class) return access Iface_2'Class is
 442          --   begin
 443          --      return new Iface_2'Class'(Obj);
 444          --   end Op;
 445
 446          else
 447             Rewrite (N,
 448               Unchecked_Convert_To (PtrT,
 449                 Make_Function_Call (Loc,
 450                   Name => New_Reference_To (RTE (RE_Displace), Loc),
 451                   Parameter_Associations => New_List (
 452                     Unchecked_Convert_To (RTE (RE_Address),
 453                       Relocate_Node (N)),
 454
 455                     New_Occurrence_Of
 456                       (Elists.Node
 457                         (First_Elmt
 458                           (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
 459                        Loc)))));
 460             Analyze_And_Resolve (N, PtrT);
 461          end if;
 462       end if;
 463    end Displace_Allocator_Pointer;
 464
 465    ---------------------------------
 466    -- Expand_Allocator_Expression --
 467    ---------------------------------
 468
 469    procedure Expand_Allocator_Expression (N : Node_Id) is
 470       Loc    : constant Source_Ptr := Sloc (N);
 471       Exp    : constant Node_Id    := Expression (Expression (N));
 472       PtrT   : constant Entity_Id  := Etype (N);
 473       DesigT : constant Entity_Id  := Designated_Type (PtrT);
 474
 475       procedure Apply_Accessibility_Check
 476         (Ref            : Node_Id;
 477          Built_In_Place : Boolean := False);
 478       --  Ada 2005 (AI-344): For an allocator with a class-wide designated
 479       --  type, generate an accessibility check to verify that the level of the
 480       --  type of the created object is not deeper than the level of the access
 481       --  type. If the type of the qualified expression is class- wide, then
 482       --  always generate the check (except in the case where it is known to be
 483       --  unnecessary, see comment below). Otherwise, only generate the check
 484       --  if the level of the qualified expression type is statically deeper
 485       --  than the access type.
 486       --
 487       --  Although the static accessibility will generally have been performed
 488       --  as a legality check, it won't have been done in cases where the
 489       --  allocator appears in generic body, so a run-time check is needed in
 490       --  general. One special case is when the access type is declared in the
 491       --  same scope as the class-wide allocator, in which case the check can
 492       --  never fail, so it need not be generated.
 493       --
 494       --  As an open issue, there seem to be cases where the static level
 495       --  associated with the class-wide object's underlying type is not
 496       --  sufficient to perform the proper accessibility check, such as for
 497       --  allocators in nested subprograms or accept statements initialized by
 498       --  class-wide formals when the actual originates outside at a deeper
 499       --  static level. The nested subprogram case might require passing
 500       --  accessibility levels along with class-wide parameters, and the task
 501       --  case seems to be an actual gap in the language rules that needs to
 502       --  be fixed by the ARG. ???
 503
 504       -------------------------------
 505       -- Apply_Accessibility_Check --
 506       -------------------------------
 507
 508       procedure Apply_Accessibility_Check
 509         (Ref            : Node_Id;
 510          Built_In_Place : Boolean := False)
 511       is
 512          Ref_Node : Node_Id;
 513
 514       begin
 515          --  Note: we skip the accessibility check for the VM case, since
 516          --  there does not seem to be any practical way of implementing it.
 517
 518          if Ada_Version >= Ada_05
 519            and then VM_Target = No_VM
 520            and then Is_Class_Wide_Type (DesigT)
 521            and then not Scope_Suppress (Accessibility_Check)
 522            and then
 523              (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
 524                or else
 525                  (Is_Class_Wide_Type (Etype (Exp))
 526                    and then Scope (PtrT) /= Current_Scope))
 527          then
 528             --  If the allocator was built in place Ref is already a reference
 529             --  to the access object initialized to the result of the allocator
 530             --  (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
 531             --  it is the entity associated with the object containing the
 532             --  address of the allocated object.
 533
 534             if Built_In_Place then
 535                Ref_Node := New_Copy (Ref);
 536             else
 537                Ref_Node := New_Reference_To (Ref, Loc);
 538             end if;
 539
 540             Insert_Action (N,
 541                Make_Raise_Program_Error (Loc,
 542                  Condition =>
 543                    Make_Op_Gt (Loc,
 544                      Left_Opnd  =>
 545                        Build_Get_Access_Level (Loc,
 546                          Make_Attribute_Reference (Loc,
 547                            Prefix => Ref_Node,
 548                            Attribute_Name => Name_Tag)),
 549                      Right_Opnd =>
 550                        Make_Integer_Literal (Loc,
 551                          Type_Access_Level (PtrT))),
 552                  Reason => PE_Accessibility_Check_Failed));
 553          end if;
 554       end Apply_Accessibility_Check;
 555
 556       --  Local variables
 557
 558       Indic : constant Node_Id   := Subtype_Mark (Expression (N));
 559       T     : constant Entity_Id := Entity (Indic);
 560       Flist : Node_Id;
 561       Node  : Node_Id;
 562       Temp  : Entity_Id;
 563
 564       TagT : Entity_Id := Empty;
 565       --  Type used as source for tag assignment
 566
 567       TagR : Node_Id := Empty;
 568       --  Target reference for tag assignment
 569
 570       Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
 571
 572       Tag_Assign : Node_Id;
 573       Tmp_Node   : Node_Id;
 574
 575    --  Start of processing for Expand_Allocator_Expression
 576
 577    begin
 578       if Is_Tagged_Type (T) or else Controlled_Type (T) then
 579
 580          --  Ada 2005 (AI-318-02): If the initialization expression is a call
 581          --  to a build-in-place function, then access to the allocated object
 582          --  must be passed to the function. Currently we limit such functions
 583          --  to those with constrained limited result subtypes, but eventually
 584          --  we plan to expand the allowed forms of functions that are treated
 585          --  as build-in-place.
 586
 587          if Ada_Version >= Ada_05
 588            and then Is_Build_In_Place_Function_Call (Exp)
 589          then
 590             Make_Build_In_Place_Call_In_Allocator (N, Exp);
 591             Apply_Accessibility_Check (N, Built_In_Place => True);
 592             return;
 593          end if;
 594
 595          --    Actions inserted before:
 596          --              Temp : constant ptr_T := new T'(Expression);
 597          --   <no CW>    Temp._tag := T'tag;
 598          --   <CTRL>     Adjust (Finalizable (Temp.all));
 599          --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
 600
 601          --  We analyze by hand the new internal allocator to avoid
 602          --  any recursion and inappropriate call to Initialize
 603
 604          --  We don't want to remove side effects when the expression must be
 605          --  built in place. In the case of a build-in-place function call,
 606          --  that could lead to a duplication of the call, which was already
 607          --  substituted for the allocator.
 608
 609          if not Aggr_In_Place then
 610             Remove_Side_Effects (Exp);
 611          end if;
 612
 613          Temp :=
 614            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 615
 616          --  For a class wide allocation generate the following code:
 617
 618          --    type Equiv_Record is record ... end record;
 619          --    implicit subtype CW is <Class_Wide_Subytpe>;
 620          --    temp : PtrT := new CW'(CW!(expr));
 621
 622          if Is_Class_Wide_Type (T) then
 623             Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
 624
 625             --  Ada 2005 (AI-251): If the expression is a class-wide interface
 626             --  object we generate code to move up "this" to reference the
 627             --  base of the object before allocating the new object.
 628
 629             --  Note that Exp'Address is recursively expanded into a call
 630             --  to Base_Address (Exp.Tag)
 631
 632             if Is_Class_Wide_Type (Etype (Exp))
 633               and then Is_Interface (Etype (Exp))
 634               and then VM_Target = No_VM
 635             then
 636                Set_Expression
 637                  (Expression (N),
 638                   Unchecked_Convert_To (Entity (Indic),
 639                     Make_Explicit_Dereference (Loc,
 640                       Unchecked_Convert_To (RTE (RE_Tag_Ptr),
 641                         Make_Attribute_Reference (Loc,
 642                           Prefix         => Exp,
 643                           Attribute_Name => Name_Address)))));
 644
 645             else
 646                Set_Expression
 647                  (Expression (N),
 648                   Unchecked_Convert_To (Entity (Indic), Exp));
 649             end if;
 650
 651             Analyze_And_Resolve (Expression (N), Entity (Indic));
 652          end if;
 653
 654          --  Keep separate the management of allocators returning interfaces
 655
 656          if not Is_Interface (Directly_Designated_Type (PtrT)) then
 657             if Aggr_In_Place then
 658                Tmp_Node :=
 659                  Make_Object_Declaration (Loc,
 660                    Defining_Identifier => Temp,
 661                    Object_Definition   => New_Reference_To (PtrT, Loc),
 662                    Expression          =>
 663                      Make_Allocator (Loc,
 664                        New_Reference_To (Etype (Exp), Loc)));
 665
 666                Set_Comes_From_Source
 667                  (Expression (Tmp_Node), Comes_From_Source (N));
 668
 669                Set_No_Initialization (Expression (Tmp_Node));
 670                Insert_Action (N, Tmp_Node);
 671
 672                if Controlled_Type (T)
 673                  and then Ekind (PtrT) = E_Anonymous_Access_Type
 674                then
 675                   --  Create local finalization list for access parameter
 676
 677                   Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 678                end if;
 679
 680                Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
 681             else
 682                Node := Relocate_Node (N);
 683                Set_Analyzed (Node);
 684                Insert_Action (N,
 685                  Make_Object_Declaration (Loc,
 686                    Defining_Identifier => Temp,
 687                    Constant_Present    => True,
 688                    Object_Definition   => New_Reference_To (PtrT, Loc),
 689                    Expression          => Node));
 690             end if;
 691
 692          --  Ada 2005 (AI-251): Handle allocators whose designated type is an
 693          --  interface type. In this case we use the type of the qualified
 694          --  expression to allocate the object.
 695
 696          else
 697             declare
 698                Def_Id   : constant Entity_Id :=
 699                             Make_Defining_Identifier (Loc,
 700                               New_Internal_Name ('T'));
 701                New_Decl : Node_Id;
 702
 703             begin
 704                New_Decl :=
 705                  Make_Full_Type_Declaration (Loc,
 706                    Defining_Identifier => Def_Id,
 707                    Type_Definition =>
 708                      Make_Access_To_Object_Definition (Loc,
 709                        All_Present            => True,
 710                        Null_Exclusion_Present => False,
 711                        Constant_Present       => False,
 712                        Subtype_Indication     =>
 713                          New_Reference_To (Etype (Exp), Loc)));
 714
 715                Insert_Action (N, New_Decl);
 716
 717                --  Inherit the final chain to ensure that the expansion of the
 718                --  aggregate is correct in case of controlled types
 719
 720                if Controlled_Type (Directly_Designated_Type (PtrT)) then
 721                   Set_Associated_Final_Chain (Def_Id,
 722                     Associated_Final_Chain (PtrT));
 723                end if;
 724
 725                --  Declare the object using the previous type declaration
 726
 727                if Aggr_In_Place then
 728                   Tmp_Node :=
 729                     Make_Object_Declaration (Loc,
 730                       Defining_Identifier => Temp,
 731                       Object_Definition   => New_Reference_To (Def_Id, Loc),
 732                       Expression          =>
 733                         Make_Allocator (Loc,
 734                           New_Reference_To (Etype (Exp), Loc)));
 735
 736                   Set_Comes_From_Source
 737                     (Expression (Tmp_Node), Comes_From_Source (N));
 738
 739                   Set_No_Initialization (Expression (Tmp_Node));
 740                   Insert_Action (N, Tmp_Node);
 741
 742                   if Controlled_Type (T)
 743                     and then Ekind (PtrT) = E_Anonymous_Access_Type
 744                   then
 745                      --  Create local finalization list for access parameter
 746
 747                      Flist :=
 748                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 749                   end if;
 750
 751                   Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
 752                else
 753                   Node := Relocate_Node (N);
 754                   Set_Analyzed (Node);
 755                   Insert_Action (N,
 756                     Make_Object_Declaration (Loc,
 757                       Defining_Identifier => Temp,
 758                       Constant_Present    => True,
 759                       Object_Definition   => New_Reference_To (Def_Id, Loc),
 760                       Expression          => Node));
 761                end if;
 762
 763                --  Generate an additional object containing the address of the
 764                --  returned object. The type of this second object declaration
 765                --  is the correct type required for the common processing that
 766                --  is still performed by this subprogram. The displacement of
 767                --  this pointer to reference the component associated with the
 768                --  interface type will be done at the end of common processing.
 769
 770                New_Decl :=
 771                  Make_Object_Declaration (Loc,
 772                    Defining_Identifier => Make_Defining_Identifier (Loc,
 773                                              New_Internal_Name ('P')),
 774                    Object_Definition   => New_Reference_To (PtrT, Loc),
 775                    Expression          => Unchecked_Convert_To (PtrT,
 776                                             New_Reference_To (Temp, Loc)));
 777
 778                Insert_Action (N, New_Decl);
 779
 780                Tmp_Node := New_Decl;
 781                Temp     := Defining_Identifier (New_Decl);
 782             end;
 783          end if;
 784
 785          Apply_Accessibility_Check (Temp);
 786
 787          --  Generate the tag assignment
 788
 789          --  Suppress the tag assignment when VM_Target because VM tags are
 790          --  represented implicitly in objects.
 791
 792          if VM_Target /= No_VM then
 793             null;
 794
 795          --  Ada 2005 (AI-251): Suppress the tag assignment with class-wide
 796          --  interface objects because in this case the tag does not change.
 797
 798          elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
 799             pragma Assert (Is_Class_Wide_Type
 800                             (Directly_Designated_Type (Etype (N))));
 801             null;
 802
 803          elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
 804             TagT := T;
 805             TagR := New_Reference_To (Temp, Loc);
 806
 807          elsif Is_Private_Type (T)
 808            and then Is_Tagged_Type (Underlying_Type (T))
 809          then
 810             TagT := Underlying_Type (T);
 811             TagR :=
 812               Unchecked_Convert_To (Underlying_Type (T),
 813                 Make_Explicit_Dereference (Loc,
 814                   Prefix => New_Reference_To (Temp, Loc)));
 815          end if;
 816
 817          if Present (TagT) then
 818             Tag_Assign :=
 819               Make_Assignment_Statement (Loc,
 820                 Name =>
 821                   Make_Selected_Component (Loc,
 822                     Prefix => TagR,
 823                     Selector_Name =>
 824                       New_Reference_To (First_Tag_Component (TagT), Loc)),
 825
 826                 Expression =>
 827                   Unchecked_Convert_To (RTE (RE_Tag),
 828                     New_Reference_To
 829                       (Elists.Node (First_Elmt (Access_Disp_Table (TagT))),
 830                        Loc)));
 831
 832             --  The previous assignment has to be done in any case
 833
 834             Set_Assignment_OK (Name (Tag_Assign));
 835             Insert_Action (N, Tag_Assign);
 836          end if;
 837
 838          if Controlled_Type (DesigT)
 839             and then Controlled_Type (T)
 840          then
 841             declare
 842                Attach : Node_Id;
 843                Apool  : constant Entity_Id :=
 844                           Associated_Storage_Pool (PtrT);
 845
 846             begin
 847                --  If it is an allocation on the secondary stack (i.e. a value
 848                --  returned from a function), the object is attached on the
 849                --  caller side as soon as the call is completed (see
 850                --  Expand_Ctrl_Function_Call)
 851
 852                if Is_RTE (Apool, RE_SS_Pool) then
 853                   declare
 854                      F : constant Entity_Id :=
 855                            Make_Defining_Identifier (Loc,
 856                              New_Internal_Name ('F'));
 857                   begin
 858                      Insert_Action (N,
 859                        Make_Object_Declaration (Loc,
 860                          Defining_Identifier => F,
 861                          Object_Definition   => New_Reference_To (RTE
 862                           (RE_Finalizable_Ptr), Loc)));
 863
 864                      Flist := New_Reference_To (F, Loc);
 865                      Attach :=  Make_Integer_Literal (Loc, 1);
 866                   end;
 867
 868                --  Normal case, not a secondary stack allocation
 869
 870                else
 871                   if Controlled_Type (T)
 872                     and then Ekind (PtrT) = E_Anonymous_Access_Type
 873                   then
 874                      --  Create local finalization list for access parameter
 875
 876                      Flist :=
 877                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 878                   else
 879                      Flist := Find_Final_List (PtrT);
 880                   end if;
 881
 882                   Attach :=  Make_Integer_Literal (Loc, 2);
 883                end if;
 884
 885                --  Generate an Adjust call if the object will be moved. In Ada
 886                --  2005, the object may be inherently limited, in which case
 887                --  there is no Adjust procedure, and the object is built in
 888                --  place. In Ada 95, the object can be limited but not
 889                --  inherently limited if this allocator came from a return
 890                --  statement (we're allocating the result on the secondary
 891                --  stack). In that case, the object will be moved, so we _do_
 892                --  want to Adjust.
 893
 894                if not Aggr_In_Place
 895                  and then not Is_Inherently_Limited_Type (T)
 896                then
 897                   Insert_Actions (N,
 898                     Make_Adjust_Call (
 899                       Ref          =>
 900
 901                      --  An unchecked conversion is needed in the classwide
 902                      --  case because the designated type can be an ancestor of
 903                      --  the subtype mark of the allocator.
 904
 905                       Unchecked_Convert_To (T,
 906                         Make_Explicit_Dereference (Loc,
 907                           Prefix => New_Reference_To (Temp, Loc))),
 908
 909                       Typ          => T,
 910                       Flist_Ref    => Flist,
 911                       With_Attach  => Attach,
 912                       Allocator    => True));
 913                end if;
 914             end;
 915          end if;
 916
 917          Rewrite (N, New_Reference_To (Temp, Loc));
 918          Analyze_And_Resolve (N, PtrT);
 919
 920          --  Ada 2005 (AI-251): Displace the pointer to reference the record
 921          --  component containing the secondary dispatch table of the interface
 922          --  type.
 923
 924          if Is_Interface (Directly_Designated_Type (PtrT)) then
 925             Displace_Allocator_Pointer (N);
 926          end if;
 927
 928       elsif Aggr_In_Place then
 929          Temp :=
 930            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 931          Tmp_Node :=
 932            Make_Object_Declaration (Loc,
 933              Defining_Identifier => Temp,
 934              Object_Definition   => New_Reference_To (PtrT, Loc),
 935              Expression          => Make_Allocator (Loc,
 936                  New_Reference_To (Etype (Exp), Loc)));
 937
 938          Set_Comes_From_Source
 939            (Expression (Tmp_Node), Comes_From_Source (N));
 940
 941          Set_No_Initialization (Expression (Tmp_Node));
 942          Insert_Action (N, Tmp_Node);
 943          Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
 944          Rewrite (N, New_Reference_To (Temp, Loc));
 945          Analyze_And_Resolve (N, PtrT);
 946
 947       elsif Is_Access_Type (DesigT)
 948         and then Nkind (Exp) = N_Allocator
 949         and then Nkind (Expression (Exp)) /= N_Qualified_Expression
 950       then
 951          --  Apply constraint to designated subtype indication
 952
 953          Apply_Constraint_Check (Expression (Exp),
 954            Designated_Type (DesigT),
 955            No_Sliding => True);
 956
 957          if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
 958
 959             --  Propagate constraint_error to enclosing allocator
 960
 961             Rewrite (Exp, New_Copy (Expression (Exp)));
 962          end if;
 963       else
 964          --  First check against the type of the qualified expression
 965          --
 966          --  NOTE: The commented call should be correct, but for some reason
 967          --  causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for
 968          --  now we just perform the old (incorrect) test against the
 969          --  designated subtype with no sliding in the else part of the if
 970          --  statement below. ???
 971          --
 972          --  Apply_Constraint_Check (Exp, T, No_Sliding => True);
 973
 974          --  A check is also needed in cases where the designated subtype is
 975          --  constrained and differs from the subtype given in the qualified
 976          --  expression. Note that the check on the qualified expression does
 977          --  not allow sliding, but this check does (a relaxation from Ada 83).
 978
 979          if Is_Constrained (DesigT)
 980            and then not Subtypes_Statically_Match
 981                           (T, DesigT)
 982          then
 983             Apply_Constraint_Check
 984               (Exp, DesigT, No_Sliding => False);
 985
 986          --  The nonsliding check should really be performed (unconditionally)
 987          --  against the subtype of the qualified expression, but that causes a
 988          --  problem with c34007g (see above), so for now we retain this.
 989
 990          else
 991             Apply_Constraint_Check
 992               (Exp, DesigT, No_Sliding => True);
 993          end if;
 994
 995          --  For an access to unconstrained packed array, GIGI needs to see an
 996          --  expression with a constrained subtype in order to compute the
 997          --  proper size for the allocator.
 998
 999          if Is_Array_Type (T)
1000            and then not Is_Constrained (T)
1001            and then Is_Packed (T)
1002          then
1003             declare
1004                ConstrT      : constant Entity_Id :=
1005                                 Make_Defining_Identifier (Loc,
1006                                   Chars => New_Internal_Name ('A'));
1007                Internal_Exp : constant Node_Id   := Relocate_Node (Exp);
1008             begin
1009                Insert_Action (Exp,
1010                  Make_Subtype_Declaration (Loc,
1011                    Defining_Identifier => ConstrT,
1012                    Subtype_Indication  =>
1013                      Make_Subtype_From_Expr (Exp, T)));
1014                Freeze_Itype (ConstrT, Exp);
1015                Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1016             end;
1017          end if;
1018
1019          --  Ada 2005 (AI-318-02): If the initialization expression is a call
1020          --  to a build-in-place function, then access to the allocated object
1021          --  must be passed to the function. Currently we limit such functions
1022          --  to those with constrained limited result subtypes, but eventually
1023          --  we plan to expand the allowed forms of functions that are treated
1024          --  as build-in-place.
1025
1026          if Ada_Version >= Ada_05
1027            and then Is_Build_In_Place_Function_Call (Exp)
1028          then
1029             Make_Build_In_Place_Call_In_Allocator (N, Exp);
1030          end if;
1031       end if;
1032
1033    exception
1034       when RE_Not_Available =>
1035          return;
1036    end Expand_Allocator_Expression;
1037
1038    -----------------------------
1039    -- Expand_Array_Comparison --
1040    -----------------------------
1041
1042    --  Expansion is only required in the case of array types. For the unpacked
1043    --  case, an appropriate runtime routine is called. For packed cases, and
1044    --  also in some other cases where a runtime routine cannot be called, the
1045    --  form of the expansion is:
1046
1047    --     [body for greater_nn; boolean_expression]
1048
1049    --  The body is built by Make_Array_Comparison_Op, and the form of the
1050    --  Boolean expression depends on the operator involved.
1051
1052    procedure Expand_Array_Comparison (N : Node_Id) is
1053       Loc  : constant Source_Ptr := Sloc (N);
1054       Op1  : Node_Id             := Left_Opnd (N);
1055       Op2  : Node_Id             := Right_Opnd (N);
1056       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
1057       Ctyp : constant Entity_Id  := Component_Type (Typ1);
1058
1059       Expr      : Node_Id;
1060       Func_Body : Node_Id;
1061       Func_Name : Entity_Id;
1062
1063       Comp : RE_Id;
1064
1065       Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1066       --  True for byte addressable target
1067
1068       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1069       --  Returns True if the length of the given operand is known to be less
1070       --  than 4. Returns False if this length is known to be four or greater
1071       --  or is not known at compile time.
1072
1073       ------------------------
1074       -- Length_Less_Than_4 --
1075       ------------------------
1076
1077       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1078          Otyp : constant Entity_Id := Etype (Opnd);
1079
1080       begin
1081          if Ekind (Otyp) = E_String_Literal_Subtype then
1082             return String_Literal_Length (Otyp) < 4;
1083
1084          else
1085             declare
1086                Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1087                Lo   : constant Node_Id   := Type_Low_Bound (Ityp);
1088                Hi   : constant Node_Id   := Type_High_Bound (Ityp);
1089                Lov  : Uint;
1090                Hiv  : Uint;
1091
1092             begin
1093                if Compile_Time_Known_Value (Lo) then
1094                   Lov := Expr_Value (Lo);
1095                else
1096                   return False;
1097                end if;
1098
1099                if Compile_Time_Known_Value (Hi) then
1100                   Hiv := Expr_Value (Hi);
1101                else
1102                   return False;
1103                end if;
1104
1105                return Hiv < Lov + 3;
1106             end;
1107          end if;
1108       end Length_Less_Than_4;
1109
1110    --  Start of processing for Expand_Array_Comparison
1111
1112    begin
1113       --  Deal first with unpacked case, where we can call a runtime routine
1114       --  except that we avoid this for targets for which are not addressable
1115       --  by bytes, and for the JVM/CIL, since they do not support direct
1116       --  addressing of array components.
1117
1118       if not Is_Bit_Packed_Array (Typ1)
1119         and then Byte_Addressable
1120         and then VM_Target = No_VM
1121       then
1122          --  The call we generate is:
1123
1124          --  Compare_Array_xn[_Unaligned]
1125          --    (left'address, right'address, left'length, right'length) <op> 0
1126
1127          --  x = U for unsigned, S for signed
1128          --  n = 8,16,32,64 for component size
1129          --  Add _Unaligned if length < 4 and component size is 8.
1130          --  <op> is the standard comparison operator
1131
1132          if Component_Size (Typ1) = 8 then
1133             if Length_Less_Than_4 (Op1)
1134                  or else
1135                Length_Less_Than_4 (Op2)
1136             then
1137                if Is_Unsigned_Type (Ctyp) then
1138                   Comp := RE_Compare_Array_U8_Unaligned;
1139                else
1140                   Comp := RE_Compare_Array_S8_Unaligned;
1141                end if;
1142
1143             else
1144                if Is_Unsigned_Type (Ctyp) then
1145                   Comp := RE_Compare_Array_U8;
1146                else
1147                   Comp := RE_Compare_Array_S8;
1148                end if;
1149             end if;
1150
1151          elsif Component_Size (Typ1) = 16 then
1152             if Is_Unsigned_Type (Ctyp) then
1153                Comp := RE_Compare_Array_U16;
1154             else
1155                Comp := RE_Compare_Array_S16;
1156             end if;
1157
1158          elsif Component_Size (Typ1) = 32 then
1159             if Is_Unsigned_Type (Ctyp) then
1160                Comp := RE_Compare_Array_U32;
1161             else
1162                Comp := RE_Compare_Array_S32;
1163             end if;
1164
1165          else pragma Assert (Component_Size (Typ1) = 64);
1166             if Is_Unsigned_Type (Ctyp) then
1167                Comp := RE_Compare_Array_U64;
1168             else
1169                Comp := RE_Compare_Array_S64;
1170             end if;
1171          end if;
1172
1173          Remove_Side_Effects (Op1, Name_Req => True);
1174          Remove_Side_Effects (Op2, Name_Req => True);
1175
1176          Rewrite (Op1,
1177            Make_Function_Call (Sloc (Op1),
1178              Name => New_Occurrence_Of (RTE (Comp), Loc),
1179
1180              Parameter_Associations => New_List (
1181                Make_Attribute_Reference (Loc,
1182                  Prefix         => Relocate_Node (Op1),
1183                  Attribute_Name => Name_Address),
1184
1185                Make_Attribute_Reference (Loc,
1186                  Prefix         => Relocate_Node (Op2),
1187                  Attribute_Name => Name_Address),
1188
1189                Make_Attribute_Reference (Loc,
1190                  Prefix         => Relocate_Node (Op1),
1191                  Attribute_Name => Name_Length),
1192
1193                Make_Attribute_Reference (Loc,
1194                  Prefix         => Relocate_Node (Op2),
1195                  Attribute_Name => Name_Length))));
1196
1197          Rewrite (Op2,
1198            Make_Integer_Literal (Sloc (Op2),
1199              Intval => Uint_0));
1200
1201          Analyze_And_Resolve (Op1, Standard_Integer);
1202          Analyze_And_Resolve (Op2, Standard_Integer);
1203          return;
1204       end if;
1205
1206       --  Cases where we cannot make runtime call
1207
1208       --  For (a <= b) we convert to not (a > b)
1209
1210       if Chars (N) = Name_Op_Le then
1211          Rewrite (N,
1212            Make_Op_Not (Loc,
1213              Right_Opnd =>
1214                 Make_Op_Gt (Loc,
1215                  Left_Opnd  => Op1,
1216                  Right_Opnd => Op2)));
1217          Analyze_And_Resolve (N, Standard_Boolean);
1218          return;
1219
1220       --  For < the Boolean expression is
1221       --    greater__nn (op2, op1)
1222
1223       elsif Chars (N) = Name_Op_Lt then
1224          Func_Body := Make_Array_Comparison_Op (Typ1, N);
1225
1226          --  Switch operands
1227
1228          Op1 := Right_Opnd (N);
1229          Op2 := Left_Opnd  (N);
1230
1231       --  For (a >= b) we convert to not (a < b)
1232
1233       elsif Chars (N) = Name_Op_Ge then
1234          Rewrite (N,
1235            Make_Op_Not (Loc,
1236              Right_Opnd =>
1237                Make_Op_Lt (Loc,
1238                  Left_Opnd  => Op1,
1239                  Right_Opnd => Op2)));
1240          Analyze_And_Resolve (N, Standard_Boolean);
1241          return;
1242
1243       --  For > the Boolean expression is
1244       --    greater__nn (op1, op2)
1245
1246       else
1247          pragma Assert (Chars (N) = Name_Op_Gt);
1248          Func_Body := Make_Array_Comparison_Op (Typ1, N);
1249       end if;
1250
1251       Func_Name := Defining_Unit_Name (Specification (Func_Body));
1252       Expr :=
1253         Make_Function_Call (Loc,
1254           Name => New_Reference_To (Func_Name, Loc),
1255           Parameter_Associations => New_List (Op1, Op2));
1256
1257       Insert_Action (N, Func_Body);
1258       Rewrite (N, Expr);
1259       Analyze_And_Resolve (N, Standard_Boolean);
1260
1261    exception
1262       when RE_Not_Available =>
1263          return;
1264    end Expand_Array_Comparison;
1265
1266    ---------------------------
1267    -- Expand_Array_Equality --
1268    ---------------------------
1269
1270    --  Expand an equality function for multi-dimensional arrays. Here is an
1271    --  example of such a function for Nb_Dimension = 2
1272
1273    --  function Enn (A : atyp; B : btyp) return boolean is
1274    --  begin
1275    --     if (A'length (1) = 0 or else A'length (2) = 0)
1276    --          and then
1277    --        (B'length (1) = 0 or else B'length (2) = 0)
1278    --     then
1279    --        return True;    -- RM 4.5.2(22)
1280    --     end if;
1281
1282    --     if A'length (1) /= B'length (1)
1283    --               or else
1284    --           A'length (2) /= B'length (2)
1285    --     then
1286    --        return False;   -- RM 4.5.2(23)
1287    --     end if;
1288
1289    --     declare
1290    --        A1 : Index_T1 := A'first (1);
1291    --        B1 : Index_T1 := B'first (1);
1292    --     begin
1293    --        loop
1294    --           declare
1295    --              A2 : Index_T2 := A'first (2);
1296    --              B2 : Index_T2 := B'first (2);
1297    --           begin
1298    --              loop
1299    --                 if A (A1, A2) /= B (B1, B2) then
1300    --                    return False;
1301    --                 end if;
1302
1303    --                 exit when A2 = A'last (2);
1304    --                 A2 := Index_T2'succ (A2);
1305    --                 B2 := Index_T2'succ (B2);
1306    --              end loop;
1307    --           end;
1308
1309    --           exit when A1 = A'last (1);
1310    --           A1 := Index_T1'succ (A1);
1311    --           B1 := Index_T1'succ (B1);
1312    --        end loop;
1313    --     end;
1314
1315    --     return true;
1316    --  end Enn;
1317
1318    --  Note on the formal types used (atyp and btyp). If either of the arrays
1319    --  is of a private type, we use the underlying type, and do an unchecked
1320    --  conversion of the actual. If either of the arrays has a bound depending
1321    --  on a discriminant, then we use the base type since otherwise we have an
1322    --  escaped discriminant in the function.
1323
1324    --  If both arrays are constrained and have the same bounds, we can generate
1325    --  a loop with an explicit iteration scheme using a 'Range attribute over
1326    --  the first array.
1327
1328    function Expand_Array_Equality
1329      (Nod    : Node_Id;
1330       Lhs    : Node_Id;
1331       Rhs    : Node_Id;
1332       Bodies : List_Id;
1333       Typ    : Entity_Id) return Node_Id
1334    is
1335       Loc         : constant Source_Ptr := Sloc (Nod);
1336       Decls       : constant List_Id    := New_List;
1337       Index_List1 : constant List_Id    := New_List;
1338       Index_List2 : constant List_Id    := New_List;
1339
1340       Actuals   : List_Id;
1341       Formals   : List_Id;
1342       Func_Name : Entity_Id;
1343       Func_Body : Node_Id;
1344
1345       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1346       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1347
1348       Ltyp : Entity_Id;
1349       Rtyp : Entity_Id;
1350       --  The parameter types to be used for the formals
1351
1352       function Arr_Attr
1353         (Arr : Entity_Id;
1354          Nam : Name_Id;
1355          Num : Int) return Node_Id;
1356       --  This builds the attribute reference Arr'Nam (Expr)
1357
1358       function Component_Equality (Typ : Entity_Id) return Node_Id;
1359       --  Create one statement to compare corresponding components, designated
1360       --  by a full set of indices.
1361
1362       function Get_Arg_Type (N : Node_Id) return Entity_Id;
1363       --  Given one of the arguments, computes the appropriate type to be used
1364       --  for that argument in the corresponding function formal
1365
1366       function Handle_One_Dimension
1367         (N     : Int;
1368          Index : Node_Id) return Node_Id;
1369       --  This procedure returns the following code
1370       --
1371       --    declare
1372       --       Bn : Index_T := B'First (N);
1373       --    begin
1374       --       loop
1375       --          xxx
1376       --          exit when An = A'Last (N);
1377       --          An := Index_T'Succ (An)
1378       --          Bn := Index_T'Succ (Bn)
1379       --       end loop;
1380       --    end;
1381       --
1382       --  If both indices are constrained and identical, the procedure
1383       --  returns a simpler loop:
1384       --
1385       --      for An in A'Range (N) loop
1386       --         xxx
1387       --      end loop
1388       --
1389       --  N is the dimension for which we are generating a loop. Index is the
1390       --  N'th index node, whose Etype is Index_Type_n in the above code. The
1391       --  xxx statement is either the loop or declare for the next dimension
1392       --  or if this is the last dimension the comparison of corresponding
1393       --  components of the arrays.
1394       --
1395       --  The actual way the code works is to return the comparison of
1396       --  corresponding components for the N+1 call. That's neater!
1397
1398       function Test_Empty_Arrays return Node_Id;
1399       --  This function constructs the test for both arrays being empty
1400       --    (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1401       --      and then
1402       --    (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1403
1404       function Test_Lengths_Correspond return Node_Id;
1405       --  This function constructs the test for arrays having different lengths
1406       --  in at least one index position, in which case the resulting code is:
1407
1408       --     A'length (1) /= B'length (1)
1409       --       or else
1410       --     A'length (2) /= B'length (2)
1411       --       or else
1412       --       ...
1413
1414       --------------
1415       -- Arr_Attr --
1416       --------------
1417
1418       function Arr_Attr
1419         (Arr : Entity_Id;
1420          Nam : Name_Id;
1421          Num : Int) return Node_Id
1422       is
1423       begin
1424          return
1425            Make_Attribute_Reference (Loc,
1426             Attribute_Name => Nam,
1427             Prefix => New_Reference_To (Arr, Loc),
1428             Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1429       end Arr_Attr;
1430
1431       ------------------------
1432       -- Component_Equality --
1433       ------------------------
1434
1435       function Component_Equality (Typ : Entity_Id) return Node_Id is
1436          Test : Node_Id;
1437          L, R : Node_Id;
1438
1439       begin
1440          --  if a(i1...) /= b(j1...) then return false; end if;
1441
1442          L :=
1443            Make_Indexed_Component (Loc,
1444              Prefix => Make_Identifier (Loc, Chars (A)),
1445              Expressions => Index_List1);
1446
1447          R :=
1448            Make_Indexed_Component (Loc,
1449              Prefix => Make_Identifier (Loc, Chars (B)),
1450              Expressions => Index_List2);
1451
1452          Test := Expand_Composite_Equality
1453                    (Nod, Component_Type (Typ), L, R, Decls);
1454
1455          --  If some (sub)component is an unchecked_union, the whole operation
1456          --  will raise program error.
1457
1458          if Nkind (Test) = N_Raise_Program_Error then
1459
1460             --  This node is going to be inserted at a location where a
1461             --  statement is expected: clear its Etype so analysis will set
1462             --  it to the expected Standard_Void_Type.
1463
1464             Set_Etype (Test, Empty);
1465             return Test;
1466
1467          else
1468             return
1469               Make_Implicit_If_Statement (Nod,
1470                 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1471                 Then_Statements => New_List (
1472                   Make_Simple_Return_Statement (Loc,
1473                     Expression => New_Occurrence_Of (Standard_False, Loc))));
1474          end if;
1475       end Component_Equality;
1476
1477       ------------------
1478       -- Get_Arg_Type --
1479       ------------------
1480
1481       function Get_Arg_Type (N : Node_Id) return Entity_Id is
1482          T : Entity_Id;
1483          X : Node_Id;
1484
1485       begin
1486          T := Etype (N);
1487
1488          if No (T) then
1489             return Typ;
1490
1491          else
1492             T := Underlying_Type (T);
1493
1494             X := First_Index (T);
1495             while Present (X) loop
1496                if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1497                  or else
1498                    Denotes_Discriminant (Type_High_Bound (Etype (X)))
1499                then
1500                   T := Base_Type (T);
1501                   exit;
1502                end if;
1503
1504                Next_Index (X);
1505             end loop;
1506
1507             return T;
1508          end if;
1509       end Get_Arg_Type;
1510
1511       --------------------------
1512       -- Handle_One_Dimension --
1513       ---------------------------
1514
1515       function Handle_One_Dimension
1516         (N     : Int;
1517          Index : Node_Id) return Node_Id
1518       is
1519          Need_Separate_Indexes : constant Boolean :=
1520                                    Ltyp /= Rtyp
1521                                      or else not Is_Constrained (Ltyp);
1522          --  If the index types are identical, and we are working with
1523          --  constrained types, then we can use the same index for both
1524          --  of the arrays.
1525
1526          An : constant Entity_Id := Make_Defining_Identifier (Loc,
1527                                       Chars => New_Internal_Name ('A'));
1528
1529          Bn       : Entity_Id;
1530          Index_T  : Entity_Id;
1531          Stm_List : List_Id;
1532          Loop_Stm : Node_Id;
1533
1534       begin
1535          if N > Number_Dimensions (Ltyp) then
1536             return Component_Equality (Ltyp);
1537          end if;
1538
1539          --  Case where we generate a loop
1540
1541          Index_T := Base_Type (Etype (Index));
1542
1543          if Need_Separate_Indexes then
1544             Bn :=
1545               Make_Defining_Identifier (Loc,
1546                 Chars => New_Internal_Name ('B'));
1547          else
1548             Bn := An;
1549          end if;
1550
1551          Append (New_Reference_To (An, Loc), Index_List1);
1552          Append (New_Reference_To (Bn, Loc), Index_List2);
1553
1554          Stm_List := New_List (
1555            Handle_One_Dimension (N + 1, Next_Index (Index)));
1556
1557          if Need_Separate_Indexes then
1558
1559             --  Generate guard for loop, followed by increments of indices
1560
1561             Append_To (Stm_List,
1562                Make_Exit_Statement (Loc,
1563                  Condition =>
1564                    Make_Op_Eq (Loc,
1565                       Left_Opnd => New_Reference_To (An, Loc),
1566                       Right_Opnd => Arr_Attr (A, Name_Last, N))));
1567
1568             Append_To (Stm_List,
1569               Make_Assignment_Statement (Loc,
1570                 Name       => New_Reference_To (An, Loc),
1571                 Expression =>
1572                   Make_Attribute_Reference (Loc,
1573                     Prefix         => New_Reference_To (Index_T, Loc),
1574                     Attribute_Name => Name_Succ,
1575                     Expressions    => New_List (New_Reference_To (An, Loc)))));
1576
1577             Append_To (Stm_List,
1578               Make_Assignment_Statement (Loc,
1579                 Name       => New_Reference_To (Bn, Loc),
1580                 Expression =>
1581                   Make_Attribute_Reference (Loc,
1582                     Prefix         => New_Reference_To (Index_T, Loc),
1583                     Attribute_Name => Name_Succ,
1584                     Expressions    => New_List (New_Reference_To (Bn, Loc)))));
1585          end if;
1586
1587          --  If separate indexes, we need a declare block for An and Bn, and a
1588          --  loop without an iteration scheme.
1589
1590          if Need_Separate_Indexes then
1591             Loop_Stm :=
1592               Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1593
1594             return
1595               Make_Block_Statement (Loc,
1596                 Declarations => New_List (
1597                   Make_Object_Declaration (Loc,
1598                     Defining_Identifier => An,
1599                     Object_Definition   => New_Reference_To (Index_T, Loc),
1600                     Expression          => Arr_Attr (A, Name_First, N)),
1601
1602                   Make_Object_Declaration (Loc,
1603                     Defining_Identifier => Bn,
1604                     Object_Definition   => New_Reference_To (Index_T, Loc),
1605                     Expression          => Arr_Attr (B, Name_First, N))),
1606
1607                 Handled_Statement_Sequence =>
1608                   Make_Handled_Sequence_Of_Statements (Loc,
1609                     Statements => New_List (Loop_Stm)));
1610
1611          --  If no separate indexes, return loop statement with explicit
1612          --  iteration scheme on its own
1613
1614          else
1615             Loop_Stm :=
1616               Make_Implicit_Loop_Statement (Nod,
1617                 Statements       => Stm_List,
1618                 Iteration_Scheme =>
1619                   Make_Iteration_Scheme (Loc,
1620                     Loop_Parameter_Specification =>
1621                       Make_Loop_Parameter_Specification (Loc,
1622                         Defining_Identifier         => An,
1623                         Discrete_Subtype_Definition =>
1624                           Arr_Attr (A, Name_Range, N))));
1625             return Loop_Stm;
1626          end if;
1627       end Handle_One_Dimension;
1628
1629       -----------------------
1630       -- Test_Empty_Arrays --
1631       -----------------------
1632
1633       function Test_Empty_Arrays return Node_Id is
1634          Alist : Node_Id;
1635          Blist : Node_Id;
1636
1637          Atest : Node_Id;
1638          Btest : Node_Id;
1639
1640       begin
1641          Alist := Empty;
1642          Blist := Empty;
1643          for J in 1 .. Number_Dimensions (Ltyp) loop
1644             Atest :=
1645               Make_Op_Eq (Loc,
1646                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1647                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1648
1649             Btest :=
1650               Make_Op_Eq (Loc,
1651                 Left_Opnd  => Arr_Attr (B, Name_Length, J),
1652                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1653
1654             if No (Alist) then
1655                Alist := Atest;
1656                Blist := Btest;
1657
1658             else
1659                Alist :=
1660                  Make_Or_Else (Loc,
1661                    Left_Opnd  => Relocate_Node (Alist),
1662                    Right_Opnd => Atest);
1663
1664                Blist :=
1665                  Make_Or_Else (Loc,
1666                    Left_Opnd  => Relocate_Node (Blist),
1667                    Right_Opnd => Btest);
1668             end if;
1669          end loop;
1670
1671          return
1672            Make_And_Then (Loc,
1673              Left_Opnd  => Alist,
1674              Right_Opnd => Blist);
1675       end Test_Empty_Arrays;
1676
1677       -----------------------------
1678       -- Test_Lengths_Correspond --
1679       -----------------------------
1680
1681       function Test_Lengths_Correspond return Node_Id is
1682          Result : Node_Id;
1683          Rtest  : Node_Id;
1684
1685       begin
1686          Result := Empty;
1687          for J in 1 .. Number_Dimensions (Ltyp) loop
1688             Rtest :=
1689               Make_Op_Ne (Loc,
1690                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1691                 Right_Opnd => Arr_Attr (B, Name_Length, J));
1692
1693             if No (Result) then
1694                Result := Rtest;
1695             else
1696                Result :=
1697                  Make_Or_Else (Loc,
1698                    Left_Opnd  => Relocate_Node (Result),
1699                    Right_Opnd => Rtest);
1700             end if;
1701          end loop;
1702
1703          return Result;
1704       end Test_Lengths_Correspond;
1705
1706    --  Start of processing for Expand_Array_Equality
1707
1708    begin
1709       Ltyp := Get_Arg_Type (Lhs);
1710       Rtyp := Get_Arg_Type (Rhs);
1711
1712       --  For now, if the argument types are not the same, go to the base type,
1713       --  since the code assumes that the formals have the same type. This is
1714       --  fixable in future ???
1715
1716       if Ltyp /= Rtyp then
1717          Ltyp := Base_Type (Ltyp);
1718          Rtyp := Base_Type (Rtyp);
1719          pragma Assert (Ltyp = Rtyp);
1720       end if;
1721
1722       --  Build list of formals for function
1723
1724       Formals := New_List (
1725         Make_Parameter_Specification (Loc,
1726           Defining_Identifier => A,
1727           Parameter_Type      => New_Reference_To (Ltyp, Loc)),
1728
1729         Make_Parameter_Specification (Loc,
1730           Defining_Identifier => B,
1731           Parameter_Type      => New_Reference_To (Rtyp, Loc)));
1732
1733       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
1734
1735       --  Build statement sequence for function
1736
1737       Func_Body :=
1738         Make_Subprogram_Body (Loc,
1739           Specification =>
1740             Make_Function_Specification (Loc,
1741               Defining_Unit_Name       => Func_Name,
1742               Parameter_Specifications => Formals,
1743               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
1744
1745           Declarations =>  Decls,
1746
1747           Handled_Statement_Sequence =>
1748             Make_Handled_Sequence_Of_Statements (Loc,
1749               Statements => New_List (
1750
1751                 Make_Implicit_If_Statement (Nod,
1752                   Condition => Test_Empty_Arrays,
1753                   Then_Statements => New_List (
1754                     Make_Simple_Return_Statement (Loc,
1755                       Expression =>
1756                         New_Occurrence_Of (Standard_True, Loc)))),
1757
1758                 Make_Implicit_If_Statement (Nod,
1759                   Condition => Test_Lengths_Correspond,
1760                   Then_Statements => New_List (
1761                     Make_Simple_Return_Statement (Loc,
1762                       Expression =>
1763                         New_Occurrence_Of (Standard_False, Loc)))),
1764
1765                 Handle_One_Dimension (1, First_Index (Ltyp)),
1766
1767                 Make_Simple_Return_Statement (Loc,
1768                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
1769
1770          Set_Has_Completion (Func_Name, True);
1771          Set_Is_Inlined (Func_Name);
1772
1773          --  If the array type is distinct from the type of the arguments, it
1774          --  is the full view of a private type. Apply an unchecked conversion
1775          --  to insure that analysis of the call succeeds.
1776
1777          declare
1778             L, R : Node_Id;
1779
1780          begin
1781             L := Lhs;
1782             R := Rhs;
1783
1784             if No (Etype (Lhs))
1785               or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1786             then
1787                L := OK_Convert_To (Ltyp, Lhs);
1788             end if;
1789
1790             if No (Etype (Rhs))
1791               or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1792             then
1793                R := OK_Convert_To (Rtyp, Rhs);
1794             end if;
1795
1796             Actuals := New_List (L, R);
1797          end;
1798
1799          Append_To (Bodies, Func_Body);
1800
1801          return
1802            Make_Function_Call (Loc,
1803              Name                   => New_Reference_To (Func_Name, Loc),
1804              Parameter_Associations => Actuals);
1805    end Expand_Array_Equality;
1806
1807    -----------------------------
1808    -- Expand_Boolean_Operator --
1809    -----------------------------
1810
1811    --  Note that we first get the actual subtypes of the operands, since we
1812    --  always want to deal with types that have bounds.
1813
1814    procedure Expand_Boolean_Operator (N : Node_Id) is
1815       Typ : constant Entity_Id  := Etype (N);
1816
1817    begin
1818       --  Special case of bit packed array where both operands are known to be
1819       --  properly aligned. In this case we use an efficient run time routine
1820       --  to carry out the operation (see System.Bit_Ops).
1821
1822       if Is_Bit_Packed_Array (Typ)
1823         and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
1824         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
1825       then
1826          Expand_Packed_Boolean_Operator (N);
1827          return;
1828       end if;
1829
1830       --  For the normal non-packed case, the general expansion is to build
1831       --  function for carrying out the comparison (use Make_Boolean_Array_Op)
1832       --  and then inserting it into the tree. The original operator node is
1833       --  then rewritten as a call to this function. We also use this in the
1834       --  packed case if either operand is a possibly unaligned object.
1835
1836       declare
1837          Loc       : constant Source_Ptr := Sloc (N);
1838          L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
1839          R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
1840          Func_Body : Node_Id;
1841          Func_Name : Entity_Id;
1842
1843       begin
1844          Convert_To_Actual_Subtype (L);
1845          Convert_To_Actual_Subtype (R);
1846          Ensure_Defined (Etype (L), N);
1847          Ensure_Defined (Etype (R), N);
1848          Apply_Length_Check (R, Etype (L));
1849
1850          if Nkind (N) = N_Op_Xor then
1851             Silly_Boolean_Array_Xor_Test (N, Etype (L));
1852          end if;
1853
1854          if Nkind (Parent (N)) = N_Assignment_Statement
1855            and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
1856          then
1857             Build_Boolean_Array_Proc_Call (Parent (N), L, R);
1858
1859          elsif Nkind (Parent (N)) = N_Op_Not
1860            and then Nkind (N) = N_Op_And
1861            and then
1862              Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
1863          then
1864             return;
1865          else
1866
1867             Func_Body := Make_Boolean_Array_Op (Etype (L), N);
1868             Func_Name := Defining_Unit_Name (Specification (Func_Body));
1869             Insert_Action (N, Func_Body);
1870
1871             --  Now rewrite the expression with a call
1872
1873             Rewrite (N,
1874               Make_Function_Call (Loc,
1875                 Name                   => New_Reference_To (Func_Name, Loc),
1876                 Parameter_Associations =>
1877                   New_List (
1878                     L,
1879                     Make_Type_Conversion
1880                       (Loc, New_Reference_To (Etype (L), Loc), R))));
1881
1882             Analyze_And_Resolve (N, Typ);
1883          end if;
1884       end;
1885    end Expand_Boolean_Operator;
1886
1887    -------------------------------
1888    -- Expand_Composite_Equality --
1889    -------------------------------
1890
1891    --  This function is only called for comparing internal fields of composite
1892    --  types when these fields are themselves composites. This is a special
1893    --  case because it is not possible to respect normal Ada visibility rules.
1894
1895    function Expand_Composite_Equality
1896      (Nod    : Node_Id;
1897       Typ    : Entity_Id;
1898       Lhs    : Node_Id;
1899       Rhs    : Node_Id;
1900       Bodies : List_Id) return Node_Id
1901    is
1902       Loc       : constant Source_Ptr := Sloc (Nod);
1903       Full_Type : Entity_Id;
1904       Prim      : Elmt_Id;
1905       Eq_Op     : Entity_Id;
1906
1907    begin
1908       if Is_Private_Type (Typ) then
1909          Full_Type := Underlying_Type (Typ);
1910       else
1911          Full_Type := Typ;
1912       end if;
1913
1914       --  Defense against malformed private types with no completion the error
1915       --  will be diagnosed later by check_completion
1916
1917       if No (Full_Type) then
1918          return New_Reference_To (Standard_False, Loc);
1919       end if;
1920
1921       Full_Type := Base_Type (Full_Type);
1922
1923       if Is_Array_Type (Full_Type) then
1924
1925          --  If the operand is an elementary type other than a floating-point
1926          --  type, then we can simply use the built-in block bitwise equality,
1927          --  since the predefined equality operators always apply and bitwise
1928          --  equality is fine for all these cases.
1929
1930          if Is_Elementary_Type (Component_Type (Full_Type))
1931            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
1932          then
1933             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
1934
1935          --  For composite component types, and floating-point types, use the
1936          --  expansion. This deals with tagged component types (where we use
1937          --  the applicable equality routine) and floating-point, (where we
1938          --  need to worry about negative zeroes), and also the case of any
1939          --  composite type recursively containing such fields.
1940
1941          else
1942             return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
1943          end if;
1944
1945       elsif Is_Tagged_Type (Full_Type) then
1946
1947          --  Call the primitive operation "=" of this type
1948
1949          if Is_Class_Wide_Type (Full_Type) then
1950             Full_Type := Root_Type (Full_Type);
1951          end if;
1952
1953          --  If this is derived from an untagged private type completed with a
1954          --  tagged type, it does not have a full view, so we use the primitive
1955          --  operations of the private type. This check should no longer be
1956          --  necessary when these types receive their full views ???
1957
1958          if Is_Private_Type (Typ)
1959            and then not Is_Tagged_Type (Typ)
1960            and then not Is_Controlled (Typ)
1961            and then Is_Derived_Type (Typ)
1962            and then No (Full_View (Typ))
1963          then
1964             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
1965          else
1966             Prim := First_Elmt (Primitive_Operations (Full_Type));
1967          end if;
1968
1969          loop
1970             Eq_Op := Node (Prim);
1971             exit when Chars (Eq_Op) = Name_Op_Eq
1972               and then Etype (First_Formal (Eq_Op)) =
1973                        Etype (Next_Formal (First_Formal (Eq_Op)))
1974               and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
1975             Next_Elmt (Prim);
1976             pragma Assert (Present (Prim));
1977          end loop;
1978
1979          Eq_Op := Node (Prim);
1980
1981          return
1982            Make_Function_Call (Loc,
1983              Name => New_Reference_To (Eq_Op, Loc),
1984              Parameter_Associations =>
1985                New_List
1986                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
1987                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
1988
1989       elsif Is_Record_Type (Full_Type) then
1990          Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
1991
1992          if Present (Eq_Op) then
1993             if Etype (First_Formal (Eq_Op)) /= Full_Type then
1994
1995                --  Inherited equality from parent type. Convert the actuals to
1996                --  match signature of operation.
1997
1998                declare
1999                   T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2000
2001                begin
2002                   return
2003                     Make_Function_Call (Loc,
2004                       Name => New_Reference_To (Eq_Op, Loc),
2005                       Parameter_Associations =>
2006                         New_List (OK_Convert_To (T, Lhs),
2007                                   OK_Convert_To (T, Rhs)));
2008                end;
2009
2010             else
2011                --  Comparison between Unchecked_Union components
2012
2013                if Is_Unchecked_Union (Full_Type) then
2014                   declare
2015                      Lhs_Type      : Node_Id := Full_Type;
2016                      Rhs_Type      : Node_Id := Full_Type;
2017                      Lhs_Discr_Val : Node_Id;
2018                      Rhs_Discr_Val : Node_Id;
2019
2020                   begin
2021                      --  Lhs subtype
2022
2023                      if Nkind (Lhs) = N_Selected_Component then
2024                         Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2025                      end if;
2026
2027                      --  Rhs subtype
2028
2029                      if Nkind (Rhs) = N_Selected_Component then
2030                         Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2031                      end if;
2032
2033                      --  Lhs of the composite equality
2034
2035                      if Is_Constrained (Lhs_Type) then
2036
2037                         --  Since the enclosing record type can never be an
2038                         --  Unchecked_Union (this code is executed for records
2039                         --  that do not have variants), we may reference its
2040                         --  discriminant(s).
2041
2042                         if Nkind (Lhs) = N_Selected_Component
2043                           and then Has_Per_Object_Constraint (
2044                                      Entity (Selector_Name (Lhs)))
2045                         then
2046                            Lhs_Discr_Val :=
2047                              Make_Selected_Component (Loc,
2048                                Prefix => Prefix (Lhs),
2049                                Selector_Name =>
2050                                  New_Copy (
2051                                    Get_Discriminant_Value (
2052                                      First_Discriminant (Lhs_Type),
2053                                      Lhs_Type,
2054                                      Stored_Constraint (Lhs_Type))));
2055
2056                         else
2057                            Lhs_Discr_Val := New_Copy (
2058                              Get_Discriminant_Value (
2059                                First_Discriminant (Lhs_Type),
2060                                Lhs_Type,
2061                                Stored_Constraint (Lhs_Type)));
2062
2063                         end if;
2064                      else
2065                         --  It is not possible to infer the discriminant since
2066                         --  the subtype is not constrained.
2067
2068                         return
2069                           Make_Raise_Program_Error (Loc,
2070                             Reason => PE_Unchecked_Union_Restriction);
2071                      end if;
2072
2073                      --  Rhs of the composite equality
2074
2075                      if Is_Constrained (Rhs_Type) then
2076                         if Nkind (Rhs) = N_Selected_Component
2077                           and then Has_Per_Object_Constraint (
2078                                      Entity (Selector_Name (Rhs)))
2079                         then
2080                            Rhs_Discr_Val :=
2081                              Make_Selected_Component (Loc,
2082                                Prefix => Prefix (Rhs),
2083                                Selector_Name =>
2084                                  New_Copy (
2085                                    Get_Discriminant_Value (
2086                                      First_Discriminant (Rhs_Type),
2087                                      Rhs_Type,
2088                                      Stored_Constraint (Rhs_Type))));
2089
2090                         else
2091                            Rhs_Discr_Val := New_Copy (
2092                              Get_Discriminant_Value (
2093                                First_Discriminant (Rhs_Type),
2094                                Rhs_Type,
2095                                Stored_Constraint (Rhs_Type)));
2096
2097                         end if;
2098                      else
2099                         return
2100                           Make_Raise_Program_Error (Loc,
2101                             Reason => PE_Unchecked_Union_Restriction);
2102                      end if;
2103
2104                      --  Call the TSS equality function with the inferred
2105                      --  discriminant values.
2106
2107                      return
2108                        Make_Function_Call (Loc,
2109                          Name => New_Reference_To (Eq_Op, Loc),
2110                          Parameter_Associations => New_List (
2111                            Lhs,
2112                            Rhs,
2113                            Lhs_Discr_Val,
2114                            Rhs_Discr_Val));
2115                   end;
2116                end if;
2117
2118                --  Shouldn't this be an else, we can't fall through the above
2119                --  IF, right???
2120
2121                return
2122                  Make_Function_Call (Loc,
2123                    Name => New_Reference_To (Eq_Op, Loc),
2124                    Parameter_Associations => New_List (Lhs, Rhs));
2125             end if;
2126
2127          else
2128             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2129          end if;
2130
2131       else
2132          --  It can be a simple record or the full view of a scalar private
2133
2134          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2135       end if;
2136    end Expand_Composite_Equality;
2137
2138    ------------------------------
2139    -- Expand_Concatenate_Other --
2140    ------------------------------
2141
2142    --  Let n be the number of array operands to be concatenated, Base_Typ their
2143    --  base type, Ind_Typ their index type, and Arr_Typ the original array type
2144    --  to which the concatenation operator applies, then the following
2145    --  subprogram is constructed:
2146
2147    --  [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
2148    --      L : Ind_Typ;
2149    --   begin
2150    --      if S1'Length /= 0 then
2151    --         L := XXX;   -->  XXX = S1'First       if Arr_Typ is unconstrained
2152    --                          XXX = Arr_Typ'First  otherwise
2153    --      elsif S2'Length /= 0 then
2154    --         L := YYY;   -->  YYY = S2'First       if Arr_Typ is unconstrained
2155    --                          YYY = Arr_Typ'First  otherwise
2156    --      ...
2157    --      elsif Sn-1'Length /= 0 then
2158    --         L := ZZZ;   -->  ZZZ = Sn-1'First     if Arr_Typ is unconstrained
2159    --                          ZZZ = Arr_Typ'First  otherwise
2160    --      else
2161    --         return Sn;
2162    --      end if;
2163
2164    --      declare
2165    --         P : Ind_Typ;
2166    --         H : Ind_Typ :=
2167    --          Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
2168    --                       + Ind_Typ'Pos (L));
2169    --         R : Base_Typ (L .. H);
2170    --      begin
2171    --         if S1'Length /= 0 then
2172    --            P := S1'First;
2173    --            loop
2174    --               R (L) := S1 (P);
2175    --               L := Ind_Typ'Succ (L);
2176    --               exit when P = S1'Last;
2177    --               P := Ind_Typ'Succ (P);
2178    --            end loop;
2179    --         end if;
2180    --
2181    --         if S2'Length /= 0 then
2182    --            L := Ind_Typ'Succ (L);
2183    --            loop
2184    --               R (L) := S2 (P);
2185    --               L := Ind_Typ'Succ (L);
2186    --               exit when P = S2'Last;
2187    --               P := Ind_Typ'Succ (P);
2188    --            end loop;
2189    --         end if;
2190
2191    --         ...
2192
2193    --         if Sn'Length /= 0 then
2194    --            P := Sn'First;
2195    --            loop
2196    --               R (L) := Sn (P);
2197    --               L := Ind_Typ'Succ (L);
2198    --               exit when P = Sn'Last;
2199    --               P := Ind_Typ'Succ (P);
2200    --            end loop;
2201    --         end if;
2202
2203    --         return R;
2204    --      end;
2205    --   end Cnn;]
2206
2207    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
2208       Loc      : constant Source_Ptr := Sloc (Cnode);
2209       Nb_Opnds : constant Nat        := List_Length (Opnds);
2210
2211       Arr_Typ  : constant Entity_Id := Etype (Entity (Cnode));
2212       Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
2213       Ind_Typ  : constant Entity_Id := Etype (First_Index (Base_Typ));
2214
2215       Func_Id     : Node_Id;
2216       Func_Spec   : Node_Id;
2217       Param_Specs : List_Id;
2218
2219       Func_Body  : Node_Id;
2220       Func_Decls : List_Id;
2221       Func_Stmts : List_Id;
2222
2223       L_Decl     : Node_Id;
2224
2225       If_Stmt    : Node_Id;
2226       Elsif_List : List_Id;
2227
2228       Declare_Block : Node_Id;
2229       Declare_Decls : List_Id;
2230       Declare_Stmts : List_Id;
2231
2232       H_Decl   : Node_Id;
2233       I_Decl   : Node_Id;
2234       H_Init   : Node_Id;
2235       P_Decl   : Node_Id;
2236       R_Decl   : Node_Id;
2237       R_Constr : Node_Id;
2238       R_Range  : Node_Id;
2239
2240       Params  : List_Id;
2241       Operand : Node_Id;
2242
2243       function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
2244       --  Builds the sequence of statement:
2245       --    P := Si'First;
2246       --    loop
2247       --       R (L) := Si (P);
2248       --       L := Ind_Typ'Succ (L);
2249       --       exit when P = Si'Last;
2250       --       P := Ind_Typ'Succ (P);
2251       --    end loop;
2252       --
2253       --  where i is the input parameter I given.
2254       --  If the flag Last is true, the exit statement is emitted before
2255       --  incrementing the lower bound, to prevent the creation out of
2256       --  bound values.
2257
2258       function Init_L (I : Nat) return Node_Id;
2259       --  Builds the statement:
2260       --    L := Arr_Typ'First;  If Arr_Typ is constrained
2261       --    L := Si'First;       otherwise (where I is the input param given)
2262
2263       function H return Node_Id;
2264       --  Builds reference to identifier H
2265
2266       function Ind_Val (E : Node_Id) return Node_Id;
2267       --  Builds expression Ind_Typ'Val (E);
2268
2269       function L return Node_Id;
2270       --  Builds reference to identifier L
2271
2272       function L_Pos return Node_Id;
2273       --  Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
2274       --  expression to avoid universal_integer computations whenever possible,
2275       --  in the expression for the upper bound H.
2276
2277       function L_Succ return Node_Id;
2278       --  Builds expression Ind_Typ'Succ (L)
2279
2280       function One return Node_Id;
2281       --  Builds integer literal one
2282
2283       function P return Node_Id;
2284       --  Builds reference to identifier P
2285
2286       function P_Succ return Node_Id;
2287       --  Builds expression Ind_Typ'Succ (P)
2288
2289       function R return Node_Id;
2290       --  Builds reference to identifier R
2291
2292       function S (I : Nat) return Node_Id;
2293       --  Builds reference to identifier Si, where I is the value given
2294
2295       function S_First (I : Nat) return Node_Id;
2296       --  Builds expression Si'First, where I is the value given
2297
2298       function S_Last (I : Nat) return Node_Id;
2299       --  Builds expression Si'Last, where I is the value given
2300
2301       function S_Length (I : Nat) return Node_Id;
2302       --  Builds expression Si'Length, where I is the value given
2303
2304       function S_Length_Test (I : Nat) return Node_Id;
2305       --  Builds expression Si'Length /= 0, where I is the value given
2306
2307       -------------------
2308       -- Copy_Into_R_S --
2309       -------------------
2310
2311       function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
2312          Stmts     : constant List_Id := New_List;
2313          P_Start   : Node_Id;
2314          Loop_Stmt : Node_Id;
2315          R_Copy    : Node_Id;
2316          Exit_Stmt : Node_Id;
2317          L_Inc     : Node_Id;
2318          P_Inc     : Node_Id;
2319
2320       begin
2321          --  First construct the initializations
2322
2323          P_Start := Make_Assignment_Statement (Loc,
2324                       Name       => P,
2325                       Expression => S_First (I));
2326          Append_To (Stmts, P_Start);
2327
2328          --  Then build the loop
2329
2330          R_Copy := Make_Assignment_Statement (Loc,
2331                      Name       => Make_Indexed_Component (Loc,
2332                                      Prefix      => R,
2333                                      Expressions => New_List (L)),
2334                      Expression => Make_Indexed_Component (Loc,
2335                                      Prefix      => S (I),
2336                                      Expressions => New_List (P)));
2337
2338          L_Inc := Make_Assignment_Statement (Loc,
2339                     Name       => L,
2340                     Expression => L_Succ);
2341
2342          Exit_Stmt := Make_Exit_Statement (Loc,
2343                         Condition => Make_Op_Eq (Loc, P, S_Last (I)));
2344
2345          P_Inc := Make_Assignment_Statement (Loc,
2346                     Name       => P,
2347                     Expression => P_Succ);
2348
2349          if Last then
2350             Loop_Stmt :=
2351               Make_Implicit_Loop_Statement (Cnode,
2352                 Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
2353          else
2354             Loop_Stmt :=
2355               Make_Implicit_Loop_Statement (Cnode,
2356                 Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
2357          end if;
2358
2359          Append_To (Stmts, Loop_Stmt);
2360
2361          return Stmts;
2362       end Copy_Into_R_S;
2363
2364       -------
2365       -- H --
2366       -------
2367
2368       function H return Node_Id is
2369       begin
2370          return Make_Identifier (Loc, Name_uH);
2371       end H;
2372
2373       -------------
2374       -- Ind_Val --
2375       -------------
2376
2377       function Ind_Val (E : Node_Id) return Node_Id is
2378       begin
2379          return
2380            Make_Attribute_Reference (Loc,
2381              Prefix         => New_Reference_To (Ind_Typ, Loc),
2382              Attribute_Name => Name_Val,
2383              Expressions    => New_List (E));
2384       end Ind_Val;
2385
2386       ------------
2387       -- Init_L --
2388       ------------
2389
2390       function Init_L (I : Nat) return Node_Id is
2391          E : Node_Id;
2392
2393       begin
2394          if Is_Constrained (Arr_Typ) then
2395             E := Make_Attribute_Reference (Loc,
2396                    Prefix         => New_Reference_To (Arr_Typ, Loc),
2397                    Attribute_Name => Name_First);
2398
2399          else
2400             E := S_First (I);
2401          end if;
2402
2403          return Make_Assignment_Statement (Loc, Name => L, Expression => E);
2404       end Init_L;
2405
2406       -------
2407       -- L --
2408       -------
2409
2410       function L return Node_Id is
2411       begin
2412          return Make_Identifier (Loc, Name_uL);
2413       end L;
2414
2415       -----------
2416       -- L_Pos --
2417       -----------
2418
2419       function L_Pos return Node_Id is
2420          Target_Type : Entity_Id;
2421
2422       begin
2423          --  If the index type is an enumeration type, the computation can be
2424          --  done in standard integer. Otherwise, choose a large enough integer
2425          --  type to accommodate the index type computation.
2426
2427          if Is_Enumeration_Type (Ind_Typ)
2428            or else Root_Type (Ind_Typ) = Standard_Integer
2429            or else Root_Type (Ind_Typ) = Standard_Short_Integer
2430            or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
2431            or else Is_Modular_Integer_Type (Ind_Typ)
2432          then
2433             Target_Type := Standard_Integer;
2434          else
2435             Target_Type := Root_Type (Ind_Typ);
2436          end if;
2437
2438          return
2439            Make_Qualified_Expression (Loc,
2440               Subtype_Mark => New_Reference_To (Target_Type, Loc),
2441               Expression   =>
2442                 Make_Attribute_Reference (Loc,
2443                   Prefix         => New_Reference_To (Ind_Typ, Loc),
2444                   Attribute_Name => Name_Pos,
2445                   Expressions    => New_List (L)));
2446       end L_Pos;
2447
2448       ------------
2449       -- L_Succ --
2450       ------------
2451
2452       function L_Succ return Node_Id is
2453       begin
2454          return
2455            Make_Attribute_Reference (Loc,
2456              Prefix         => New_Reference_To (Ind_Typ, Loc),
2457              Attribute_Name => Name_Succ,
2458              Expressions    => New_List (L));
2459       end L_Succ;
2460
2461       ---------
2462       -- One --
2463       ---------
2464
2465       function One return Node_Id is
2466       begin
2467          return Make_Integer_Literal (Loc, 1);
2468       end One;
2469
2470       -------
2471       -- P --
2472       -------
2473
2474       function P return Node_Id is
2475       begin
2476          return Make_Identifier (Loc, Name_uP);
2477       end P;
2478
2479       ------------
2480       -- P_Succ --
2481       ------------
2482
2483       function P_Succ return Node_Id is
2484       begin
2485          return
2486            Make_Attribute_Reference (Loc,
2487              Prefix         => New_Reference_To (Ind_Typ, Loc),
2488              Attribute_Name => Name_Succ,
2489              Expressions    => New_List (P));
2490       end P_Succ;
2491
2492       -------
2493       -- R --
2494       -------
2495
2496       function R return Node_Id is
2497       begin
2498          return Make_Identifier (Loc, Name_uR);
2499       end R;
2500
2501       -------
2502       -- S --
2503       -------
2504
2505       function S (I : Nat) return Node_Id is
2506       begin
2507          return Make_Identifier (Loc, New_External_Name ('S', I));
2508       end S;
2509
2510       -------------
2511       -- S_First --
2512       -------------
2513
2514       function S_First (I : Nat) return Node_Id is
2515       begin
2516          return Make_Attribute_Reference (Loc,
2517                   Prefix         => S (I),
2518                   Attribute_Name => Name_First);
2519       end S_First;
2520
2521       ------------
2522       -- S_Last --
2523       ------------
2524
2525       function S_Last (I : Nat) return Node_Id is
2526       begin
2527          return Make_Attribute_Reference (Loc,
2528                   Prefix         => S (I),
2529                   Attribute_Name => Name_Last);
2530       end S_Last;
2531
2532       --------------
2533       -- S_Length --
2534       --------------
2535
2536       function S_Length (I : Nat) return Node_Id is
2537       begin
2538          return Make_Attribute_Reference (Loc,
2539                   Prefix         => S (I),
2540                   Attribute_Name => Name_Length);
2541       end S_Length;
2542
2543       -------------------
2544       -- S_Length_Test --
2545       -------------------
2546
2547       function S_Length_Test (I : Nat) return Node_Id is
2548       begin
2549          return
2550            Make_Op_Ne (Loc,
2551              Left_Opnd  => S_Length (I),
2552              Right_Opnd => Make_Integer_Literal (Loc, 0));
2553       end S_Length_Test;
2554
2555    --  Start of processing for Expand_Concatenate_Other
2556
2557    begin
2558       --  Construct the parameter specs and the overall function spec
2559
2560       Param_Specs := New_List;
2561       for I in 1 .. Nb_Opnds loop
2562          Append_To
2563            (Param_Specs,
2564             Make_Parameter_Specification (Loc,
2565               Defining_Identifier =>
2566                 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
2567               Parameter_Type      => New_Reference_To (Base_Typ, Loc)));
2568       end loop;
2569
2570       Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2571       Func_Spec :=
2572         Make_Function_Specification (Loc,
2573           Defining_Unit_Name       => Func_Id,
2574           Parameter_Specifications => Param_Specs,
2575           Result_Definition        => New_Reference_To (Base_Typ, Loc));
2576
2577       --  Construct L's object declaration
2578
2579       L_Decl :=
2580         Make_Object_Declaration (Loc,
2581           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
2582           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
2583
2584       Func_Decls := New_List (L_Decl);
2585
2586       --  Construct the if-then-elsif statements
2587
2588       Elsif_List := New_List;
2589       for I in 2 .. Nb_Opnds - 1 loop
2590          Append_To (Elsif_List, Make_Elsif_Part (Loc,
2591                                   Condition       => S_Length_Test (I),
2592                                   Then_Statements => New_List (Init_L (I))));
2593       end loop;
2594
2595       If_Stmt :=
2596         Make_Implicit_If_Statement (Cnode,
2597           Condition       => S_Length_Test (1),
2598           Then_Statements => New_List (Init_L (1)),
2599           Elsif_Parts     => Elsif_List,
2600           Else_Statements => New_List (Make_Simple_Return_Statement (Loc,
2601                                          Expression => S (Nb_Opnds))));
2602
2603       --  Construct the declaration for H
2604
2605       P_Decl :=
2606         Make_Object_Declaration (Loc,
2607           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2608           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
2609
2610       H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
2611       for I in 2 .. Nb_Opnds loop
2612          H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
2613       end loop;
2614
2615       --  If the index type is small modular type, we need to perform an
2616       --  additional check that the upper bound fits in the index type.
2617       --  Otherwise the computation of the upper bound can wrap around
2618       --  and yield meaningless results. The constraint check has to be
2619       --  explicit in the code, because the generated function is compiled
2620       --  with checks disabled, for efficiency.
2621
2622       if Is_Modular_Integer_Type (Ind_Typ)
2623         and then Esize (Ind_Typ) < Esize (Standard_Integer)
2624       then
2625          I_Decl :=
2626             Make_Object_Declaration (Loc,
2627              Defining_Identifier => Make_Defining_Identifier (Loc, Name_uI),
2628              Object_Definition   => New_Reference_To (Standard_Integer, Loc),
2629              Expression          =>
2630                Make_Type_Conversion (Loc,
2631                   New_Reference_To (Standard_Integer, Loc),
2632                   Make_Op_Add (Loc, H_Init, L_Pos)));
2633
2634          H_Init :=
2635            Ind_Val (
2636              Make_Type_Conversion (Loc,
2637                New_Reference_To (Ind_Typ, Loc),
2638                New_Reference_To (Defining_Identifier (I_Decl), Loc)));
2639
2640       --  For other index types, computation is safe.
2641
2642       else
2643          H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
2644       end if;
2645
2646       H_Decl :=
2647         Make_Object_Declaration (Loc,
2648           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
2649           Object_Definition   => New_Reference_To (Ind_Typ, Loc),
2650           Expression          => H_Init);
2651
2652       --  Construct the declaration for R
2653
2654       R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
2655       R_Constr :=
2656         Make_Index_Or_Discriminant_Constraint (Loc,
2657           Constraints => New_List (R_Range));
2658
2659       R_Decl :=
2660         Make_Object_Declaration (Loc,
2661           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
2662           Object_Definition   =>
2663             Make_Subtype_Indication (Loc,
2664                Subtype_Mark => New_Reference_To (Base_Typ, Loc),
2665                Constraint   => R_Constr));
2666
2667       --  Construct the declarations for the declare block
2668
2669       Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
2670
2671       --  Add constraint check for the modular index case.
2672
2673       if Is_Modular_Integer_Type (Ind_Typ)
2674         and then Esize (Ind_Typ) < Esize (Standard_Integer)
2675       then
2676          Insert_After (P_Decl, I_Decl);
2677
2678          Insert_After (I_Decl,
2679             Make_Raise_Constraint_Error (Loc,
2680                Condition =>
2681                   Make_Op_Gt (Loc,
2682                      Left_Opnd =>
2683                        New_Reference_To (Defining_Identifier (I_Decl), Loc),
2684                      Right_Opnd =>
2685                        Make_Type_Conversion (Loc,
2686                           New_Reference_To (Standard_Integer, Loc),
2687                           Make_Attribute_Reference (Loc,
2688                              Prefix => New_Reference_To (Ind_Typ, Loc),
2689                              Attribute_Name => Name_Last))),
2690                 Reason => CE_Range_Check_Failed));
2691       end if;
2692
2693       --  Construct list of statements for the declare block
2694
2695       Declare_Stmts := New_List;
2696       for I in 1 .. Nb_Opnds loop
2697          Append_To (Declare_Stmts,
2698                     Make_Implicit_If_Statement (Cnode,
2699                       Condition       => S_Length_Test (I),
2700                       Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
2701       end loop;
2702
2703       Append_To
2704         (Declare_Stmts, Make_Simple_Return_Statement (Loc, Expression => R));
2705
2706       --  Construct the declare block
2707
2708       Declare_Block := Make_Block_Statement (Loc,
2709         Declarations               => Declare_Decls,
2710         Handled_Statement_Sequence =>
2711           Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
2712
2713       --  Construct the list of function statements
2714
2715       Func_Stmts := New_List (If_Stmt, Declare_Block);
2716
2717       --  Construct the function body
2718
2719       Func_Body :=
2720         Make_Subprogram_Body (Loc,
2721           Specification              => Func_Spec,
2722           Declarations               => Func_Decls,
2723           Handled_Statement_Sequence =>
2724             Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
2725
2726       --  Insert the newly generated function in the code. This is analyzed
2727       --  with all checks off, since we have completed all the checks.
2728
2729       --  Note that this does *not* fix the array concatenation bug when the
2730       --  low bound is Integer'first sibce that bug comes from the pointer
2731       --  dereferencing an unconstrained array. And there we need a constraint
2732       --  check to make sure the length of the concatenated array is ok. ???
2733
2734       Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
2735
2736       --  Construct list of arguments for the function call
2737
2738       Params := New_List;
2739       Operand  := First (Opnds);
2740       for I in 1 .. Nb_Opnds loop
2741          Append_To (Params, Relocate_Node (Operand));
2742          Next (Operand);
2743       end loop;
2744
2745       --  Insert the function call
2746
2747       Rewrite
2748         (Cnode,
2749          Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
2750
2751       Analyze_And_Resolve (Cnode, Base_Typ);
2752       Set_Is_Inlined (Func_Id);
2753    end Expand_Concatenate_Other;
2754
2755    -------------------------------
2756    -- Expand_Concatenate_String --
2757    -------------------------------
2758
2759    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
2760       Loc   : constant Source_Ptr := Sloc (Cnode);
2761       Opnd1 : constant Node_Id    := First (Opnds);
2762       Opnd2 : constant Node_Id    := Next (Opnd1);
2763       Typ1  : constant Entity_Id  := Base_Type (Etype (Opnd1));
2764       Typ2  : constant Entity_Id  := Base_Type (Etype (Opnd2));
2765
2766       R : RE_Id;
2767       --  RE_Id value for function to be called
2768
2769    begin
2770       --  In all cases, we build a call to a routine giving the list of
2771       --  arguments as the parameter list to the routine.
2772
2773       case List_Length (Opnds) is
2774          when 2 =>
2775             if Typ1 = Standard_Character then
2776                if Typ2 = Standard_Character then
2777                   R := RE_Str_Concat_CC;
2778
2779                else
2780                   pragma Assert (Typ2 = Standard_String);
2781                   R := RE_Str_Concat_CS;
2782                end if;
2783
2784             elsif Typ1 = Standard_String then
2785                if Typ2 = Standard_Character then
2786                   R := RE_Str_Concat_SC;
2787
2788                else
2789                   pragma Assert (Typ2 = Standard_String);
2790                   R := RE_Str_Concat;
2791                end if;
2792
2793             --  If we have anything other than Standard_Character or
2794             --  Standard_String, then we must have had a serious error
2795             --  earlier, so we just abandon the attempt at expansion.
2796
2797             else
2798                pragma Assert (Serious_Errors_Detected > 0);
2799                return;
2800             end if;
2801
2802          when 3 =>
2803             R := RE_Str_Concat_3;
2804
2805          when 4 =>
2806             R := RE_Str_Concat_4;
2807
2808          when 5 =>
2809             R := RE_Str_Concat_5;
2810
2811          when others =>
2812             R := RE_Null;
2813             raise Program_Error;
2814       end case;
2815
2816       --  Now generate the appropriate call
2817
2818       Rewrite (Cnode,
2819         Make_Function_Call (Sloc (Cnode),
2820           Name => New_Occurrence_Of (RTE (R), Loc),
2821           Parameter_Associations => Opnds));
2822
2823       Analyze_And_Resolve (Cnode, Standard_String);
2824
2825    exception
2826       when RE_Not_Available =>
2827          return;
2828    end Expand_Concatenate_String;
2829
2830    ------------------------
2831    -- Expand_N_Allocator --
2832    ------------------------
2833
2834    procedure Expand_N_Allocator (N : Node_Id) is
2835       PtrT  : constant Entity_Id  := Etype (N);
2836       Dtyp  : constant Entity_Id  := Designated_Type (PtrT);
2837       Etyp  : constant Entity_Id  := Etype (Expression (N));
2838       Loc   : constant Source_Ptr := Sloc (N);
2839       Desig : Entity_Id;
2840       Temp  : Entity_Id;
2841       Nod   : Node_Id;
2842
2843       procedure Complete_Coextension_Finalization;
2844       --  Generate finalization calls for all nested coextensions of N. This
2845       --  routine may allocate list controllers if necessary.
2846
2847       procedure Rewrite_Coextension (N : Node_Id);
2848       --  Static coextensions have the same lifetime as the entity they
2849       --  constrain. Such occurrences can be rewritten as aliased objects
2850       --  and their unrestricted access used instead of the coextension.
2851
2852       ---------------------------------------
2853       -- Complete_Coextension_Finalization --
2854       ---------------------------------------
2855
2856       procedure Complete_Coextension_Finalization is
2857          Coext      : Node_Id;
2858          Coext_Elmt : Elmt_Id;
2859          Flist      : Node_Id;
2860          Ref        : Node_Id;
2861
2862          function Inside_A_Return_Statement (N : Node_Id) return Boolean;
2863          --  Determine whether node N is part of a return statement
2864
2865          function Needs_Initialization_Call (N : Node_Id) return Boolean;
2866          --  Determine whether node N is a subtype indicator allocator which
2867          --  acts a coextension. Such coextensions need initialization.
2868
2869          -------------------------------
2870          -- Inside_A_Return_Statement --
2871          -------------------------------
2872
2873          function Inside_A_Return_Statement (N : Node_Id) return Boolean is
2874             P : Node_Id;
2875
2876          begin
2877             P := Parent (N);
2878             while Present (P) loop
2879                if Nkind_In
2880                    (P, N_Extended_Return_Statement, N_Simple_Return_Statement)
2881                then
2882                   return True;
2883
2884                --  Stop the traversal when we reach a subprogram body
2885
2886                elsif Nkind (P) = N_Subprogram_Body then
2887                   return False;
2888                end if;
2889
2890                P := Parent (P);
2891             end loop;
2892
2893             return False;
2894          end Inside_A_Return_Statement;
2895
2896          -------------------------------
2897          -- Needs_Initialization_Call --
2898          -------------------------------
2899
2900          function Needs_Initialization_Call (N : Node_Id) return Boolean is
2901             Obj_Decl : Node_Id;
2902
2903          begin
2904             if Nkind (N) = N_Explicit_Dereference
2905               and then Nkind (Prefix (N)) = N_Identifier
2906               and then Nkind (Parent (Entity (Prefix (N)))) =
2907                          N_Object_Declaration
2908             then
2909                Obj_Decl := Parent (Entity (Prefix (N)));
2910
2911                return
2912                  Present (Expression (Obj_Decl))
2913                    and then Nkind (Expression (Obj_Decl)) = N_Allocator
2914                    and then Nkind (Expression (Expression (Obj_Decl))) /=
2915                               N_Qualified_Expression;
2916             end if;
2917
2918             return False;
2919          end Needs_Initialization_Call;
2920
2921       --  Start of processing for Complete_Coextension_Finalization
2922
2923       begin
2924          --  When a coextension root is inside a return statement, we need to
2925          --  use the finalization chain of the function's scope. This does not
2926          --  apply for controlled named access types because in those cases we
2927          --  can use the finalization chain of the type itself.
2928
2929          if Inside_A_Return_Statement (N)
2930            and then
2931              (Ekind (PtrT) = E_Anonymous_Access_Type
2932                 or else
2933                   (Ekind (PtrT) = E_Access_Type
2934                      and then No (Associated_Final_Chain (PtrT))))
2935          then
2936             declare
2937                Decl    : Node_Id;
2938                Outer_S : Entity_Id;
2939                S       : Entity_Id := Current_Scope;
2940
2941             begin
2942                while Present (S) and then S /= Standard_Standard loop
2943                   if Ekind (S) = E_Function then
2944                      Outer_S := Scope (S);
2945
2946                      --  Retrieve the declaration of the body
2947
2948                      Decl := Parent (Parent (
2949                                Corresponding_Body (Parent (Parent (S)))));
2950                      exit;
2951                   end if;
2952
2953                   S := Scope (S);
2954                end loop;
2955
2956                --  Push the scope of the function body since we are inserting
2957                --  the list before the body, but we are currently in the body
2958                --  itself. Override the finalization list of PtrT since the
2959                --  finalization context is now different.
2960
2961                Push_Scope (Outer_S);
2962                Build_Final_List (Decl, PtrT);
2963                Pop_Scope;
2964             end;
2965
2966          --  The root allocator may not be controlled, but it still needs a
2967          --  finalization list for all nested coextensions.
2968
2969          elsif No (Associated_Final_Chain (PtrT)) then
2970             Build_Final_List (N, PtrT);
2971          end if;
2972
2973          Flist :=
2974            Make_Selected_Component (Loc,
2975              Prefix =>
2976                New_Reference_To (Associated_Final_Chain (PtrT), Loc),
2977              Selector_Name =>
2978                Make_Identifier (Loc, Name_F));
2979
2980          Coext_Elmt := First_Elmt (Coextensions (N));
2981          while Present (Coext_Elmt) loop
2982             Coext := Node (Coext_Elmt);
2983
2984             --  Generate:
2985             --    typ! (coext.all)
2986
2987             if Nkind (Coext) = N_Identifier then
2988                Ref :=
2989                  Make_Unchecked_Type_Conversion (Loc,
2990                    Subtype_Mark => New_Reference_To (Etype (Coext), Loc),
2991                    Expression   =>
2992                      Make_Explicit_Dereference (Loc,
2993                        Prefix => New_Copy_Tree (Coext)));
2994             else
2995                Ref := New_Copy_Tree (Coext);
2996             end if;
2997
2998             --  No initialization call if not allowed
2999
3000             Check_Restriction (No_Default_Initialization, N);
3001
3002             if not Restriction_Active (No_Default_Initialization) then
3003
3004                --  Generate:
3005                --    initialize (Ref)
3006                --    attach_to_final_list (Ref, Flist, 2)
3007
3008                if Needs_Initialization_Call (Coext) then
3009                   Insert_Actions (N,
3010                     Make_Init_Call (
3011                       Ref         => Ref,
3012                       Typ         => Etype (Coext),
3013                       Flist_Ref   => Flist,
3014                       With_Attach => Make_Integer_Literal (Loc, Uint_2)));
3015
3016                --  Generate:
3017                --    attach_to_final_list (Ref, Flist, 2)
3018
3019                else
3020                   Insert_Action (N,
3021                     Make_Attach_Call (
3022                       Obj_Ref     => Ref,
3023                       Flist_Ref   => New_Copy_Tree (Flist),
3024                       With_Attach => Make_Integer_Literal (Loc, Uint_2)));
3025                end if;
3026             end if;
3027
3028             Next_Elmt (Coext_Elmt);
3029          end loop;
3030       end Complete_Coextension_Finalization;
3031
3032       -------------------------
3033       -- Rewrite_Coextension --
3034       -------------------------
3035
3036       procedure Rewrite_Coextension (N : Node_Id) is
3037          Temp : constant Node_Id :=
3038                   Make_Defining_Identifier (Loc,
3039                     New_Internal_Name ('C'));
3040
3041          --  Generate:
3042          --    Cnn : aliased Etyp;
3043
3044          Decl : constant Node_Id :=
3045                   Make_Object_Declaration (Loc,
3046                     Defining_Identifier => Temp,
3047                     Aliased_Present     => True,
3048                     Object_Definition   =>
3049                       New_Occurrence_Of (Etyp, Loc));
3050          Nod  : Node_Id;
3051
3052       begin
3053          if Nkind (Expression (N)) = N_Qualified_Expression then
3054             Set_Expression (Decl, Expression (Expression (N)));
3055          end if;
3056
3057          --  Find the proper insertion node for the declaration
3058
3059          Nod := Parent (N);
3060          while Present (Nod) loop
3061             exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call
3062               or else Nkind (Nod) = N_Procedure_Call_Statement
3063               or else Nkind (Nod) in N_Declaration;
3064             Nod := Parent (Nod);
3065          end loop;
3066
3067          Insert_Before (Nod, Decl);
3068          Analyze (Decl);
3069
3070          Rewrite (N,
3071            Make_Attribute_Reference (Loc,
3072              Prefix         => New_Occurrence_Of (Temp, Loc),
3073              Attribute_Name => Name_Unrestricted_Access));
3074
3075          Analyze_And_Resolve (N, PtrT);
3076       end Rewrite_Coextension;
3077
3078    --  Start of processing for Expand_N_Allocator
3079
3080    begin
3081       --  RM E.2.3(22). We enforce that the expected type of an allocator
3082       --  shall not be a remote access-to-class-wide-limited-private type
3083
3084       --  Why is this being done at expansion time, seems clearly wrong ???
3085
3086       Validate_Remote_Access_To_Class_Wide_Type (N);
3087
3088       --  Set the Storage Pool
3089
3090       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
3091
3092       if Present (Storage_Pool (N)) then
3093          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
3094             if VM_Target = No_VM then
3095                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
3096             end if;
3097
3098          elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
3099             Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
3100
3101          else
3102             Set_Procedure_To_Call (N,
3103               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
3104          end if;
3105       end if;
3106
3107       --  Under certain circumstances we can replace an allocator by an access
3108       --  to statically allocated storage. The conditions, as noted in AARM
3109       --  3.10 (10c) are as follows:
3110
3111       --    Size and initial value is known at compile time
3112       --    Access type is access-to-constant
3113
3114       --  The allocator is not part of a constraint on a record component,
3115       --  because in that case the inserted actions are delayed until the
3116       --  record declaration is fully analyzed, which is too late for the
3117       --  analysis of the rewritten allocator.
3118
3119       if Is_Access_Constant (PtrT)
3120         and then Nkind (Expression (N)) = N_Qualified_Expression
3121         and then Compile_Time_Known_Value (Expression (Expression (N)))
3122         and then Size_Known_At_Compile_Time (Etype (Expression
3123                                                     (Expression (N))))
3124         and then not Is_Record_Type (Current_Scope)
3125       then
3126          --  Here we can do the optimization. For the allocator
3127
3128          --    new x'(y)
3129
3130          --  We insert an object declaration
3131
3132          --    Tnn : aliased x := y;
3133
3134          --  and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3135          --  marked as requiring static allocation.
3136
3137          Temp :=
3138            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3139
3140          Desig := Subtype_Mark (Expression (N));
3141
3142          --  If context is constrained, use constrained subtype directly,
3143          --  so that the constant is not labelled as having a nominally
3144          --  unconstrained subtype.
3145
3146          if Entity (Desig) = Base_Type (Dtyp) then
3147             Desig := New_Occurrence_Of (Dtyp, Loc);
3148          end if;
3149
3150          Insert_Action (N,
3151            Make_Object_Declaration (Loc,
3152              Defining_Identifier => Temp,
3153              Aliased_Present     => True,
3154              Constant_Present    => Is_Access_Constant (PtrT),
3155              Object_Definition   => Desig,
3156              Expression          => Expression (Expression (N))));
3157
3158          Rewrite (N,
3159            Make_Attribute_Reference (Loc,
3160              Prefix => New_Occurrence_Of (Temp, Loc),
3161              Attribute_Name => Name_Unrestricted_Access));
3162
3163          Analyze_And_Resolve (N, PtrT);
3164
3165          --  We set the variable as statically allocated, since we don't want
3166          --  it going on the stack of the current procedure!
3167
3168          Set_Is_Statically_Allocated (Temp);
3169          return;
3170       end if;
3171
3172       --  Same if the allocator is an access discriminant for a local object:
3173       --  instead of an allocator we create a local value and constrain the
3174       --  the enclosing object with the corresponding access attribute.
3175
3176       if Is_Static_Coextension (N) then
3177          Rewrite_Coextension (N);
3178          return;
3179       end if;
3180
3181       --  The current allocator creates an object which may contain nested
3182       --  coextensions. Use the current allocator's finalization list to
3183       --  generate finalization call for all nested coextensions.
3184
3185       if Is_Coextension_Root (N) then
3186          Complete_Coextension_Finalization;
3187       end if;
3188
3189       --  Handle case of qualified expression (other than optimization above)
3190
3191       if Nkind (Expression (N)) = N_Qualified_Expression then
3192          Expand_Allocator_Expression (N);
3193          return;
3194       end if;
3195
3196       --  If the allocator is for a type which requires initialization, and
3197       --  there is no initial value (i.e. operand is a subtype indication
3198       --  rather than a qualified expression), then we must generate a call to
3199       --  the initialization routine using an expressions action node:
3200
3201       --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3202
3203       --  Here ptr_T is the pointer type for the allocator, and T is the
3204       --  subtype of the allocator. A special case arises if the designated
3205       --  type of the access type is a task or contains tasks. In this case
3206       --  the call to Init (Temp.all ...) is replaced by code that ensures
3207       --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3208       --  for details). In addition, if the type T is a task T, then the
3209       --  first argument to Init must be converted to the task record type.
3210
3211       declare
3212          T            : constant Entity_Id := Entity (Expression (N));
3213          Init         : Entity_Id;
3214          Arg1         : Node_Id;
3215          Args         : List_Id;
3216          Decls        : List_Id;
3217          Decl         : Node_Id;
3218          Discr        : Elmt_Id;
3219          Flist        : Node_Id;
3220          Temp_Decl    : Node_Id;
3221          Temp_Type    : Entity_Id;
3222          Attach_Level : Uint;
3223
3224       begin
3225          if No_Initialization (N) then
3226             null;
3227
3228          --  Case of no initialization procedure present
3229
3230          elsif not Has_Non_Null_Base_Init_Proc (T) then
3231
3232             --  Case of simple initialization required
3233
3234             if Needs_Simple_Initialization (T) then
3235                Check_Restriction (No_Default_Initialization, N);
3236                Rewrite (Expression (N),
3237                  Make_Qualified_Expression (Loc,
3238                    Subtype_Mark => New_Occurrence_Of (T, Loc),
3239                    Expression   => Get_Simple_Init_Val (T, N)));
3240
3241                Analyze_And_Resolve (Expression (Expression (N)), T);
3242                Analyze_And_Resolve (Expression (N), T);
3243                Set_Paren_Count     (Expression (Expression (N)), 1);
3244                Expand_N_Allocator  (N);
3245
3246             --  No initialization required
3247
3248             else
3249                null;
3250             end if;
3251
3252          --  Case of initialization procedure present, must be called
3253
3254          else
3255             Check_Restriction (No_Default_Initialization, N);
3256
3257             if not Restriction_Active (No_Default_Initialization) then
3258                Init := Base_Init_Proc (T);
3259                Nod  := N;
3260                Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3261
3262                --  Construct argument list for the initialization routine call
3263
3264                Arg1 :=
3265                  Make_Explicit_Dereference (Loc,
3266                    Prefix => New_Reference_To (Temp, Loc));
3267                Set_Assignment_OK (Arg1);
3268                Temp_Type := PtrT;
3269
3270                --  The initialization procedure expects a specific type. if the
3271                --  context is access to class wide, indicate that the object
3272                --  being allocated has the right specific type.
3273
3274                if Is_Class_Wide_Type (Dtyp) then
3275                   Arg1 := Unchecked_Convert_To (T, Arg1);
3276                end if;
3277
3278                --  If designated type is a concurrent type or if it is private
3279                --  type whose definition is a concurrent type, the first
3280                --  argument in the Init routine has to be unchecked conversion
3281                --  to the corresponding record type. If the designated type is
3282                --  a derived type, we also convert the argument to its root
3283                --  type.
3284
3285                if Is_Concurrent_Type (T) then
3286                   Arg1 :=
3287                     Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
3288
3289                elsif Is_Private_Type (T)
3290                  and then Present (Full_View (T))
3291                  and then Is_Concurrent_Type (Full_View (T))
3292                then
3293                   Arg1 :=
3294                     Unchecked_Convert_To
3295                       (Corresponding_Record_Type (Full_View (T)), Arg1);
3296
3297                elsif Etype (First_Formal (Init)) /= Base_Type (T) then
3298                   declare
3299                      Ftyp : constant Entity_Id := Etype (First_Formal (Init));
3300                   begin
3301                      Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
3302                      Set_Etype (Arg1, Ftyp);
3303                   end;
3304                end if;
3305
3306                Args := New_List (Arg1);
3307
3308                --  For the task case, pass the Master_Id of the access type as
3309                --  the value of the _Master parameter, and _Chain as the value
3310                --  of the _Chain parameter (_Chain will be defined as part of
3311                --  the generated code for the allocator).
3312
3313                --  In Ada 2005, the context may be a function that returns an
3314                --  anonymous access type. In that case the Master_Id has been
3315                --  created when expanding the function declaration.
3316
3317                if Has_Task (T) then
3318                   if No (Master_Id (Base_Type (PtrT))) then
3319
3320                      --  If we have a non-library level task with restriction
3321                      --  No_Task_Hierarchy set, then no point in expanding.
3322
3323                      if not Is_Library_Level_Entity (T)
3324                        and then Restriction_Active (No_Task_Hierarchy)
3325                      then
3326                         return;
3327                      end if;
3328
3329                      --  The designated type was an incomplete type, and the
3330                      --  access type did not get expanded. Salvage it now.
3331
3332                      pragma Assert (Present (Parent (Base_Type (PtrT))));
3333                      Expand_N_Full_Type_Declaration
3334                        (Parent (Base_Type (PtrT)));
3335                   end if;
3336
3337                   --  If the context of the allocator is a declaration or an
3338                   --  assignment, we can generate a meaningful image for it,
3339                   --  even though subsequent assignments might remove the
3340                   --  connection between task and entity. We build this image
3341                   --  when the left-hand side is a simple variable, a simple
3342                   --  indexed assignment or a simple selected component.
3343
3344                   if Nkind (Parent (N)) = N_Assignment_Statement then
3345                      declare
3346                         Nam : constant Node_Id := Name (Parent (N));
3347
3348                      begin
3349                         if Is_Entity_Name (Nam) then
3350                            Decls :=
3351                              Build_Task_Image_Decls
3352                                (Loc,
3353                                 New_Occurrence_Of
3354                                   (Entity (Nam), Sloc (Nam)), T);
3355
3356                         elsif Nkind_In
3357                           (Nam, N_Indexed_Component, N_Selected_Component)
3358                           and then Is_Entity_Name (Prefix (Nam))
3359                         then
3360                            Decls :=
3361                              Build_Task_Image_Decls
3362                                (Loc, Nam, Etype (Prefix (Nam)));
3363                         else
3364                            Decls := Build_Task_Image_Decls (Loc, T, T);
3365                         end if;
3366                      end;
3367
3368                   elsif Nkind (Parent (N)) = N_Object_Declaration then
3369                      Decls :=
3370                        Build_Task_Image_Decls
3371                          (Loc, Defining_Identifier (Parent (N)), T);
3372
3373                   else
3374                      Decls := Build_Task_Image_Decls (Loc, T, T);
3375                   end if;
3376
3377                   Append_To (Args,
3378                     New_Reference_To
3379                       (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
3380                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
3381
3382                   Decl := Last (Decls);
3383                   Append_To (Args,
3384                     New_Occurrence_Of (Defining_Identifier (Decl), Loc));
3385
3386                   --  Has_Task is false, Decls not used
3387
3388                else
3389                   Decls := No_List;
3390                end if;
3391
3392                --  Add discriminants if discriminated type
3393
3394                declare
3395                   Dis : Boolean := False;
3396                   Typ : Entity_Id;
3397
3398                begin
3399                   if Has_Discriminants (T) then
3400                      Dis := True;
3401                      Typ := T;
3402
3403                   elsif Is_Private_Type (T)
3404                     and then Present (Full_View (T))
3405                     and then Has_Discriminants (Full_View (T))
3406                   then
3407                      Dis := True;
3408                      Typ := Full_View (T);
3409                   end if;
3410
3411                   if Dis then
3412
3413                      --  If the allocated object will be constrained by the
3414                      --  default values for discriminants, then build a subtype
3415                      --  with those defaults, and change the allocated subtype
3416                      --  to that. Note that this happens in fewer cases in Ada
3417                      --  2005 (AI-363).
3418
3419                      if not Is_Constrained (Typ)
3420                        and then Present (Discriminant_Default_Value
3421                                          (First_Discriminant (Typ)))
3422                        and then (Ada_Version < Ada_05
3423                                   or else
3424                                     not Has_Constrained_Partial_View (Typ))
3425                      then
3426                         Typ := Build_Default_Subtype (Typ, N);
3427                         Set_Expression (N, New_Reference_To (Typ, Loc));
3428                      end if;
3429
3430                      Discr := First_Elmt (Discriminant_Constraint (Typ));
3431                      while Present (Discr) loop
3432                         Nod := Node (Discr);
3433                         Append (New_Copy_Tree (Node (Discr)), Args);
3434
3435                         --  AI-416: when the discriminant constraint is an
3436                         --  anonymous access type make sure an accessibility
3437                         --  check is inserted if necessary (3.10.2(22.q/2))
3438
3439                         if Ada_Version >= Ada_05
3440                           and then
3441                             Ekind (Etype (Nod)) = E_Anonymous_Access_Type
3442                         then
3443                            Apply_Accessibility_Check
3444                              (Nod, Typ, Insert_Node => Nod);
3445                         end if;
3446
3447                         Next_Elmt (Discr);
3448                      end loop;
3449                   end if;
3450                end;
3451
3452                --  We set the allocator as analyzed so that when we analyze the
3453                --  expression actions node, we do not get an unwanted recursive
3454                --  expansion of the allocator expression.
3455
3456                Set_Analyzed (N, True);
3457                Nod := Relocate_Node (N);
3458
3459                --  Here is the transformation:
3460                --    input:  new T
3461                --    output: Temp : constant ptr_T := new T;
3462                --            Init (Temp.all, ...);
3463                --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
3464                --    <CTRL>  Initialize (Finalizable (Temp.all));
3465
3466                --  Here ptr_T is the pointer type for the allocator, and is the
3467                --  subtype of the allocator.
3468
3469                Temp_Decl :=
3470                  Make_Object_Declaration (Loc,
3471                    Defining_Identifier => Temp,
3472                    Constant_Present    => True,
3473                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
3474                    Expression          => Nod);
3475
3476                Set_Assignment_OK (Temp_Decl);
3477                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
3478
3479                --  If the designated type is a task type or contains tasks,
3480                --  create block to activate created tasks, and insert
3481                --  declaration for Task_Image variable ahead of call.
3482
3483                if Has_Task (T) then
3484                   declare
3485                      L   : constant List_Id := New_List;
3486                      Blk : Node_Id;
3487                   begin
3488                      Build_Task_Allocate_Block (L, Nod, Args);
3489                      Blk := Last (L);
3490                      Insert_List_Before (First (Declarations (Blk)), Decls);
3491                      Insert_Actions (N, L);
3492                   end;
3493
3494                else
3495                   Insert_Action (N,
3496                     Make_Procedure_Call_Statement (Loc,
3497                       Name                   => New_Reference_To (Init, Loc),
3498                       Parameter_Associations => Args));
3499                end if;
3500
3501                if Controlled_Type (T) then
3502
3503                   --  Postpone the generation of a finalization call for the
3504                   --  current allocator if it acts as a coextension.
3505
3506                   if Is_Dynamic_Coextension (N) then
3507                      if No (Coextensions (N)) then
3508                         Set_Coextensions (N, New_Elmt_List);
3509                      end if;
3510
3511                      Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
3512
3513                   else
3514                      Flist :=
3515                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
3516
3517                      --  Anonymous access types created for access parameters
3518                      --  are attached to an explicitly constructed controller,
3519                      --  which ensures that they can be finalized properly,
3520                      --  even if their deallocation might not happen. The list
3521                      --  associated with the controller is doubly-linked. For
3522                      --  other anonymous access types, the object may end up
3523                      --  on the global final list which is singly-linked.
3524                      --  Work needed for access discriminants in Ada 2005 ???
3525
3526                      if Ekind (PtrT) = E_Anonymous_Access_Type
3527                        and then
3528                          Nkind (Associated_Node_For_Itype (PtrT))
3529                      not in N_Subprogram_Specification
3530                      then
3531                         Attach_Level := Uint_1;
3532                      else
3533                         Attach_Level := Uint_2;
3534                      end if;
3535
3536                      Insert_Actions (N,
3537                        Make_Init_Call (
3538                          Ref          => New_Copy_Tree (Arg1),
3539                          Typ          => T,
3540                          Flist_Ref    => Flist,
3541                          With_Attach  => Make_Integer_Literal (Loc,
3542                                            Intval => Attach_Level)));
3543                   end if;
3544                end if;
3545
3546                Rewrite (N, New_Reference_To (Temp, Loc));
3547                Analyze_And_Resolve (N, PtrT);
3548             end if;
3549          end if;
3550       end;
3551
3552       --  Ada 2005 (AI-251): If the allocator is for a class-wide interface
3553       --  object that has been rewritten as a reference, we displace "this"
3554       --  to reference properly its secondary dispatch table.
3555
3556       if Nkind (N) = N_Identifier
3557         and then Is_Interface (Dtyp)
3558       then
3559          Displace_Allocator_Pointer (N);
3560       end if;
3561
3562    exception
3563       when RE_Not_Available =>
3564          return;
3565    end Expand_N_Allocator;
3566
3567    -----------------------
3568    -- Expand_N_And_Then --
3569    -----------------------
3570
3571    --  Expand into conditional expression if Actions present, and also deal
3572    --  with optimizing case of arguments being True or False.
3573
3574    procedure Expand_N_And_Then (N : Node_Id) is
3575       Loc     : constant Source_Ptr := Sloc (N);
3576       Typ     : constant Entity_Id  := Etype (N);
3577       Left    : constant Node_Id    := Left_Opnd (N);
3578       Right   : constant Node_Id    := Right_Opnd (N);
3579       Actlist : List_Id;
3580
3581    begin
3582       --  Deal with non-standard booleans
3583
3584       if Is_Boolean_Type (Typ) then
3585          Adjust_Condition (Left);
3586          Adjust_Condition (Right);
3587          Set_Etype (N, Standard_Boolean);
3588       end if;
3589
3590       --  Check for cases of left argument is True or False
3591
3592       if Nkind (Left) = N_Identifier then
3593
3594          --  If left argument is True, change (True and then Right) to Right.
3595          --  Any actions associated with Right will be executed unconditionally
3596          --  and can thus be inserted into the tree unconditionally.
3597
3598          if Entity (Left) = Standard_True then
3599             if Present (Actions (N)) then
3600                Insert_Actions (N, Actions (N));
3601             end if;
3602
3603             Rewrite (N, Right);
3604             Adjust_Result_Type (N, Typ);
3605             return;
3606
3607          --  If left argument is False, change (False and then Right) to False.
3608          --  In this case we can forget the actions associated with Right,
3609          --  since they will never be executed.
3610
3611          elsif Entity (Left) = Standard_False then
3612             Kill_Dead_Code (Right);
3613             Kill_Dead_Code (Actions (N));
3614             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3615             Adjust_Result_Type (N, Typ);
3616             return;
3617          end if;
3618       end if;
3619
3620       --  If Actions are present, we expand
3621
3622       --     left and then right
3623
3624       --  into
3625
3626       --     if left then right else false end
3627
3628       --  with the actions becoming the Then_Actions of the conditional
3629       --  expression. This conditional expression is then further expanded
3630       --  (and will eventually disappear)
3631
3632       if Present (Actions (N)) then
3633          Actlist := Actions (N);
3634          Rewrite (N,
3635             Make_Conditional_Expression (Loc,
3636               Expressions => New_List (
3637                 Left,
3638                 Right,
3639                 New_Occurrence_Of (Standard_False, Loc))));
3640
3641          Set_Then_Actions (N, Actlist);
3642          Analyze_And_Resolve (N, Standard_Boolean);
3643          Adjust_Result_Type (N, Typ);
3644          return;
3645       end if;
3646
3647       --  No actions present, check for cases of right argument True/False
3648
3649       if Nkind (Right) = N_Identifier then
3650
3651          --  Change (Left and then True) to Left. Note that we know there are
3652          --  no actions associated with the True operand, since we just checked
3653          --  for this case above.
3654
3655          if Entity (Right) = Standard_True then
3656             Rewrite (N, Left);
3657
3658          --  Change (Left and then False) to False, making sure to preserve any
3659          --  side effects associated with the Left operand.
3660
3661          elsif Entity (Right) = Standard_False then
3662             Remove_Side_Effects (Left);
3663             Rewrite
3664               (N, New_Occurrence_Of (Standard_False, Loc));
3665          end if;
3666       end if;
3667
3668       Adjust_Result_Type (N, Typ);
3669    end Expand_N_And_Then;
3670
3671    -------------------------------------
3672    -- Expand_N_Conditional_Expression --
3673    -------------------------------------
3674
3675    --  Expand into expression actions if then/else actions present
3676
3677    procedure Expand_N_Conditional_Expression (N : Node_Id) is
3678       Loc    : constant Source_Ptr := Sloc (N);
3679       Cond   : constant Node_Id    := First (Expressions (N));
3680       Thenx  : constant Node_Id    := Next (Cond);
3681       Elsex  : constant Node_Id    := Next (Thenx);
3682       Typ    : constant Entity_Id  := Etype (N);
3683       Cnn    : Entity_Id;
3684       New_If : Node_Id;
3685
3686    begin
3687       --  If either then or else actions are present, then given:
3688
3689       --     if cond then then-expr else else-expr end
3690
3691       --  we insert the following sequence of actions (using Insert_Actions):
3692
3693       --      Cnn : typ;
3694       --      if cond then
3695       --         <<then actions>>
3696       --         Cnn := then-expr;
3697       --      else
3698       --         <<else actions>>
3699       --         Cnn := else-expr
3700       --      end if;
3701
3702       --  and replace the conditional expression by a reference to Cnn
3703
3704       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
3705          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
3706
3707          New_If :=
3708            Make_Implicit_If_Statement (N,
3709              Condition => Relocate_Node (Cond),
3710
3711              Then_Statements => New_List (
3712                Make_Assignment_Statement (Sloc (Thenx),
3713                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
3714                  Expression => Relocate_Node (Thenx))),
3715
3716              Else_Statements => New_List (
3717                Make_Assignment_Statement (Sloc (Elsex),
3718                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
3719                  Expression => Relocate_Node (Elsex))));
3720
3721          Set_Assignment_OK (Name (First (Then_Statements (New_If))));
3722          Set_Assignment_OK (Name (First (Else_Statements (New_If))));
3723
3724          if Present (Then_Actions (N)) then
3725             Insert_List_Before
3726               (First (Then_Statements (New_If)), Then_Actions (N));
3727          end if;
3728
3729          if Present (Else_Actions (N)) then
3730             Insert_List_Before
3731               (First (Else_Statements (New_If)), Else_Actions (N));
3732          end if;
3733
3734          Rewrite (N, New_Occurrence_Of (Cnn, Loc));
3735
3736          Insert_Action (N,
3737            Make_Object_Declaration (Loc,
3738              Defining_Identifier => Cnn,
3739              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
3740
3741          Insert_Action (N, New_If);
3742          Analyze_And_Resolve (N, Typ);
3743       end if;
3744    end Expand_N_Conditional_Expression;
3745
3746    -----------------------------------
3747    -- Expand_N_Explicit_Dereference --
3748    -----------------------------------
3749
3750    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
3751    begin
3752       --  Insert explicit dereference call for the checked storage pool case
3753
3754       Insert_Dereference_Action (Prefix (N));
3755    end Expand_N_Explicit_Dereference;
3756
3757    -----------------
3758    -- Expand_N_In --
3759    -----------------
3760
3761    procedure Expand_N_In (N : Node_Id) is
3762       Loc    : constant Source_Ptr := Sloc (N);
3763       Rtyp   : constant Entity_Id  := Etype (N);
3764       Lop    : constant Node_Id    := Left_Opnd (N);
3765       Rop    : constant Node_Id    := Right_Opnd (N);
3766       Static : constant Boolean    := Is_OK_Static_Expression (N);
3767
3768       procedure Substitute_Valid_Check;
3769       --  Replaces node N by Lop'Valid. This is done when we have an explicit
3770       --  test for the left operand being in range of its subtype.
3771
3772       ----------------------------
3773       -- Substitute_Valid_Check --
3774       ----------------------------
3775
3776       procedure Substitute_Valid_Check is
3777       begin
3778          Rewrite (N,
3779            Make_Attribute_Reference (Loc,
3780              Prefix         => Relocate_Node (Lop),
3781              Attribute_Name => Name_Valid));
3782
3783          Analyze_And_Resolve (N, Rtyp);
3784
3785          Error_Msg_N ("?explicit membership test may be optimized away", N);
3786          Error_Msg_N ("\?use ''Valid attribute instead", N);
3787          return;
3788       end Substitute_Valid_Check;
3789
3790    --  Start of processing for Expand_N_In
3791
3792    begin
3793       --  Check case of explicit test for an expression in range of its
3794       --  subtype. This is suspicious usage and we replace it with a 'Valid
3795       --  test and give a warning.
3796
3797       if Is_Scalar_Type (Etype (Lop))
3798         and then Nkind (Rop) in N_Has_Entity
3799         and then Etype (Lop) = Entity (Rop)
3800         and then Comes_From_Source (N)
3801         and then VM_Target = No_VM
3802       then
3803          Substitute_Valid_Check;
3804          return;
3805       end if;
3806
3807       --  Do validity check on operands
3808
3809       if Validity_Checks_On and Validity_Check_Operands then
3810          Ensure_Valid (Left_Opnd (N));
3811          Validity_Check_Range (Right_Opnd (N));
3812       end if;
3813
3814       --  Case of explicit range
3815
3816       if Nkind (Rop) = N_Range then
3817          declare
3818             Lo : constant Node_Id := Low_Bound (Rop);
3819             Hi : constant Node_Id := High_Bound (Rop);
3820
3821             Ltyp : constant Entity_Id := Etype (Lop);
3822
3823             Lo_Orig : constant Node_Id := Original_Node (Lo);
3824             Hi_Orig : constant Node_Id := Original_Node (Hi);
3825
3826             Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
3827             Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
3828
3829             Warn1 : constant Boolean :=
3830                       Constant_Condition_Warnings
3831                         and then Comes_From_Source (N);
3832             --  This must be true for any of the optimization warnings, we
3833             --  clearly want to give them only for source with the flag on.
3834
3835             Warn2 : constant Boolean :=
3836                       Warn1
3837                         and then Nkind (Original_Node (Rop)) = N_Range
3838                         and then Is_Integer_Type (Etype (Lo));
3839             --  For the case where only one bound warning is elided, we also
3840             --  insist on an explicit range and an integer type. The reason is
3841             --  that the use of enumeration ranges including an end point is
3842             --  common, as is the use of a subtype name, one of whose bounds
3843             --  is the same as the type of the expression.
3844
3845          begin
3846             --  If test is explicit x'first .. x'last, replace by valid check
3847
3848             if Is_Scalar_Type (Ltyp)
3849               and then Nkind (Lo_Orig) = N_Attribute_Reference
3850               and then Attribute_Name (Lo_Orig) = Name_First
3851               and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
3852               and then Entity (Prefix (Lo_Orig)) = Ltyp
3853               and then Nkind (Hi_Orig) = N_Attribute_Reference
3854               and then Attribute_Name (Hi_Orig) = Name_Last
3855               and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
3856               and then Entity (Prefix (Hi_Orig)) = Ltyp
3857               and then Comes_From_Source (N)
3858               and then VM_Target = No_VM
3859             then
3860                Substitute_Valid_Check;
3861                return;
3862             end if;
3863
3864             --  If bounds of type are known at compile time, and the end points
3865             --  are known at compile time and identical, this is another case
3866             --  for substituting a valid test. We only do this for discrete
3867             --  types, since it won't arise in practice for float types.
3868
3869             if Comes_From_Source (N)
3870               and then Is_Discrete_Type (Ltyp)
3871               and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
3872               and then Compile_Time_Known_Value (Type_Low_Bound  (Ltyp))
3873               and then Compile_Time_Known_Value (Lo)
3874               and then Compile_Time_Known_Value (Hi)
3875               and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
3876               and then Expr_Value (Type_Low_Bound  (Ltyp)) = Expr_Value (Lo)
3877             then
3878                Substitute_Valid_Check;
3879                return;
3880             end if;
3881
3882             --  If we have an explicit range, do a bit of optimization based
3883             --  on range analysis (we may be able to kill one or both checks).
3884
3885             --  If either check is known to fail, replace result by False since
3886             --  the other check does not matter. Preserve the static flag for
3887             --  legality checks, because we are constant-folding beyond RM 4.9.
3888
3889             if Lcheck = LT or else Ucheck = GT then
3890                if Warn1 then
3891                   Error_Msg_N ("?range test optimized away", N);
3892                   Error_Msg_N ("\?value is known to be out of range", N);
3893                end if;
3894
3895                Rewrite (N,
3896                  New_Reference_To (Standard_False, Loc));
3897                Analyze_And_Resolve (N, Rtyp);
3898                Set_Is_Static_Expression (N, Static);
3899
3900                return;
3901
3902             --  If both checks are known to succeed, replace result by True,
3903             --  since we know we are in range.
3904
3905             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
3906                if Warn1 then
3907                   Error_Msg_N ("?range test optimized away", N);
3908                   Error_Msg_N ("\?value is known to be in range", N);
3909                end if;
3910
3911                Rewrite (N,
3912                  New_Reference_To (Standard_True, Loc));
3913                Analyze_And_Resolve (N, Rtyp);
3914                Set_Is_Static_Expression (N, Static);
3915
3916                return;
3917
3918             --  If lower bound check succeeds and upper bound check is not
3919             --  known to succeed or fail, then replace the range check with
3920             --  a comparison against the upper bound.
3921
3922             elsif Lcheck in Compare_GE then
3923                if Warn2 then
3924                   Error_Msg_N ("?lower bound test optimized away", Lo);
3925                   Error_Msg_N ("\?value is known to be in range", Lo);
3926                end if;
3927
3928                Rewrite (N,
3929                  Make_Op_Le (Loc,
3930                    Left_Opnd  => Lop,
3931                    Right_Opnd => High_Bound (Rop)));
3932                Analyze_And_Resolve (N, Rtyp);
3933
3934                return;
3935
3936             --  If upper bound check succeeds and lower bound check is not
3937             --  known to succeed or fail, then replace the range check with
3938             --  a comparison against the lower bound.
3939
3940             elsif Ucheck in Compare_LE then
3941                if Warn2 then
3942                   Error_Msg_N ("?upper bound test optimized away", Hi);
3943                   Error_Msg_N ("\?value is known to be in range", Hi);
3944                end if;
3945
3946                Rewrite (N,
3947                  Make_Op_Ge (Loc,
3948                    Left_Opnd  => Lop,
3949                    Right_Opnd => Low_Bound (Rop)));
3950                Analyze_And_Resolve (N, Rtyp);
3951
3952                return;
3953             end if;
3954          end;
3955
3956          --  For all other cases of an explicit range, nothing to be done
3957
3958          return;
3959
3960       --  Here right operand is a subtype mark
3961
3962       else
3963          declare
3964             Typ    : Entity_Id        := Etype (Rop);
3965             Is_Acc : constant Boolean := Is_Access_Type (Typ);
3966             Obj    : Node_Id          := Lop;
3967             Cond   : Node_Id          := Empty;
3968
3969          begin
3970             Remove_Side_Effects (Obj);
3971
3972             --  For tagged type, do tagged membership operation
3973
3974             if Is_Tagged_Type (Typ) then
3975
3976                --  No expansion will be performed when VM_Target, as the VM
3977                --  back-ends will handle the membership tests directly (tags
3978                --  are not explicitly represented in Java objects, so the
3979                --  normal tagged membership expansion is not what we want).
3980
3981                if VM_Target = No_VM then
3982                   Rewrite (N, Tagged_Membership (N));
3983                   Analyze_And_Resolve (N, Rtyp);
3984                end if;
3985
3986                return;
3987
3988             --  If type is scalar type, rewrite as x in t'first .. t'last.
3989             --  This reason we do this is that the bounds may have the wrong
3990             --  type if they come from the original type definition.
3991
3992             elsif Is_Scalar_Type (Typ) then
3993                Rewrite (Rop,
3994                  Make_Range (Loc,
3995                    Low_Bound =>
3996                      Make_Attribute_Reference (Loc,
3997                        Attribute_Name => Name_First,
3998                        Prefix => New_Reference_To (Typ, Loc)),
3999
4000                    High_Bound =>
4001                      Make_Attribute_Reference (Loc,
4002                        Attribute_Name => Name_Last,
4003                        Prefix => New_Reference_To (Typ, Loc))));
4004                Analyze_And_Resolve (N, Rtyp);
4005                return;
4006
4007             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
4008             --  a membership test if the subtype mark denotes a constrained
4009             --  Unchecked_Union subtype and the expression lacks inferable
4010             --  discriminants.
4011
4012             elsif Is_Unchecked_Union (Base_Type (Typ))
4013               and then Is_Constrained (Typ)
4014               and then not Has_Inferable_Discriminants (Lop)
4015             then
4016                Insert_Action (N,
4017                  Make_Raise_Program_Error (Loc,
4018                    Reason => PE_Unchecked_Union_Restriction));
4019
4020                --  Prevent Gigi from generating incorrect code by rewriting
4021                --  the test as a standard False.
4022
4023                Rewrite (N,
4024                  New_Occurrence_Of (Standard_False, Loc));
4025
4026                return;
4027             end if;
4028
4029             --  Here we have a non-scalar type
4030
4031             if Is_Acc then
4032                Typ := Designated_Type (Typ);
4033             end if;
4034
4035             if not Is_Constrained (Typ) then
4036                Rewrite (N,
4037                  New_Reference_To (Standard_True, Loc));
4038                Analyze_And_Resolve (N, Rtyp);
4039
4040             --  For the constrained array case, we have to check the subscripts
4041             --  for an exact match if the lengths are non-zero (the lengths
4042             --  must match in any case).
4043
4044             elsif Is_Array_Type (Typ) then
4045
4046                Check_Subscripts : declare
4047                   function Construct_Attribute_Reference
4048                     (E   : Node_Id;
4049                      Nam : Name_Id;
4050                      Dim : Nat) return Node_Id;
4051                   --  Build attribute reference E'Nam(Dim)
4052
4053                   -----------------------------------
4054                   -- Construct_Attribute_Reference --
4055                   -----------------------------------
4056
4057                   function Construct_Attribute_Reference
4058                     (E   : Node_Id;
4059                      Nam : Name_Id;
4060                      Dim : Nat) return Node_Id
4061                   is
4062                   begin
4063                      return
4064                        Make_Attribute_Reference (Loc,
4065                          Prefix => E,
4066                          Attribute_Name => Nam,
4067                          Expressions => New_List (
4068                            Make_Integer_Literal (Loc, Dim)));
4069                   end Construct_Attribute_Reference;
4070
4071                --  Start processing for Check_Subscripts
4072
4073                begin
4074                   for J in 1 .. Number_Dimensions (Typ) loop
4075                      Evolve_And_Then (Cond,
4076                        Make_Op_Eq (Loc,
4077                          Left_Opnd  =>
4078                            Construct_Attribute_Reference
4079                              (Duplicate_Subexpr_No_Checks (Obj),
4080                               Name_First, J),
4081                          Right_Opnd =>
4082                            Construct_Attribute_Reference
4083                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
4084
4085                      Evolve_And_Then (Cond,
4086                        Make_Op_Eq (Loc,
4087                          Left_Opnd  =>
4088                            Construct_Attribute_Reference
4089                              (Duplicate_Subexpr_No_Checks (Obj),
4090                               Name_Last, J),
4091                          Right_Opnd =>
4092                            Construct_Attribute_Reference
4093                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
4094                   end loop;
4095
4096                   if Is_Acc then
4097                      Cond :=
4098                        Make_Or_Else (Loc,
4099                          Left_Opnd =>
4100                            Make_Op_Eq (Loc,
4101                              Left_Opnd  => Obj,
4102                              Right_Opnd => Make_Null (Loc)),
4103                          Right_Opnd => Cond);
4104                   end if;
4105
4106                   Rewrite (N, Cond);
4107                   Analyze_And_Resolve (N, Rtyp);
4108                end Check_Subscripts;
4109
4110             --  These are the cases where constraint checks may be required,
4111             --  e.g. records with possible discriminants
4112
4113             else
4114                --  Expand the test into a series of discriminant comparisons.
4115                --  The expression that is built is the negation of the one that
4116                --  is used for checking discriminant constraints.
4117
4118                Obj := Relocate_Node (Left_Opnd (N));
4119
4120                if Has_Discriminants (Typ) then
4121                   Cond := Make_Op_Not (Loc,
4122                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
4123
4124                   if Is_Acc then
4125                      Cond := Make_Or_Else (Loc,
4126                        Left_Opnd =>
4127                          Make_Op_Eq (Loc,
4128                            Left_Opnd  => Obj,
4129                            Right_Opnd => Make_Null (Loc)),
4130                        Right_Opnd => Cond);
4131                   end if;
4132
4133                else
4134                   Cond := New_Occurrence_Of (Standard_True, Loc);
4135                end if;
4136
4137                Rewrite (N, Cond);
4138                Analyze_And_Resolve (N, Rtyp);
4139             end if;
4140          end;
4141       end if;
4142    end Expand_N_In;
4143
4144    --------------------------------
4145    -- Expand_N_Indexed_Component --
4146    --------------------------------
4147
4148    procedure Expand_N_Indexed_Component (N : Node_Id) is
4149       Loc : constant Source_Ptr := Sloc (N);
4150       Typ : constant Entity_Id  := Etype (N);
4151       P   : constant Node_Id    := Prefix (N);
4152       T   : constant Entity_Id  := Etype (P);
4153
4154    begin
4155       --  A special optimization, if we have an indexed component that is
4156       --  selecting from a slice, then we can eliminate the slice, since, for
4157       --  example, x (i .. j)(k) is identical to x(k). The only difference is
4158       --  the range check required by the slice. The range check for the slice
4159       --  itself has already been generated. The range check for the
4160       --  subscripting operation is ensured by converting the subject to
4161       --  the subtype of the slice.
4162
4163       --  This optimization not only generates better code, avoiding slice
4164       --  messing especially in the packed case, but more importantly bypasses
4165       --  some problems in handling this peculiar case, for example, the issue
4166       --  of dealing specially with object renamings.
4167
4168       if Nkind (P) = N_Slice then
4169          Rewrite (N,
4170            Make_Indexed_Component (Loc,
4171              Prefix => Prefix (P),
4172              Expressions => New_List (
4173                Convert_To
4174                  (Etype (First_Index (Etype (P))),
4175                   First (Expressions (N))))));
4176          Analyze_And_Resolve (N, Typ);
4177          return;
4178       end if;
4179
4180       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4181       --  function, then additional actuals must be passed.
4182
4183       if Ada_Version >= Ada_05
4184         and then Is_Build_In_Place_Function_Call (P)
4185       then
4186          Make_Build_In_Place_Call_In_Anonymous_Context (P);
4187       end if;
4188
4189       --  If the prefix is an access type, then we unconditionally rewrite if
4190       --  as an explicit deference. This simplifies processing for several
4191       --  cases, including packed array cases and certain cases in which checks
4192       --  must be generated. We used to try to do this only when it was
4193       --  necessary, but it cleans up the code to do it all the time.
4194
4195       if Is_Access_Type (T) then
4196          Insert_Explicit_Dereference (P);
4197          Analyze_And_Resolve (P, Designated_Type (T));
4198       end if;
4199
4200       --  Generate index and validity checks
4201
4202       Generate_Index_Checks (N);
4203
4204       if Validity_Checks_On and then Validity_Check_Subscripts then
4205          Apply_Subscript_Validity_Checks (N);
4206       end if;
4207
4208       --  All done for the non-packed case
4209
4210       if not Is_Packed (Etype (Prefix (N))) then
4211          return;
4212       end if;
4213
4214       --  For packed arrays that are not bit-packed (i.e. the case of an array
4215       --  with one or more index types with a non-contiguous enumeration type),
4216       --  we can always use the normal packed element get circuit.
4217
4218       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
4219          Expand_Packed_Element_Reference (N);
4220          return;
4221       end if;
4222
4223       --  For a reference to a component of a bit packed array, we have to
4224       --  convert it to a reference to the corresponding Packed_Array_Type.
4225       --  We only want to do this for simple references, and not for:
4226
4227       --    Left side of assignment, or prefix of left side of assignment, or
4228       --    prefix of the prefix, to handle packed arrays of packed arrays,
4229       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4230
4231       --    Renaming objects in renaming associations
4232       --      This case is handled when a use of the renamed variable occurs
4233
4234       --    Actual parameters for a procedure call
4235       --      This case is handled in Exp_Ch6.Expand_Actuals
4236
4237       --    The second expression in a 'Read attribute reference
4238
4239       --    The prefix of an address or size attribute reference
4240
4241       --  The following circuit detects these exceptions
4242
4243       declare
4244          Child : Node_Id := N;
4245          Parnt : Node_Id := Parent (N);
4246
4247       begin
4248          loop
4249             if Nkind (Parnt) = N_Unchecked_Expression then
4250                null;
4251
4252             elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
4253                                    N_Procedure_Call_Statement)
4254               or else (Nkind (Parnt) = N_Parameter_Association
4255                         and then
4256                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
4257             then
4258                return;
4259
4260             elsif Nkind (Parnt) = N_Attribute_Reference
4261               and then (Attribute_Name (Parnt) = Name_Address
4262                          or else
4263                         Attribute_Name (Parnt) = Name_Size)
4264               and then Prefix (Parnt) = Child
4265             then
4266                return;
4267
4268             elsif Nkind (Parnt) = N_Assignment_Statement
4269               and then Name (Parnt) = Child
4270             then
4271                return;
4272
4273             --  If the expression is an index of an indexed component, it must
4274             --  be expanded regardless of context.
4275
4276             elsif Nkind (Parnt) = N_Indexed_Component
4277               and then Child /= Prefix (Parnt)
4278             then
4279                Expand_Packed_Element_Reference (N);
4280                return;
4281
4282             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
4283               and then Name (Parent (Parnt)) = Parnt
4284             then
4285                return;
4286
4287             elsif Nkind (Parnt) = N_Attribute_Reference
4288               and then Attribute_Name (Parnt) = Name_Read
4289               and then Next (First (Expressions (Parnt))) = Child
4290             then
4291                return;
4292
4293             elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
4294                and then Prefix (Parnt) = Child
4295             then
4296                null;
4297
4298             else
4299                Expand_Packed_Element_Reference (N);
4300                return;
4301             end if;
4302
4303             --  Keep looking up tree for unchecked expression, or if we are the
4304             --  prefix of a possible assignment left side.
4305
4306             Child := Parnt;
4307             Parnt := Parent (Child);
4308          end loop;
4309       end;
4310    end Expand_N_Indexed_Component;
4311
4312    ---------------------
4313    -- Expand_N_Not_In --
4314    ---------------------
4315
4316    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
4317    --  can be done. This avoids needing to duplicate this expansion code.
4318
4319    procedure Expand_N_Not_In (N : Node_Id) is
4320       Loc : constant Source_Ptr := Sloc (N);
4321       Typ : constant Entity_Id  := Etype (N);
4322       Cfs : constant Boolean    := Comes_From_Source (N);
4323
4324    begin
4325       Rewrite (N,
4326         Make_Op_Not (Loc,
4327           Right_Opnd =>
4328             Make_In (Loc,
4329               Left_Opnd  => Left_Opnd (N),
4330               Right_Opnd => Right_Opnd (N))));
4331
4332       --  We want this to appear as coming from source if original does (see
4333       --  transformations in Expand_N_In).
4334
4335       Set_Comes_From_Source (N, Cfs);
4336       Set_Comes_From_Source (Right_Opnd (N), Cfs);
4337
4338       --  Now analyze transformed node
4339
4340       Analyze_And_Resolve (N, Typ);
4341    end Expand_N_Not_In;
4342
4343    -------------------
4344    -- Expand_N_Null --
4345    -------------------
4346
4347    --  The only replacement required is for the case of a null of type that is
4348    --  an access to protected subprogram. We represent such access values as a
4349    --  record, and so we must replace the occurrence of null by the equivalent
4350    --  record (with a null address and a null pointer in it), so that the
4351    --  backend creates the proper value.
4352
4353    procedure Expand_N_Null (N : Node_Id) is
4354       Loc : constant Source_Ptr := Sloc (N);
4355       Typ : constant Entity_Id  := Etype (N);
4356       Agg : Node_Id;
4357
4358    begin
4359       if Is_Access_Protected_Subprogram_Type (Typ) then
4360          Agg :=
4361            Make_Aggregate (Loc,
4362              Expressions => New_List (
4363                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
4364                Make_Null (Loc)));
4365
4366          Rewrite (N, Agg);
4367          Analyze_And_Resolve (N, Equivalent_Type (Typ));
4368
4369          --  For subsequent semantic analysis, the node must retain its type.
4370          --  Gigi in any case replaces this type by the corresponding record
4371          --  type before processing the node.
4372
4373          Set_Etype (N, Typ);
4374       end if;
4375
4376    exception
4377       when RE_Not_Available =>
4378          return;
4379    end Expand_N_Null;
4380
4381    ---------------------
4382    -- Expand_N_Op_Abs --
4383    ---------------------
4384
4385    procedure Expand_N_Op_Abs (N : Node_Id) is
4386       Loc  : constant Source_Ptr := Sloc (N);
4387       Expr : constant Node_Id := Right_Opnd (N);
4388
4389    begin
4390       Unary_Op_Validity_Checks (N);
4391
4392       --  Deal with software overflow checking
4393
4394       if not Backend_Overflow_Checks_On_Target
4395          and then Is_Signed_Integer_Type (Etype (N))
4396          and then Do_Overflow_Check (N)
4397       then
4398          --  The only case to worry about is when the argument is equal to the
4399          --  largest negative number, so what we do is to insert the check:
4400
4401          --     [constraint_error when Expr = typ'Base'First]
4402
4403          --  with the usual Duplicate_Subexpr use coding for expr
4404
4405          Insert_Action (N,
4406            Make_Raise_Constraint_Error (Loc,
4407              Condition =>
4408                Make_Op_Eq (Loc,
4409                  Left_Opnd  => Duplicate_Subexpr (Expr),
4410                  Right_Opnd =>
4411                    Make_Attribute_Reference (Loc,
4412                      Prefix =>
4413                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
4414                      Attribute_Name => Name_First)),
4415              Reason => CE_Overflow_Check_Failed));
4416       end if;
4417
4418       --  Vax floating-point types case
4419
4420       if Vax_Float (Etype (N)) then
4421          Expand_Vax_Arith (N);
4422       end if;
4423    end Expand_N_Op_Abs;
4424
4425    ---------------------
4426    -- Expand_N_Op_Add --
4427    ---------------------
4428
4429    procedure Expand_N_Op_Add (N : Node_Id) is
4430       Typ : constant Entity_Id := Etype (N);
4431
4432    begin
4433       Binary_Op_Validity_Checks (N);
4434
4435       --  N + 0 = 0 + N = N for integer types
4436
4437       if Is_Integer_Type (Typ) then
4438          if Compile_Time_Known_Value (Right_Opnd (N))
4439            and then Expr_Value (Right_Opnd (N)) = Uint_0
4440          then
4441             Rewrite (N, Left_Opnd (N));
4442             return;
4443
4444          elsif Compile_Time_Known_Value (Left_Opnd (N))
4445            and then Expr_Value (Left_Opnd (N)) = Uint_0
4446          then
4447             Rewrite (N, Right_Opnd (N));
4448             return;
4449          end if;
4450       end if;
4451
4452       --  Arithmetic overflow checks for signed integer/fixed point types
4453
4454       if Is_Signed_Integer_Type (Typ)
4455         or else Is_Fixed_Point_Type (Typ)
4456       then
4457          Apply_Arithmetic_Overflow_Check (N);
4458          return;
4459
4460       --  Vax floating-point types case
4461
4462       elsif Vax_Float (Typ) then
4463          Expand_Vax_Arith (N);
4464       end if;
4465    end Expand_N_Op_Add;
4466
4467    ---------------------
4468    -- Expand_N_Op_And --
4469    ---------------------
4470
4471    procedure Expand_N_Op_And (N : Node_Id) is
4472       Typ : constant Entity_Id := Etype (N);
4473
4474    begin
4475       Binary_Op_Validity_Checks (N);
4476
4477       if Is_Array_Type (Etype (N)) then
4478          Expand_Boolean_Operator (N);
4479
4480       elsif Is_Boolean_Type (Etype (N)) then
4481          Adjust_Condition (Left_Opnd (N));
4482          Adjust_Condition (Right_Opnd (N));
4483          Set_Etype (N, Standard_Boolean);
4484          Adjust_Result_Type (N, Typ);
4485       end if;
4486    end Expand_N_Op_And;
4487
4488    ------------------------
4489    -- Expand_N_Op_Concat --
4490    ------------------------
4491
4492    Max_Available_String_Operands : Int := -1;
4493    --  This is initialized the first time this routine is called. It records
4494    --  a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4495    --  available in the run-time:
4496    --
4497    --    0  None available
4498    --    2  RE_Str_Concat available, RE_Str_Concat_3 not available
4499    --    3  RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4500    --    4  RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4501    --    5  All routines including RE_Str_Concat_5 available
4502
4503    Char_Concat_Available : Boolean;
4504    --  Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4505    --  all three are available, False if any one of these is unavailable.
4506
4507    procedure Expand_N_Op_Concat (N : Node_Id) is
4508       Opnds : List_Id;
4509       --  List of operands to be concatenated
4510
4511       Opnd  : Node_Id;
4512       --  Single operand for concatenation
4513
4514       Cnode : Node_Id;
4515       --  Node which is to be replaced by the result of concatenating the nodes
4516       --  in the list Opnds.
4517
4518       Atyp : Entity_Id;
4519       --  Array type of concatenation result type
4520
4521       Ctyp : Entity_Id;
4522       --  Component type of concatenation represented by Cnode
4523
4524    begin
4525       --  Initialize global variables showing run-time status
4526
4527       if Max_Available_String_Operands < 1 then
4528
4529          --  See what routines are available and set max operand count
4530          --  according to the highest count available in the run-time.
4531
4532          if not RTE_Available (RE_Str_Concat) then
4533             Max_Available_String_Operands := 0;
4534
4535          elsif not RTE_Available (RE_Str_Concat_3) then
4536             Max_Available_String_Operands := 2;
4537
4538          elsif not RTE_Available (RE_Str_Concat_4) then
4539             Max_Available_String_Operands := 3;
4540
4541          elsif not RTE_Available (RE_Str_Concat_5) then
4542             Max_Available_String_Operands := 4;
4543
4544          else
4545             Max_Available_String_Operands := 5;
4546          end if;
4547
4548          Char_Concat_Available :=
4549            RTE_Available (RE_Str_Concat_CC)
4550              and then
4551            RTE_Available (RE_Str_Concat_CS)
4552              and then
4553            RTE_Available (RE_Str_Concat_SC);
4554       end if;
4555
4556       --  Ensure validity of both operands
4557
4558       Binary_Op_Validity_Checks (N);
4559
4560       --  If we are the left operand of a concatenation higher up the tree,
4561       --  then do nothing for now, since we want to deal with a series of
4562       --  concatenations as a unit.
4563
4564       if Nkind (Parent (N)) = N_Op_Concat
4565         and then N = Left_Opnd (Parent (N))
4566       then
4567          return;
4568       end if;
4569
4570       --  We get here with a concatenation whose left operand may be a
4571       --  concatenation itself with a consistent type. We need to process
4572       --  these concatenation operands from left to right, which means
4573       --  from the deepest node in the tree to the highest node.
4574
4575       Cnode := N;
4576       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
4577          Cnode := Left_Opnd (Cnode);
4578       end loop;
4579
4580       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
4581       --  nodes above, so now we process bottom up, doing the operations. We
4582       --  gather a string that is as long as possible up to five operands
4583
4584       --  The outer loop runs more than once if there are more than five
4585       --  concatenations of type Standard.String, the most we handle for
4586       --  this case, or if more than one concatenation type is involved.
4587
4588       Outer : loop
4589          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
4590          Set_Parent (Opnds, N);
4591
4592          --  The inner loop gathers concatenation operands. We gather any
4593          --  number of these in the non-string case, or if no concatenation
4594          --  routines are available for string (since in that case we will
4595          --  treat string like any other non-string case). Otherwise we only
4596          --  gather as many operands as can be handled by the available
4597          --  procedures in the run-time library (normally 5, but may be
4598          --  less for the configurable run-time case).
4599
4600          Inner : while Cnode /= N
4601                    and then (Base_Type (Etype (Cnode)) /= Standard_String
4602                                or else
4603                              Max_Available_String_Operands = 0
4604                                or else
4605                              List_Length (Opnds) <
4606                                                Max_Available_String_Operands)
4607                    and then Base_Type (Etype (Cnode)) =
4608                             Base_Type (Etype (Parent (Cnode)))
4609          loop
4610             Cnode := Parent (Cnode);
4611             Append (Right_Opnd (Cnode), Opnds);
4612          end loop Inner;
4613
4614          --  Here we process the collected operands. First we convert singleton
4615          --  operands to singleton aggregates. This is skipped however for the
4616          --  case of two operands of type String since we have special routines
4617          --  for these cases.
4618
4619          Atyp := Base_Type (Etype (Cnode));
4620          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
4621
4622          if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
4623            or else not Char_Concat_Available
4624          then
4625             Opnd := First (Opnds);
4626             loop
4627                if Base_Type (Etype (Opnd)) = Ctyp then
4628                   Rewrite (Opnd,
4629                     Make_Aggregate (Sloc (Cnode),
4630                       Expressions => New_List (Relocate_Node (Opnd))));
4631                   Analyze_And_Resolve (Opnd, Atyp);
4632                end if;
4633
4634                Next (Opnd);
4635                exit when No (Opnd);
4636             end loop;
4637          end if;
4638
4639          --  Now call appropriate continuation routine
4640
4641          if Atyp = Standard_String
4642            and then Max_Available_String_Operands > 0
4643          then
4644             Expand_Concatenate_String (Cnode, Opnds);
4645          else
4646             Expand_Concatenate_Other (Cnode, Opnds);
4647          end if;
4648
4649          exit Outer when Cnode = N;
4650          Cnode := Parent (Cnode);
4651       end loop Outer;
4652    end Expand_N_Op_Concat;
4653
4654    ------------------------
4655    -- Expand_N_Op_Divide --
4656    ------------------------
4657
4658    procedure Expand_N_Op_Divide (N : Node_Id) is
4659       Loc   : constant Source_Ptr := Sloc (N);
4660       Lopnd : constant Node_Id    := Left_Opnd (N);
4661       Ropnd : constant Node_Id    := Right_Opnd (N);
4662       Ltyp  : constant Entity_Id  := Etype (Lopnd);
4663       Rtyp  : constant Entity_Id  := Etype (Ropnd);
4664       Typ   : Entity_Id           := Etype (N);
4665       Rknow : constant Boolean    := Is_Integer_Type (Typ)
4666                                        and then
4667                                          Compile_Time_Known_Value (Ropnd);
4668       Rval  : Uint;
4669
4670    begin
4671       Binary_Op_Validity_Checks (N);
4672
4673       if Rknow then
4674          Rval := Expr_Value (Ropnd);
4675       end if;
4676
4677       --  N / 1 = N for integer types
4678
4679       if Rknow and then Rval = Uint_1 then
4680          Rewrite (N, Lopnd);
4681          return;
4682       end if;
4683
4684       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4685       --  Is_Power_Of_2_For_Shift is set means that we know that our left
4686       --  operand is an unsigned integer, as required for this to work.
4687
4688       if Nkind (Ropnd) = N_Op_Expon
4689         and then Is_Power_Of_2_For_Shift (Ropnd)
4690
4691       --  We cannot do this transformation in configurable run time mode if we
4692       --  have 64-bit --  integers and long shifts are not available.
4693
4694         and then
4695           (Esize (Ltyp) <= 32
4696              or else Support_Long_Shifts_On_Target)
4697       then
4698          Rewrite (N,
4699            Make_Op_Shift_Right (Loc,
4700              Left_Opnd  => Lopnd,
4701              Right_Opnd =>
4702                Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
4703          Analyze_And_Resolve (N, Typ);
4704          return;
4705       end if;
4706
4707       --  Do required fixup of universal fixed operation
4708
4709       if Typ = Universal_Fixed then
4710          Fixup_Universal_Fixed_Operation (N);
4711          Typ := Etype (N);
4712       end if;
4713
4714       --  Divisions with fixed-point results
4715
4716       if Is_Fixed_Point_Type (Typ) then
4717
4718          --  No special processing if Treat_Fixed_As_Integer is set, since
4719          --  from a semantic point of view such operations are simply integer
4720          --  operations and will be treated that way.
4721
4722          if not Treat_Fixed_As_Integer (N) then
4723             if Is_Integer_Type (Rtyp) then
4724                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
4725             else
4726                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
4727             end if;
4728          end if;
4729
4730       --  Other cases of division of fixed-point operands. Again we exclude the
4731       --  case where Treat_Fixed_As_Integer is set.
4732
4733       elsif (Is_Fixed_Point_Type (Ltyp) or else
4734              Is_Fixed_Point_Type (Rtyp))
4735         and then not Treat_Fixed_As_Integer (N)
4736       then
4737          if Is_Integer_Type (Typ) then
4738             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
4739          else
4740             pragma Assert (Is_Floating_Point_Type (Typ));
4741             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
4742          end if;
4743
4744       --  Mixed-mode operations can appear in a non-static universal context,
4745       --  in which case the integer argument must be converted explicitly.
4746
4747       elsif Typ = Universal_Real
4748         and then Is_Integer_Type (Rtyp)
4749       then
4750          Rewrite (Ropnd,
4751            Convert_To (Universal_Real, Relocate_Node (Ropnd)));
4752
4753          Analyze_And_Resolve (Ropnd, Universal_Real);
4754
4755       elsif Typ = Universal_Real
4756         and then Is_Integer_Type (Ltyp)
4757       then
4758          Rewrite (Lopnd,
4759            Convert_To (Universal_Real, Relocate_Node (Lopnd)));
4760
4761          Analyze_And_Resolve (Lopnd, Universal_Real);
4762
4763       --  Non-fixed point cases, do integer zero divide and overflow checks
4764
4765       elsif Is_Integer_Type (Typ) then
4766          Apply_Divide_Check (N);
4767
4768          --  Check for 64-bit division available, or long shifts if the divisor
4769          --  is a small power of 2 (since such divides will be converted into
4770          --  long shifts.
4771
4772          if Esize (Ltyp) > 32
4773            and then not Support_64_Bit_Divides_On_Target
4774            and then
4775              (not Rknow
4776                 or else not Support_Long_Shifts_On_Target
4777                 or else (Rval /= Uint_2  and then
4778                          Rval /= Uint_4  and then
4779                          Rval /= Uint_8  and then
4780                          Rval /= Uint_16 and then
4781                          Rval /= Uint_32 and then
4782                          Rval /= Uint_64))
4783          then
4784             Error_Msg_CRT ("64-bit division", N);
4785          end if;
4786
4787       --  Deal with Vax_Float
4788
4789       elsif Vax_Float (Typ) then
4790          Expand_Vax_Arith (N);
4791          return;
4792       end if;
4793    end Expand_N_Op_Divide;
4794
4795    --------------------
4796    -- Expand_N_Op_Eq --
4797    --------------------
4798
4799    procedure Expand_N_Op_Eq (N : Node_Id) is
4800       Loc    : constant Source_Ptr := Sloc (N);
4801       Typ    : constant Entity_Id  := Etype (N);
4802       Lhs    : constant Node_Id    := Left_Opnd (N);
4803       Rhs    : constant Node_Id    := Right_Opnd (N);
4804       Bodies : constant List_Id    := New_List;
4805       A_Typ  : constant Entity_Id  := Etype (Lhs);
4806
4807       Typl    : Entity_Id := A_Typ;
4808       Op_Name : Entity_Id;
4809       Prim    : Elmt_Id;
4810
4811       procedure Build_Equality_Call (Eq : Entity_Id);
4812       --  If a constructed equality exists for the type or for its parent,
4813       --  build and analyze call, adding conversions if the operation is
4814       --  inherited.
4815
4816       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
4817       --  Determines whether a type has a subcomponent of an unconstrained
4818       --  Unchecked_Union subtype. Typ is a record type.
4819
4820       -------------------------
4821       -- Build_Equality_Call --
4822       -------------------------
4823
4824       procedure Build_Equality_Call (Eq : Entity_Id) is
4825          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
4826          L_Exp   : Node_Id := Relocate_Node (Lhs);
4827          R_Exp   : Node_Id := Relocate_Node (Rhs);
4828
4829       begin
4830          if Base_Type (Op_Type) /= Base_Type (A_Typ)
4831            and then not Is_Class_Wide_Type (A_Typ)
4832          then
4833             L_Exp := OK_Convert_To (Op_Type, L_Exp);
4834             R_Exp := OK_Convert_To (Op_Type, R_Exp);
4835          end if;
4836
4837          --  If we have an Unchecked_Union, we need to add the inferred
4838          --  discriminant values as actuals in the function call. At this
4839          --  point, the expansion has determined that both operands have
4840          --  inferable discriminants.
4841
4842          if Is_Unchecked_Union (Op_Type) then
4843             declare
4844                Lhs_Type      : constant Node_Id := Etype (L_Exp);
4845                Rhs_Type      : constant Node_Id := Etype (R_Exp);
4846                Lhs_Discr_Val : Node_Id;
4847                Rhs_Discr_Val : Node_Id;
4848
4849             begin
4850                --  Per-object constrained selected components require special
4851                --  attention. If the enclosing scope of the component is an
4852                --  Unchecked_Union, we cannot reference its discriminants
4853                --  directly. This is why we use the two extra parameters of
4854                --  the equality function of the enclosing Unchecked_Union.
4855
4856                --  type UU_Type (Discr : Integer := 0) is
4857                --     . . .
4858                --  end record;
4859                --  pragma Unchecked_Union (UU_Type);
4860
4861                --  1. Unchecked_Union enclosing record:
4862
4863                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
4864                --        . . .
4865                --        Comp : UU_Type (Discr);
4866                --        . . .
4867                --     end Enclosing_UU_Type;
4868                --     pragma Unchecked_Union (Enclosing_UU_Type);
4869
4870                --     Obj1 : Enclosing_UU_Type;
4871                --     Obj2 : Enclosing_UU_Type (1);
4872
4873                --     [. . .] Obj1 = Obj2 [. . .]
4874
4875                --     Generated code:
4876
4877                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4878
4879                --  A and B are the formal parameters of the equality function
4880                --  of Enclosing_UU_Type. The function always has two extra
4881                --  formals to capture the inferred discriminant values.
4882
4883                --  2. Non-Unchecked_Union enclosing record:
4884
4885                --     type
4886                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
4887                --     is record
4888                --        . . .
4889                --        Comp : UU_Type (Discr);
4890                --        . . .
4891                --     end Enclosing_Non_UU_Type;
4892
4893                --     Obj1 : Enclosing_Non_UU_Type;
4894                --     Obj2 : Enclosing_Non_UU_Type (1);
4895
4896                --     ...  Obj1 = Obj2 ...
4897
4898                --     Generated code:
4899
4900                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
4901                --                        obj1.discr, obj2.discr)) then
4902
4903                --  In this case we can directly reference the discriminants of
4904                --  the enclosing record.
4905
4906                --  Lhs of equality
4907
4908                if Nkind (Lhs) = N_Selected_Component
4909                  and then Has_Per_Object_Constraint
4910                             (Entity (Selector_Name (Lhs)))
4911                then
4912                   --  Enclosing record is an Unchecked_Union, use formal A
4913
4914                   if Is_Unchecked_Union (Scope
4915                        (Entity (Selector_Name (Lhs))))
4916                   then
4917                      Lhs_Discr_Val :=
4918                        Make_Identifier (Loc,
4919                          Chars => Name_A);
4920
4921                   --  Enclosing record is of a non-Unchecked_Union type, it is
4922                   --  possible to reference the discriminant.
4923
4924                   else
4925                      Lhs_Discr_Val :=
4926                        Make_Selected_Component (Loc,
4927                          Prefix => Prefix (Lhs),
4928                          Selector_Name =>
4929                            New_Copy
4930                              (Get_Discriminant_Value
4931                                 (First_Discriminant (Lhs_Type),
4932                                  Lhs_Type,
4933                                  Stored_Constraint (Lhs_Type))));
4934                   end if;
4935
4936                --  Comment needed here ???
4937
4938                else
4939                   --  Infer the discriminant value
4940
4941                   Lhs_Discr_Val :=
4942                     New_Copy
4943                       (Get_Discriminant_Value
4944                          (First_Discriminant (Lhs_Type),
4945                           Lhs_Type,
4946                           Stored_Constraint (Lhs_Type)));
4947                end if;
4948
4949                --  Rhs of equality
4950
4951                if Nkind (Rhs) = N_Selected_Component
4952                  and then Has_Per_Object_Constraint
4953                             (Entity (Selector_Name (Rhs)))
4954                then
4955                   if Is_Unchecked_Union
4956                        (Scope (Entity (Selector_Name (Rhs))))
4957                   then
4958                      Rhs_Discr_Val :=
4959                        Make_Identifier (Loc,
4960                          Chars => Name_B);
4961
4962                   else
4963                      Rhs_Discr_Val :=
4964                        Make_Selected_Component (Loc,
4965                          Prefix => Prefix (Rhs),
4966                          Selector_Name =>
4967                            New_Copy (Get_Discriminant_Value (
4968                              First_Discriminant (Rhs_Type),
4969                              Rhs_Type,
4970                              Stored_Constraint (Rhs_Type))));
4971
4972                   end if;
4973                else
4974                   Rhs_Discr_Val :=
4975                     New_Copy (Get_Discriminant_Value (
4976                       First_Discriminant (Rhs_Type),
4977                       Rhs_Type,
4978                       Stored_Constraint (Rhs_Type)));
4979
4980                end if;
4981
4982                Rewrite (N,
4983                  Make_Function_Call (Loc,
4984                    Name => New_Reference_To (Eq, Loc),
4985                    Parameter_Associations => New_List (
4986                      L_Exp,
4987                      R_Exp,
4988                      Lhs_Discr_Val,
4989                      Rhs_Discr_Val)));
4990             end;
4991
4992          --  Normal case, not an unchecked union
4993
4994          else
4995             Rewrite (N,
4996               Make_Function_Call (Loc,
4997                 Name => New_Reference_To (Eq, Loc),
4998                 Parameter_Associations => New_List (L_Exp, R_Exp)));
4999          end if;
5000
5001          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5002       end Build_Equality_Call;
5003
5004       ------------------------------------
5005       -- Has_Unconstrained_UU_Component --
5006       ------------------------------------
5007
5008       function Has_Unconstrained_UU_Component
5009         (Typ : Node_Id) return Boolean
5010       is
5011          Tdef  : constant Node_Id :=
5012                    Type_Definition (Declaration_Node (Base_Type (Typ)));
5013          Clist : Node_Id;
5014          Vpart : Node_Id;
5015
5016          function Component_Is_Unconstrained_UU
5017            (Comp : Node_Id) return Boolean;
5018          --  Determines whether the subtype of the component is an
5019          --  unconstrained Unchecked_Union.
5020
5021          function Variant_Is_Unconstrained_UU
5022            (Variant : Node_Id) return Boolean;
5023          --  Determines whether a component of the variant has an unconstrained
5024          --  Unchecked_Union subtype.
5025
5026          -----------------------------------
5027          -- Component_Is_Unconstrained_UU --
5028          -----------------------------------
5029
5030          function Component_Is_Unconstrained_UU
5031            (Comp : Node_Id) return Boolean
5032          is
5033          begin
5034             if Nkind (Comp) /= N_Component_Declaration then
5035                return False;
5036             end if;
5037
5038             declare
5039                Sindic : constant Node_Id :=
5040                           Subtype_Indication (Component_Definition (Comp));
5041
5042             begin
5043                --  Unconstrained nominal type. In the case of a constraint
5044                --  present, the node kind would have been N_Subtype_Indication.
5045
5046                if Nkind (Sindic) = N_Identifier then
5047                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
5048                end if;
5049
5050                return False;
5051             end;
5052          end Component_Is_Unconstrained_UU;
5053
5054          ---------------------------------
5055          -- Variant_Is_Unconstrained_UU --
5056          ---------------------------------
5057
5058          function Variant_Is_Unconstrained_UU
5059            (Variant : Node_Id) return Boolean
5060          is
5061             Clist : constant Node_Id := Component_List (Variant);
5062
5063          begin
5064             if Is_Empty_List (Component_Items (Clist)) then
5065                return False;
5066             end if;
5067
5068             --  We only need to test one component
5069
5070             declare
5071                Comp : Node_Id := First (Component_Items (Clist));
5072
5073             begin
5074                while Present (Comp) loop
5075                   if Component_Is_Unconstrained_UU (Comp) then
5076                      return True;
5077                   end if;
5078
5079                   Next (Comp);
5080                end loop;
5081             end;
5082
5083             --  None of the components withing the variant were of
5084             --  unconstrained Unchecked_Union type.
5085
5086             return False;
5087          end Variant_Is_Unconstrained_UU;
5088
5089       --  Start of processing for Has_Unconstrained_UU_Component
5090
5091       begin
5092          if Null_Present (Tdef) then
5093             return False;
5094          end if;
5095
5096          Clist := Component_List (Tdef);
5097          Vpart := Variant_Part (Clist);
5098
5099          --  Inspect available components
5100
5101          if Present (Component_Items (Clist)) then
5102             declare
5103                Comp : Node_Id := First (Component_Items (Clist));
5104
5105             begin
5106                while Present (Comp) loop
5107
5108                   --  One component is sufficient
5109
5110                   if Component_Is_Unconstrained_UU (Comp) then
5111                      return True;
5112                   end if;
5113
5114                   Next (Comp);
5115                end loop;
5116             end;
5117          end if;
5118
5119          --  Inspect available components withing variants
5120
5121          if Present (Vpart) then
5122             declare
5123                Variant : Node_Id := First (Variants (Vpart));
5124
5125             begin
5126                while Present (Variant) loop
5127
5128                   --  One component within a variant is sufficient
5129
5130                   if Variant_Is_Unconstrained_UU (Variant) then
5131                      return True;
5132                   end if;
5133
5134                   Next (Variant);
5135                end loop;
5136             end;
5137          end if;
5138
5139          --  Neither the available components, nor the components inside the
5140          --  variant parts were of an unconstrained Unchecked_Union subtype.
5141
5142          return False;
5143       end Has_Unconstrained_UU_Component;
5144
5145    --  Start of processing for Expand_N_Op_Eq
5146
5147    begin
5148       Binary_Op_Validity_Checks (N);
5149
5150       if Ekind (Typl) = E_Private_Type then
5151          Typl := Underlying_Type (Typl);
5152       elsif Ekind (Typl) = E_Private_Subtype then
5153          Typl := Underlying_Type (Base_Type (Typl));
5154       else
5155          null;
5156       end if;
5157
5158       --  It may happen in error situations that the underlying type is not
5159       --  set. The error will be detected later, here we just defend the
5160       --  expander code.
5161
5162       if No (Typl) then
5163          return;
5164       end if;
5165
5166       Typl := Base_Type (Typl);
5167
5168       --  Boolean types (requiring handling of non-standard case)
5169
5170       if Is_Boolean_Type (Typl) then
5171          Adjust_Condition (Left_Opnd (N));
5172          Adjust_Condition (Right_Opnd (N));
5173          Set_Etype (N, Standard_Boolean);
5174          Adjust_Result_Type (N, Typ);
5175
5176       --  Array types
5177
5178       elsif Is_Array_Type (Typl) then
5179
5180          --  If we are doing full validity checking, and it is possible for the
5181          --  array elements to be invalid then expand out array comparisons to
5182          --  make sure that we check the array elements.
5183
5184          if Validity_Check_Operands
5185            and then not Is_Known_Valid (Component_Type (Typl))
5186          then
5187             declare
5188                Save_Force_Validity_Checks : constant Boolean :=
5189                                               Force_Validity_Checks;
5190             begin
5191                Force_Validity_Checks := True;
5192                Rewrite (N,
5193                  Expand_Array_Equality
5194                   (N,
5195                    Relocate_Node (Lhs),
5196                    Relocate_Node (Rhs),
5197                    Bodies,
5198                    Typl));
5199                Insert_Actions (N, Bodies);
5200                Analyze_And_Resolve (N, Standard_Boolean);
5201                Force_Validity_Checks := Save_Force_Validity_Checks;
5202             end;
5203
5204          --  Packed case where both operands are known aligned
5205
5206          elsif Is_Bit_Packed_Array (Typl)
5207            and then not Is_Possibly_Unaligned_Object (Lhs)
5208            and then not Is_Possibly_Unaligned_Object (Rhs)
5209          then
5210             Expand_Packed_Eq (N);
5211
5212          --  Where the component type is elementary we can use a block bit
5213          --  comparison (if supported on the target) exception in the case
5214          --  of floating-point (negative zero issues require element by
5215          --  element comparison), and atomic types (where we must be sure
5216          --  to load elements independently) and possibly unaligned arrays.
5217
5218          elsif Is_Elementary_Type (Component_Type (Typl))
5219            and then not Is_Floating_Point_Type (Component_Type (Typl))
5220            and then not Is_Atomic (Component_Type (Typl))
5221            and then not Is_Possibly_Unaligned_Object (Lhs)
5222            and then not Is_Possibly_Unaligned_Object (Rhs)
5223            and then Support_Composite_Compare_On_Target
5224          then
5225             null;
5226
5227          --  For composite and floating-point cases, expand equality loop to
5228          --  make sure of using proper comparisons for tagged types, and
5229          --  correctly handling the floating-point case.
5230
5231          else
5232             Rewrite (N,
5233               Expand_Array_Equality
5234                 (N,
5235                  Relocate_Node (Lhs),
5236                  Relocate_Node (Rhs),
5237                  Bodies,
5238                  Typl));
5239             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5240             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5241          end if;
5242
5243       --  Record Types
5244
5245       elsif Is_Record_Type (Typl) then
5246
5247          --  For tagged types, use the primitive "="
5248
5249          if Is_Tagged_Type (Typl) then
5250
5251             --  No need to do anything else compiling under restriction
5252             --  No_Dispatching_Calls. During the semantic analysis we
5253             --  already notified such violation.
5254
5255             if Restriction_Active (No_Dispatching_Calls) then
5256                return;
5257             end if;
5258
5259             --  If this is derived from an untagged private type completed with
5260             --  a tagged type, it does not have a full view, so we use the
5261             --  primitive operations of the private type. This check should no
5262             --  longer be necessary when these types get their full views???
5263
5264             if Is_Private_Type (A_Typ)
5265               and then not Is_Tagged_Type (A_Typ)
5266               and then Is_Derived_Type (A_Typ)
5267               and then No (Full_View (A_Typ))
5268             then
5269                --  Search for equality operation, checking that the operands
5270                --  have the same type. Note that we must find a matching entry,
5271                --  or something is very wrong!
5272
5273                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
5274
5275                while Present (Prim) loop
5276                   exit when Chars (Node (Prim)) = Name_Op_Eq
5277                     and then Etype (First_Formal (Node (Prim))) =
5278                              Etype (Next_Formal (First_Formal (Node (Prim))))
5279                     and then
5280                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5281
5282                   Next_Elmt (Prim);
5283                end loop;
5284
5285                pragma Assert (Present (Prim));
5286                Op_Name := Node (Prim);
5287
5288             --  Find the type's predefined equality or an overriding
5289             --  user- defined equality. The reason for not simply calling
5290             --  Find_Prim_Op here is that there may be a user-defined
5291             --  overloaded equality op that precedes the equality that we want,
5292             --  so we have to explicitly search (e.g., there could be an
5293             --  equality with two different parameter types).
5294
5295             else
5296                if Is_Class_Wide_Type (Typl) then
5297                   Typl := Root_Type (Typl);
5298                end if;
5299
5300                Prim := First_Elmt (Primitive_Operations (Typl));
5301                while Present (Prim) loop
5302                   exit when Chars (Node (Prim)) = Name_Op_Eq
5303                     and then Etype (First_Formal (Node (Prim))) =
5304                              Etype (Next_Formal (First_Formal (Node (Prim))))
5305                     and then
5306                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5307
5308                   Next_Elmt (Prim);
5309                end loop;
5310
5311                pragma Assert (Present (Prim));
5312                Op_Name := Node (Prim);
5313             end if;
5314
5315             Build_Equality_Call (Op_Name);
5316
5317          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
5318          --  predefined equality operator for a type which has a subcomponent
5319          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
5320
5321          elsif Has_Unconstrained_UU_Component (Typl) then
5322             Insert_Action (N,
5323               Make_Raise_Program_Error (Loc,
5324                 Reason => PE_Unchecked_Union_Restriction));
5325
5326             --  Prevent Gigi from generating incorrect code by rewriting the
5327             --  equality as a standard False.
5328
5329             Rewrite (N,
5330               New_Occurrence_Of (Standard_False, Loc));
5331
5332          elsif Is_Unchecked_Union (Typl) then
5333
5334             --  If we can infer the discriminants of the operands, we make a
5335             --  call to the TSS equality function.
5336
5337             if Has_Inferable_Discriminants (Lhs)
5338                  and then
5339                Has_Inferable_Discriminants (Rhs)
5340             then
5341                Build_Equality_Call
5342                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
5343
5344             else
5345                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
5346                --  the predefined equality operator for an Unchecked_Union type
5347                --  if either of the operands lack inferable discriminants.
5348
5349                Insert_Action (N,
5350                  Make_Raise_Program_Error (Loc,
5351                    Reason => PE_Unchecked_Union_Restriction));
5352
5353                --  Prevent Gigi from generating incorrect code by rewriting
5354                --  the equality as a standard False.
5355
5356                Rewrite (N,
5357                  New_Occurrence_Of (Standard_False, Loc));
5358
5359             end if;
5360
5361          --  If a type support function is present (for complex cases), use it
5362
5363          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
5364             Build_Equality_Call
5365               (TSS (Root_Type (Typl), TSS_Composite_Equality));
5366
5367          --  Otherwise expand the component by component equality. Note that
5368          --  we never use block-bit comparisons for records, because of the
5369          --  problems with gaps. The backend will often be able to recombine
5370          --  the separate comparisons that we generate here.
5371
5372          else
5373             Remove_Side_Effects (Lhs);
5374             Remove_Side_Effects (Rhs);
5375             Rewrite (N,
5376               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
5377
5378             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5379             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5380          end if;
5381       end if;
5382
5383       --  Test if result is known at compile time
5384
5385       Rewrite_Comparison (N);
5386
5387       --  If we still have comparison for Vax_Float, process it
5388
5389       if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare  then
5390          Expand_Vax_Comparison (N);
5391          return;
5392       end if;
5393    end Expand_N_Op_Eq;
5394
5395    -----------------------
5396    -- Expand_N_Op_Expon --
5397    -----------------------
5398
5399    procedure Expand_N_Op_Expon (N : Node_Id) is
5400       Loc    : constant Source_Ptr := Sloc (N);
5401       Typ    : constant Entity_Id  := Etype (N);
5402       Rtyp   : constant Entity_Id  := Root_Type (Typ);
5403       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
5404       Bastyp : constant Node_Id    := Etype (Base);
5405       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
5406       Exptyp : constant Entity_Id  := Etype (Exp);
5407       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
5408       Expv   : Uint;
5409       Xnode  : Node_Id;
5410       Temp   : Node_Id;
5411       Rent   : RE_Id;
5412       Ent    : Entity_Id;
5413       Etyp   : Entity_Id;
5414
5415    begin
5416       Binary_Op_Validity_Checks (N);
5417
5418       --  If either operand is of a private type, then we have the use of an
5419       --  intrinsic operator, and we get rid of the privateness, by using root
5420       --  types of underlying types for the actual operation. Otherwise the
5421       --  private types will cause trouble if we expand multiplications or
5422       --  shifts etc. We also do this transformation if the result type is
5423       --  different from the base type.
5424
5425       if Is_Private_Type (Etype (Base))
5426            or else
5427          Is_Private_Type (Typ)
5428            or else
5429          Is_Private_Type (Exptyp)
5430            or else
5431          Rtyp /= Root_Type (Bastyp)
5432       then
5433          declare
5434             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
5435             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
5436
5437          begin
5438             Rewrite (N,
5439               Unchecked_Convert_To (Typ,
5440                 Make_Op_Expon (Loc,
5441                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
5442                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
5443             Analyze_And_Resolve (N, Typ);
5444             return;
5445          end;
5446       end if;
5447
5448       --  Test for case of known right argument
5449
5450       if Compile_Time_Known_Value (Exp) then
5451          Expv := Expr_Value (Exp);
5452
5453          --  We only fold small non-negative exponents. You might think we
5454          --  could fold small negative exponents for the real case, but we
5455          --  can't because we are required to raise Constraint_Error for
5456          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
5457          --  See ACVC test C4A012B.
5458
5459          if Expv >= 0 and then Expv <= 4 then
5460
5461             --  X ** 0 = 1 (or 1.0)
5462
5463             if Expv = 0 then
5464                if Ekind (Typ) in Integer_Kind then
5465                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
5466                else
5467                   Xnode := Make_Real_Literal (Loc, Ureal_1);
5468                end if;
5469
5470             --  X ** 1 = X
5471
5472             elsif Expv = 1 then
5473                Xnode := Base;
5474
5475             --  X ** 2 = X * X
5476
5477             elsif Expv = 2 then
5478                Xnode :=
5479                  Make_Op_Multiply (Loc,
5480                    Left_Opnd  => Duplicate_Subexpr (Base),
5481                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
5482
5483             --  X ** 3 = X * X * X
5484
5485             elsif Expv = 3 then
5486                Xnode :=
5487                  Make_Op_Multiply (Loc,
5488                    Left_Opnd =>
5489                      Make_Op_Multiply (Loc,
5490                        Left_Opnd  => Duplicate_Subexpr (Base),
5491                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
5492                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
5493
5494             --  X ** 4  ->
5495             --    En : constant base'type := base * base;
5496             --    ...
5497             --    En * En
5498
5499             else -- Expv = 4
5500                Temp :=
5501                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5502
5503                Insert_Actions (N, New_List (
5504                  Make_Object_Declaration (Loc,
5505                    Defining_Identifier => Temp,
5506                    Constant_Present    => True,
5507                    Object_Definition   => New_Reference_To (Typ, Loc),
5508                    Expression =>
5509                      Make_Op_Multiply (Loc,
5510                        Left_Opnd  => Duplicate_Subexpr (Base),
5511                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
5512
5513                Xnode :=
5514                  Make_Op_Multiply (Loc,
5515                    Left_Opnd  => New_Reference_To (Temp, Loc),
5516                    Right_Opnd => New_Reference_To (Temp, Loc));
5517             end if;
5518
5519             Rewrite (N, Xnode);
5520             Analyze_And_Resolve (N, Typ);
5521             return;
5522          end if;
5523       end if;
5524
5525       --  Case of (2 ** expression) appearing as an argument of an integer
5526       --  multiplication, or as the right argument of a division of a non-
5527       --  negative integer. In such cases we leave the node untouched, setting
5528       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5529       --  of the higher level node converts it into a shift.
5530
5531       --  Note: this transformation is not applicable for a modular type with
5532       --  a non-binary modulus in the multiplication case, since we get a wrong
5533       --  result if the shift causes an overflow before the modular reduction.
5534
5535       if Nkind (Base) = N_Integer_Literal
5536         and then Intval (Base) = 2
5537         and then Is_Integer_Type (Root_Type (Exptyp))
5538         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
5539         and then Is_Unsigned_Type (Exptyp)
5540         and then not Ovflo
5541         and then Nkind (Parent (N)) in N_Binary_Op
5542       then
5543          declare
5544             P : constant Node_Id := Parent (N);
5545             L : constant Node_Id := Left_Opnd (P);
5546             R : constant Node_Id := Right_Opnd (P);
5547
5548          begin
5549             if (Nkind (P) = N_Op_Multiply
5550                  and then not Non_Binary_Modulus (Typ)
5551                  and then
5552                    ((Is_Integer_Type (Etype (L)) and then R = N)
5553                        or else
5554                     (Is_Integer_Type (Etype (R)) and then L = N))
5555                  and then not Do_Overflow_Check (P))
5556
5557               or else
5558                 (Nkind (P) = N_Op_Divide
5559                   and then Is_Integer_Type (Etype (L))
5560                   and then Is_Unsigned_Type (Etype (L))
5561                   and then R = N
5562                   and then not Do_Overflow_Check (P))
5563             then
5564                Set_Is_Power_Of_2_For_Shift (N);
5565                return;
5566             end if;
5567          end;
5568       end if;
5569
5570       --  Fall through if exponentiation must be done using a runtime routine
5571
5572       --  First deal with modular case
5573
5574       if Is_Modular_Integer_Type (Rtyp) then
5575
5576          --  Non-binary case, we call the special exponentiation routine for
5577          --  the non-binary case, converting the argument to Long_Long_Integer
5578          --  and passing the modulus value. Then the result is converted back
5579          --  to the base type.
5580
5581          if Non_Binary_Modulus (Rtyp) then
5582             Rewrite (N,
5583               Convert_To (Typ,
5584                 Make_Function_Call (Loc,
5585                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
5586                   Parameter_Associations => New_List (
5587                     Convert_To (Standard_Integer, Base),
5588                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
5589                     Exp))));
5590
5591          --  Binary case, in this case, we call one of two routines, either the
5592          --  unsigned integer case, or the unsigned long long integer case,
5593          --  with a final "and" operation to do the required mod.
5594
5595          else
5596             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
5597                Ent := RTE (RE_Exp_Unsigned);
5598             else
5599                Ent := RTE (RE_Exp_Long_Long_Unsigned);
5600             end if;
5601
5602             Rewrite (N,
5603               Convert_To (Typ,
5604                 Make_Op_And (Loc,
5605                   Left_Opnd =>
5606                     Make_Function_Call (Loc,
5607                       Name => New_Reference_To (Ent, Loc),
5608                       Parameter_Associations => New_List (
5609                         Convert_To (Etype (First_Formal (Ent)), Base),
5610                         Exp)),
5611                    Right_Opnd =>
5612                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
5613
5614          end if;
5615
5616          --  Common exit point for modular type case
5617
5618          Analyze_And_Resolve (N, Typ);
5619          return;
5620
5621       --  Signed integer cases, done using either Integer or Long_Long_Integer.
5622       --  It is not worth having routines for Short_[Short_]Integer, since for
5623       --  most machines it would not help, and it would generate more code that
5624       --  might need certification when a certified run time is required.
5625
5626       --  In the integer cases, we have two routines, one for when overflow
5627       --  checks are required, and one when they are not required, since there
5628       --  is a real gain in omitting checks on many machines.
5629
5630       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
5631         or else (Rtyp = Base_Type (Standard_Long_Integer)
5632                    and then
5633                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
5634         or else (Rtyp = Universal_Integer)
5635       then
5636          Etyp := Standard_Long_Long_Integer;
5637
5638          if Ovflo then
5639             Rent := RE_Exp_Long_Long_Integer;
5640          else
5641             Rent := RE_Exn_Long_Long_Integer;
5642          end if;
5643
5644       elsif Is_Signed_Integer_Type (Rtyp) then
5645          Etyp := Standard_Integer;
5646
5647          if Ovflo then
5648             Rent := RE_Exp_Integer;
5649          else
5650             Rent := RE_Exn_Integer;
5651          end if;
5652
5653       --  Floating-point cases, always done using Long_Long_Float. We do not
5654       --  need separate routines for the overflow case here, since in the case
5655       --  of floating-point, we generate infinities anyway as a rule (either
5656       --  that or we automatically trap overflow), and if there is an infinity
5657       --  generated and a range check is required, the check will fail anyway.
5658
5659       else
5660          pragma Assert (Is_Floating_Point_Type (Rtyp));
5661          Etyp := Standard_Long_Long_Float;
5662          Rent := RE_Exn_Long_Long_Float;
5663       end if;
5664
5665       --  Common processing for integer cases and floating-point cases.
5666       --  If we are in the right type, we can call runtime routine directly
5667
5668       if Typ = Etyp
5669         and then Rtyp /= Universal_Integer
5670         and then Rtyp /= Universal_Real
5671       then
5672          Rewrite (N,
5673            Make_Function_Call (Loc,
5674              Name => New_Reference_To (RTE (Rent), Loc),
5675              Parameter_Associations => New_List (Base, Exp)));
5676
5677       --  Otherwise we have to introduce conversions (conversions are also
5678       --  required in the universal cases, since the runtime routine is
5679       --  typed using one of the standard types.
5680
5681       else
5682          Rewrite (N,
5683            Convert_To (Typ,
5684              Make_Function_Call (Loc,
5685                Name => New_Reference_To (RTE (Rent), Loc),
5686                Parameter_Associations => New_List (
5687                  Convert_To (Etyp, Base),
5688                  Exp))));
5689       end if;
5690
5691       Analyze_And_Resolve (N, Typ);
5692       return;
5693
5694    exception
5695       when RE_Not_Available =>
5696          return;
5697    end Expand_N_Op_Expon;
5698
5699    --------------------
5700    -- Expand_N_Op_Ge --
5701    --------------------
5702
5703    procedure Expand_N_Op_Ge (N : Node_Id) is
5704       Typ  : constant Entity_Id := Etype (N);
5705       Op1  : constant Node_Id   := Left_Opnd (N);
5706       Op2  : constant Node_Id   := Right_Opnd (N);
5707       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5708
5709    begin
5710       Binary_Op_Validity_Checks (N);
5711
5712       if Is_Array_Type (Typ1) then
5713          Expand_Array_Comparison (N);
5714          return;
5715       end if;
5716
5717       if Is_Boolean_Type (Typ1) then
5718          Adjust_Condition (Op1);
5719          Adjust_Condition (Op2);
5720          Set_Etype (N, Standard_Boolean);
5721          Adjust_Result_Type (N, Typ);
5722       end if;
5723
5724       Rewrite_Comparison (N);
5725
5726       --  If we still have comparison, and Vax_Float type, process it
5727
5728       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5729          Expand_Vax_Comparison (N);
5730          return;
5731       end if;
5732    end Expand_N_Op_Ge;
5733
5734    --------------------
5735    -- Expand_N_Op_Gt --
5736    --------------------
5737
5738    procedure Expand_N_Op_Gt (N : Node_Id) is
5739       Typ  : constant Entity_Id := Etype (N);
5740       Op1  : constant Node_Id   := Left_Opnd (N);
5741       Op2  : constant Node_Id   := Right_Opnd (N);
5742       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5743
5744    begin
5745       Binary_Op_Validity_Checks (N);
5746
5747       if Is_Array_Type (Typ1) then
5748          Expand_Array_Comparison (N);
5749          return;
5750       end if;
5751
5752       if Is_Boolean_Type (Typ1) then
5753          Adjust_Condition (Op1);
5754          Adjust_Condition (Op2);
5755          Set_Etype (N, Standard_Boolean);
5756          Adjust_Result_Type (N, Typ);
5757       end if;
5758
5759       Rewrite_Comparison (N);
5760
5761       --  If we still have comparison, and Vax_Float type, process it
5762
5763       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5764          Expand_Vax_Comparison (N);
5765          return;
5766       end if;
5767    end Expand_N_Op_Gt;
5768
5769    --------------------
5770    -- Expand_N_Op_Le --
5771    --------------------
5772
5773    procedure Expand_N_Op_Le (N : Node_Id) is
5774       Typ  : constant Entity_Id := Etype (N);
5775       Op1  : constant Node_Id   := Left_Opnd (N);
5776       Op2  : constant Node_Id   := Right_Opnd (N);
5777       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5778
5779    begin
5780       Binary_Op_Validity_Checks (N);
5781
5782       if Is_Array_Type (Typ1) then
5783          Expand_Array_Comparison (N);
5784          return;
5785       end if;
5786
5787       if Is_Boolean_Type (Typ1) then
5788          Adjust_Condition (Op1);
5789          Adjust_Condition (Op2);
5790          Set_Etype (N, Standard_Boolean);
5791          Adjust_Result_Type (N, Typ);
5792       end if;
5793
5794       Rewrite_Comparison (N);
5795
5796       --  If we still have comparison, and Vax_Float type, process it
5797
5798       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5799          Expand_Vax_Comparison (N);
5800          return;
5801       end if;
5802    end Expand_N_Op_Le;
5803
5804    --------------------
5805    -- Expand_N_Op_Lt --
5806    --------------------
5807
5808    procedure Expand_N_Op_Lt (N : Node_Id) is
5809       Typ  : constant Entity_Id := Etype (N);
5810       Op1  : constant Node_Id   := Left_Opnd (N);
5811       Op2  : constant Node_Id   := Right_Opnd (N);
5812       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5813
5814    begin
5815       Binary_Op_Validity_Checks (N);
5816
5817       if Is_Array_Type (Typ1) then
5818          Expand_Array_Comparison (N);
5819          return;
5820       end if;
5821
5822       if Is_Boolean_Type (Typ1) then
5823          Adjust_Condition (Op1);
5824          Adjust_Condition (Op2);
5825          Set_Etype (N, Standard_Boolean);
5826          Adjust_Result_Type (N, Typ);
5827       end if;
5828
5829       Rewrite_Comparison (N);
5830
5831       --  If we still have comparison, and Vax_Float type, process it
5832
5833       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5834          Expand_Vax_Comparison (N);
5835          return;
5836       end if;
5837    end Expand_N_Op_Lt;
5838
5839    -----------------------
5840    -- Expand_N_Op_Minus --
5841    -----------------------
5842
5843    procedure Expand_N_Op_Minus (N : Node_Id) is
5844       Loc : constant Source_Ptr := Sloc (N);
5845       Typ : constant Entity_Id  := Etype (N);
5846
5847    begin
5848       Unary_Op_Validity_Checks (N);
5849
5850       if not Backend_Overflow_Checks_On_Target
5851          and then Is_Signed_Integer_Type (Etype (N))
5852          and then Do_Overflow_Check (N)
5853       then
5854          --  Software overflow checking expands -expr into (0 - expr)
5855
5856          Rewrite (N,
5857            Make_Op_Subtract (Loc,
5858              Left_Opnd  => Make_Integer_Literal (Loc, 0),
5859              Right_Opnd => Right_Opnd (N)));
5860
5861          Analyze_And_Resolve (N, Typ);
5862
5863       --  Vax floating-point types case
5864
5865       elsif Vax_Float (Etype (N)) then
5866          Expand_Vax_Arith (N);
5867       end if;
5868    end Expand_N_Op_Minus;
5869
5870    ---------------------
5871    -- Expand_N_Op_Mod --
5872    ---------------------
5873
5874    procedure Expand_N_Op_Mod (N : Node_Id) is
5875       Loc   : constant Source_Ptr := Sloc (N);
5876       Typ   : constant Entity_Id  := Etype (N);
5877       Left  : constant Node_Id    := Left_Opnd (N);
5878       Right : constant Node_Id    := Right_Opnd (N);
5879       DOC   : constant Boolean    := Do_Overflow_Check (N);
5880       DDC   : constant Boolean    := Do_Division_Check (N);
5881
5882       LLB : Uint;
5883       Llo : Uint;
5884       Lhi : Uint;
5885       LOK : Boolean;
5886       Rlo : Uint;
5887       Rhi : Uint;
5888       ROK : Boolean;
5889
5890       pragma Warnings (Off, Lhi);
5891
5892    begin
5893       Binary_Op_Validity_Checks (N);
5894
5895       Determine_Range (Right, ROK, Rlo, Rhi);
5896       Determine_Range (Left,  LOK, Llo, Lhi);
5897
5898       --  Convert mod to rem if operands are known non-negative. We do this
5899       --  since it is quite likely that this will improve the quality of code,
5900       --  (the operation now corresponds to the hardware remainder), and it
5901       --  does not seem likely that it could be harmful.
5902
5903       if LOK and then Llo >= 0
5904            and then
5905          ROK and then Rlo >= 0
5906       then
5907          Rewrite (N,
5908            Make_Op_Rem (Sloc (N),
5909              Left_Opnd  => Left_Opnd (N),
5910              Right_Opnd => Right_Opnd (N)));
5911
5912          --  Instead of reanalyzing the node we do the analysis manually. This
5913          --  avoids anomalies when the replacement is done in an instance and
5914          --  is epsilon more efficient.
5915
5916          Set_Entity            (N, Standard_Entity (S_Op_Rem));
5917          Set_Etype             (N, Typ);
5918          Set_Do_Overflow_Check (N, DOC);
5919          Set_Do_Division_Check (N, DDC);
5920          Expand_N_Op_Rem (N);
5921          Set_Analyzed (N);
5922
5923       --  Otherwise, normal mod processing
5924
5925       else
5926          if Is_Integer_Type (Etype (N)) then
5927             Apply_Divide_Check (N);
5928          end if;
5929
5930          --  Apply optimization x mod 1 = 0. We don't really need that with
5931          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
5932          --  certainly harmless.
5933
5934          if Is_Integer_Type (Etype (N))
5935            and then Compile_Time_Known_Value (Right)
5936            and then Expr_Value (Right) = Uint_1
5937          then
5938             Rewrite (N, Make_Integer_Literal (Loc, 0));
5939             Analyze_And_Resolve (N, Typ);
5940             return;
5941          end if;
5942
5943          --  Deal with annoying case of largest negative number remainder
5944          --  minus one. Gigi does not handle this case correctly, because
5945          --  it generates a divide instruction which may trap in this case.
5946
5947          --  In fact the check is quite easy, if the right operand is -1, then
5948          --  the mod value is always 0, and we can just ignore the left operand
5949          --  completely in this case.
5950
5951          --  The operand type may be private (e.g. in the expansion of an
5952          --  intrinsic operation) so we must use the underlying type to get the
5953          --  bounds, and convert the literals explicitly.
5954
5955          LLB :=
5956            Expr_Value
5957              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
5958
5959          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
5960            and then
5961             ((not LOK) or else (Llo = LLB))
5962          then
5963             Rewrite (N,
5964               Make_Conditional_Expression (Loc,
5965                 Expressions => New_List (
5966                   Make_Op_Eq (Loc,
5967                     Left_Opnd => Duplicate_Subexpr (Right),
5968                     Right_Opnd =>
5969                       Unchecked_Convert_To (Typ,
5970                         Make_Integer_Literal (Loc, -1))),
5971                   Unchecked_Convert_To (Typ,
5972                     Make_Integer_Literal (Loc, Uint_0)),
5973                   Relocate_Node (N))));
5974
5975             Set_Analyzed (Next (Next (First (Expressions (N)))));
5976             Analyze_And_Resolve (N, Typ);
5977          end if;
5978       end if;
5979    end Expand_N_Op_Mod;
5980
5981    --------------------------
5982    -- Expand_N_Op_Multiply --
5983    --------------------------
5984
5985    procedure Expand_N_Op_Multiply (N : Node_Id) is
5986       Loc  : constant Source_Ptr := Sloc (N);
5987       Lop  : constant Node_Id    := Left_Opnd (N);
5988       Rop  : constant Node_Id    := Right_Opnd (N);
5989
5990       Lp2  : constant Boolean :=
5991                Nkind (Lop) = N_Op_Expon
5992                  and then Is_Power_Of_2_For_Shift (Lop);
5993
5994       Rp2  : constant Boolean :=
5995                Nkind (Rop) = N_Op_Expon
5996                  and then Is_Power_Of_2_For_Shift (Rop);
5997
5998       Ltyp : constant Entity_Id  := Etype (Lop);
5999       Rtyp : constant Entity_Id  := Etype (Rop);
6000       Typ  : Entity_Id           := Etype (N);
6001
6002    begin
6003       Binary_Op_Validity_Checks (N);
6004
6005       --  Special optimizations for integer types
6006
6007       if Is_Integer_Type (Typ) then
6008
6009          --  N * 0 = 0 * N = 0 for integer types
6010
6011          if (Compile_Time_Known_Value (Rop)
6012               and then Expr_Value (Rop) = Uint_0)
6013            or else
6014             (Compile_Time_Known_Value (Lop)
6015               and then Expr_Value (Lop) = Uint_0)
6016          then
6017             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
6018             Analyze_And_Resolve (N, Typ);
6019             return;
6020          end if;
6021
6022          --  N * 1 = 1 * N = N for integer types
6023
6024          --  This optimisation is not done if we are going to
6025          --  rewrite the product 1 * 2 ** N to a shift.
6026
6027          if Compile_Time_Known_Value (Rop)
6028            and then Expr_Value (Rop) = Uint_1
6029            and then not Lp2
6030          then
6031             Rewrite (N, Lop);
6032             return;
6033
6034          elsif Compile_Time_Known_Value (Lop)
6035            and then Expr_Value (Lop) = Uint_1
6036            and then not Rp2
6037          then
6038             Rewrite (N, Rop);
6039             return;
6040          end if;
6041       end if;
6042
6043       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6044       --  Is_Power_Of_2_For_Shift is set means that we know that our left
6045       --  operand is an integer, as required for this to work.
6046
6047       if Rp2 then
6048          if Lp2 then
6049
6050             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
6051
6052             Rewrite (N,
6053               Make_Op_Expon (Loc,
6054                 Left_Opnd => Make_Integer_Literal (Loc, 2),
6055                 Right_Opnd =>
6056                   Make_Op_Add (Loc,
6057                     Left_Opnd  => Right_Opnd (Lop),
6058                     Right_Opnd => Right_Opnd (Rop))));
6059             Analyze_And_Resolve (N, Typ);
6060             return;
6061
6062          else
6063             Rewrite (N,
6064               Make_Op_Shift_Left (Loc,
6065                 Left_Opnd  => Lop,
6066                 Right_Opnd =>
6067                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
6068             Analyze_And_Resolve (N, Typ);
6069             return;
6070          end if;
6071
6072       --  Same processing for the operands the other way round
6073
6074       elsif Lp2 then
6075          Rewrite (N,
6076            Make_Op_Shift_Left (Loc,
6077              Left_Opnd  => Rop,
6078              Right_Opnd =>
6079                Convert_To (Standard_Natural, Right_Opnd (Lop))));
6080          Analyze_And_Resolve (N, Typ);
6081          return;
6082       end if;
6083
6084       --  Do required fixup of universal fixed operation
6085
6086       if Typ = Universal_Fixed then
6087          Fixup_Universal_Fixed_Operation (N);
6088          Typ := Etype (N);
6089       end if;
6090
6091       --  Multiplications with fixed-point results
6092
6093       if Is_Fixed_Point_Type (Typ) then
6094
6095          --  No special processing if Treat_Fixed_As_Integer is set, since from
6096          --  a semantic point of view such operations are simply integer
6097          --  operations and will be treated that way.
6098
6099          if not Treat_Fixed_As_Integer (N) then
6100
6101             --  Case of fixed * integer => fixed
6102
6103             if Is_Integer_Type (Rtyp) then
6104                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
6105
6106             --  Case of integer * fixed => fixed
6107
6108             elsif Is_Integer_Type (Ltyp) then
6109                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
6110
6111             --  Case of fixed * fixed => fixed
6112
6113             else
6114                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
6115             end if;
6116          end if;
6117
6118       --  Other cases of multiplication of fixed-point operands. Again we
6119       --  exclude the cases where Treat_Fixed_As_Integer flag is set.
6120
6121       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6122         and then not Treat_Fixed_As_Integer (N)
6123       then
6124          if Is_Integer_Type (Typ) then
6125             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
6126          else
6127             pragma Assert (Is_Floating_Point_Type (Typ));
6128             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
6129          end if;
6130
6131       --  Mixed-mode operations can appear in a non-static universal context,
6132       --  in which case the integer argument must be converted explicitly.
6133
6134       elsif Typ = Universal_Real
6135         and then Is_Integer_Type (Rtyp)
6136       then
6137          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
6138
6139          Analyze_And_Resolve (Rop, Universal_Real);
6140
6141       elsif Typ = Universal_Real
6142         and then Is_Integer_Type (Ltyp)
6143       then
6144          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
6145
6146          Analyze_And_Resolve (Lop, Universal_Real);
6147
6148       --  Non-fixed point cases, check software overflow checking required
6149
6150       elsif Is_Signed_Integer_Type (Etype (N)) then
6151          Apply_Arithmetic_Overflow_Check (N);
6152
6153       --  Deal with VAX float case
6154
6155       elsif Vax_Float (Typ) then
6156          Expand_Vax_Arith (N);
6157          return;
6158       end if;
6159    end Expand_N_Op_Multiply;
6160
6161    --------------------
6162    -- Expand_N_Op_Ne --
6163    --------------------
6164
6165    procedure Expand_N_Op_Ne (N : Node_Id) is
6166       Typ : constant Entity_Id := Etype (Left_Opnd (N));
6167
6168    begin
6169       --  Case of elementary type with standard operator
6170
6171       if Is_Elementary_Type (Typ)
6172         and then Sloc (Entity (N)) = Standard_Location
6173       then
6174          Binary_Op_Validity_Checks (N);
6175
6176          --  Boolean types (requiring handling of non-standard case)
6177
6178          if Is_Boolean_Type (Typ) then
6179             Adjust_Condition (Left_Opnd (N));
6180             Adjust_Condition (Right_Opnd (N));
6181             Set_Etype (N, Standard_Boolean);
6182             Adjust_Result_Type (N, Typ);
6183          end if;
6184
6185          Rewrite_Comparison (N);
6186
6187          --  If we still have comparison for Vax_Float, process it
6188
6189          if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare  then
6190             Expand_Vax_Comparison (N);
6191             return;
6192          end if;
6193
6194       --  For all cases other than elementary types, we rewrite node as the
6195       --  negation of an equality operation, and reanalyze. The equality to be
6196       --  used is defined in the same scope and has the same signature. This
6197       --  signature must be set explicitly since in an instance it may not have
6198       --  the same visibility as in the generic unit. This avoids duplicating
6199       --  or factoring the complex code for record/array equality tests etc.
6200
6201       else
6202          declare
6203             Loc : constant Source_Ptr := Sloc (N);
6204             Neg : Node_Id;
6205             Ne  : constant Entity_Id := Entity (N);
6206
6207          begin
6208             Binary_Op_Validity_Checks (N);
6209
6210             Neg :=
6211               Make_Op_Not (Loc,
6212                 Right_Opnd =>
6213                   Make_Op_Eq (Loc,
6214                     Left_Opnd =>  Left_Opnd (N),
6215                     Right_Opnd => Right_Opnd (N)));
6216             Set_Paren_Count (Right_Opnd (Neg), 1);
6217
6218             if Scope (Ne) /= Standard_Standard then
6219                Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
6220             end if;
6221
6222             --  For navigation purposes, the inequality is treated as an
6223             --  implicit reference to the corresponding equality. Preserve the
6224             --  Comes_From_ source flag so that the proper Xref entry is
6225             --  generated.
6226
6227             Preserve_Comes_From_Source (Neg, N);
6228             Preserve_Comes_From_Source (Right_Opnd (Neg), N);
6229             Rewrite (N, Neg);
6230             Analyze_And_Resolve (N, Standard_Boolean);
6231          end;
6232       end if;
6233    end Expand_N_Op_Ne;
6234
6235    ---------------------
6236    -- Expand_N_Op_Not --
6237    ---------------------
6238
6239    --  If the argument is other than a Boolean array type, there is no special
6240    --  expansion required.
6241
6242    --  For the packed case, we call the special routine in Exp_Pakd, except
6243    --  that if the component size is greater than one, we use the standard
6244    --  routine generating a gruesome loop (it is so peculiar to have packed
6245    --  arrays with non-standard Boolean representations anyway, so it does not
6246    --  matter that we do not handle this case efficiently).
6247
6248    --  For the unpacked case (and for the special packed case where we have non
6249    --  standard Booleans, as discussed above), we generate and insert into the
6250    --  tree the following function definition:
6251
6252    --     function Nnnn (A : arr) is
6253    --       B : arr;
6254    --     begin
6255    --       for J in a'range loop
6256    --          B (J) := not A (J);
6257    --       end loop;
6258    --       return B;
6259    --     end Nnnn;
6260
6261    --  Here arr is the actual subtype of the parameter (and hence always
6262    --  constrained). Then we replace the not with a call to this function.
6263
6264    procedure Expand_N_Op_Not (N : Node_Id) is
6265       Loc  : constant Source_Ptr := Sloc (N);
6266       Typ  : constant Entity_Id  := Etype (N);
6267       Opnd : Node_Id;
6268       Arr  : Entity_Id;
6269       A    : Entity_Id;
6270       B    : Entity_Id;
6271       J    : Entity_Id;
6272       A_J  : Node_Id;
6273       B_J  : Node_Id;
6274
6275       Func_Name      : Entity_Id;
6276       Loop_Statement : Node_Id;
6277
6278    begin
6279       Unary_Op_Validity_Checks (N);
6280
6281       --  For boolean operand, deal with non-standard booleans
6282
6283       if Is_Boolean_Type (Typ) then
6284          Adjust_Condition (Right_Opnd (N));
6285          Set_Etype (N, Standard_Boolean);
6286          Adjust_Result_Type (N, Typ);
6287          return;
6288       end if;
6289
6290       --  Only array types need any other processing
6291
6292       if not Is_Array_Type (Typ) then
6293          return;
6294       end if;
6295
6296       --  Case of array operand. If bit packed with a component size of 1,
6297       --  handle it in Exp_Pakd if the operand is known to be aligned.
6298
6299       if Is_Bit_Packed_Array (Typ)
6300         and then Component_Size (Typ) = 1
6301         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
6302       then
6303          Expand_Packed_Not (N);
6304          return;
6305       end if;
6306
6307       --  Case of array operand which is not bit-packed. If the context is
6308       --  a safe assignment, call in-place operation, If context is a larger
6309       --  boolean expression in the context of a safe assignment, expansion is
6310       --  done by enclosing operation.
6311
6312       Opnd := Relocate_Node (Right_Opnd (N));
6313       Convert_To_Actual_Subtype (Opnd);
6314       Arr := Etype (Opnd);
6315       Ensure_Defined (Arr, N);
6316       Silly_Boolean_Array_Not_Test (N, Arr);
6317
6318       if Nkind (Parent (N)) = N_Assignment_Statement then
6319          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
6320             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6321             return;
6322
6323          --  Special case the negation of a binary operation
6324
6325          elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
6326            and then Safe_In_Place_Array_Op
6327                       (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
6328          then
6329             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6330             return;
6331          end if;
6332
6333       elsif Nkind (Parent (N)) in N_Binary_Op
6334         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
6335       then
6336          declare
6337             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
6338             Op2 : constant Node_Id := Right_Opnd (Parent (N));
6339             Lhs : constant Node_Id := Name (Parent (Parent (N)));
6340
6341          begin
6342             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
6343                if N = Op1
6344                  and then Nkind (Op2) = N_Op_Not
6345                then
6346                   --  (not A) op (not B) can be reduced to a single call
6347
6348                   return;
6349
6350                elsif N = Op2
6351                  and then Nkind (Parent (N)) = N_Op_Xor
6352                then
6353                   --  A xor (not B) can also be special-cased
6354
6355                   return;
6356                end if;
6357             end if;
6358          end;
6359       end if;
6360
6361       A := Make_Defining_Identifier (Loc, Name_uA);
6362       B := Make_Defining_Identifier (Loc, Name_uB);
6363       J := Make_Defining_Identifier (Loc, Name_uJ);
6364
6365       A_J :=
6366         Make_Indexed_Component (Loc,
6367           Prefix      => New_Reference_To (A, Loc),
6368           Expressions => New_List (New_Reference_To (J, Loc)));
6369
6370       B_J :=
6371         Make_Indexed_Component (Loc,
6372           Prefix      => New_Reference_To (B, Loc),
6373           Expressions => New_List (New_Reference_To (J, Loc)));
6374
6375       Loop_Statement :=
6376         Make_Implicit_Loop_Statement (N,
6377           Identifier => Empty,
6378
6379           Iteration_Scheme =>
6380             Make_Iteration_Scheme (Loc,
6381               Loop_Parameter_Specification =>
6382                 Make_Loop_Parameter_Specification (Loc,
6383                   Defining_Identifier => J,
6384                   Discrete_Subtype_Definition =>
6385                     Make_Attribute_Reference (Loc,
6386                       Prefix => Make_Identifier (Loc, Chars (A)),
6387                       Attribute_Name => Name_Range))),
6388
6389           Statements => New_List (
6390             Make_Assignment_Statement (Loc,
6391               Name       => B_J,
6392               Expression => Make_Op_Not (Loc, A_J))));
6393
6394       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
6395       Set_Is_Inlined (Func_Name);
6396
6397       Insert_Action (N,
6398         Make_Subprogram_Body (Loc,
6399           Specification =>
6400             Make_Function_Specification (Loc,
6401               Defining_Unit_Name => Func_Name,
6402               Parameter_Specifications => New_List (
6403                 Make_Parameter_Specification (Loc,
6404                   Defining_Identifier => A,
6405                   Parameter_Type      => New_Reference_To (Typ, Loc))),
6406               Result_Definition => New_Reference_To (Typ, Loc)),
6407
6408           Declarations => New_List (
6409             Make_Object_Declaration (Loc,
6410               Defining_Identifier => B,
6411               Object_Definition   => New_Reference_To (Arr, Loc))),
6412
6413           Handled_Statement_Sequence =>
6414             Make_Handled_Sequence_Of_Statements (Loc,
6415               Statements => New_List (
6416                 Loop_Statement,
6417                 Make_Simple_Return_Statement (Loc,
6418                   Expression =>
6419                     Make_Identifier (Loc, Chars (B)))))));
6420
6421       Rewrite (N,
6422         Make_Function_Call (Loc,
6423           Name => New_Reference_To (Func_Name, Loc),
6424           Parameter_Associations => New_List (Opnd)));
6425
6426       Analyze_And_Resolve (N, Typ);
6427    end Expand_N_Op_Not;
6428
6429    --------------------
6430    -- Expand_N_Op_Or --
6431    --------------------
6432
6433    procedure Expand_N_Op_Or (N : Node_Id) is
6434       Typ : constant Entity_Id := Etype (N);
6435
6436    begin
6437       Binary_Op_Validity_Checks (N);
6438
6439       if Is_Array_Type (Etype (N)) then
6440          Expand_Boolean_Operator (N);
6441
6442       elsif Is_Boolean_Type (Etype (N)) then
6443          Adjust_Condition (Left_Opnd (N));
6444          Adjust_Condition (Right_Opnd (N));
6445          Set_Etype (N, Standard_Boolean);
6446          Adjust_Result_Type (N, Typ);
6447       end if;
6448    end Expand_N_Op_Or;
6449
6450    ----------------------
6451    -- Expand_N_Op_Plus --
6452    ----------------------
6453
6454    procedure Expand_N_Op_Plus (N : Node_Id) is
6455    begin
6456       Unary_Op_Validity_Checks (N);
6457    end Expand_N_Op_Plus;
6458
6459    ---------------------
6460    -- Expand_N_Op_Rem --
6461    ---------------------
6462
6463    procedure Expand_N_Op_Rem (N : Node_Id) is
6464       Loc : constant Source_Ptr := Sloc (N);
6465       Typ : constant Entity_Id  := Etype (N);
6466
6467       Left  : constant Node_Id := Left_Opnd (N);
6468       Right : constant Node_Id := Right_Opnd (N);
6469
6470       LLB : Uint;
6471       Llo : Uint;
6472       Lhi : Uint;
6473       LOK : Boolean;
6474       Rlo : Uint;
6475       Rhi : Uint;
6476       ROK : Boolean;
6477
6478       pragma Warnings (Off, Lhi);
6479
6480    begin
6481       Binary_Op_Validity_Checks (N);
6482
6483       if Is_Integer_Type (Etype (N)) then
6484          Apply_Divide_Check (N);
6485       end if;
6486
6487       --  Apply optimization x rem 1 = 0. We don't really need that with gcc,
6488       --  but it is useful with other back ends (e.g. AAMP), and is certainly
6489       --  harmless.
6490
6491       if Is_Integer_Type (Etype (N))
6492         and then Compile_Time_Known_Value (Right)
6493         and then Expr_Value (Right) = Uint_1
6494       then
6495          Rewrite (N, Make_Integer_Literal (Loc, 0));
6496          Analyze_And_Resolve (N, Typ);
6497          return;
6498       end if;
6499
6500       --  Deal with annoying case of largest negative number remainder minus
6501       --  one. Gigi does not handle this case correctly, because it generates
6502       --  a divide instruction which may trap in this case.
6503
6504       --  In fact the check is quite easy, if the right operand is -1, then
6505       --  the remainder is always 0, and we can just ignore the left operand
6506       --  completely in this case.
6507
6508       Determine_Range (Right, ROK, Rlo, Rhi);
6509       Determine_Range (Left, LOK, Llo, Lhi);
6510
6511       --  The operand type may be private (e.g. in the expansion of an an
6512       --  intrinsic operation) so we must use the underlying type to get the
6513       --  bounds, and convert the literals explicitly.
6514
6515       LLB :=
6516         Expr_Value
6517           (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
6518
6519       --  Now perform the test, generating code only if needed
6520
6521       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
6522         and then
6523          ((not LOK) or else (Llo = LLB))
6524       then
6525          Rewrite (N,
6526            Make_Conditional_Expression (Loc,
6527              Expressions => New_List (
6528                Make_Op_Eq (Loc,
6529                  Left_Opnd => Duplicate_Subexpr (Right),
6530                  Right_Opnd =>
6531                    Unchecked_Convert_To (Typ,
6532                      Make_Integer_Literal (Loc, -1))),
6533
6534                Unchecked_Convert_To (Typ,
6535                  Make_Integer_Literal (Loc, Uint_0)),
6536
6537                Relocate_Node (N))));
6538
6539          Set_Analyzed (Next (Next (First (Expressions (N)))));
6540          Analyze_And_Resolve (N, Typ);
6541       end if;
6542    end Expand_N_Op_Rem;
6543
6544    -----------------------------
6545    -- Expand_N_Op_Rotate_Left --
6546    -----------------------------
6547
6548    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
6549    begin
6550       Binary_Op_Validity_Checks (N);
6551    end Expand_N_Op_Rotate_Left;
6552
6553    ------------------------------
6554    -- Expand_N_Op_Rotate_Right --
6555    ------------------------------
6556
6557    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
6558    begin
6559       Binary_Op_Validity_Checks (N);
6560    end Expand_N_Op_Rotate_Right;
6561
6562    ----------------------------
6563    -- Expand_N_Op_Shift_Left --
6564    ----------------------------
6565
6566    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
6567    begin
6568       Binary_Op_Validity_Checks (N);
6569    end Expand_N_Op_Shift_Left;
6570
6571    -----------------------------
6572    -- Expand_N_Op_Shift_Right --
6573    -----------------------------
6574
6575    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
6576    begin
6577       Binary_Op_Validity_Checks (N);
6578    end Expand_N_Op_Shift_Right;
6579
6580    ----------------------------------------
6581    -- Expand_N_Op_Shift_Right_Arithmetic --
6582    ----------------------------------------
6583
6584    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
6585    begin
6586       Binary_Op_Validity_Checks (N);
6587    end Expand_N_Op_Shift_Right_Arithmetic;
6588
6589    --------------------------
6590    -- Expand_N_Op_Subtract --
6591    --------------------------
6592
6593    procedure Expand_N_Op_Subtract (N : Node_Id) is
6594       Typ : constant Entity_Id := Etype (N);
6595
6596    begin
6597       Binary_Op_Validity_Checks (N);
6598
6599       --  N - 0 = N for integer types
6600
6601       if Is_Integer_Type (Typ)
6602         and then Compile_Time_Known_Value (Right_Opnd (N))
6603         and then Expr_Value (Right_Opnd (N)) = 0
6604       then
6605          Rewrite (N, Left_Opnd (N));
6606          return;
6607       end if;
6608
6609       --  Arithmetic overflow checks for signed integer/fixed point types
6610
6611       if Is_Signed_Integer_Type (Typ)
6612         or else Is_Fixed_Point_Type (Typ)
6613       then
6614          Apply_Arithmetic_Overflow_Check (N);
6615
6616       --  Vax floating-point types case
6617
6618       elsif Vax_Float (Typ) then
6619          Expand_Vax_Arith (N);
6620       end if;
6621    end Expand_N_Op_Subtract;
6622
6623    ---------------------
6624    -- Expand_N_Op_Xor --
6625    ---------------------
6626
6627    procedure Expand_N_Op_Xor (N : Node_Id) is
6628       Typ : constant Entity_Id := Etype (N);
6629
6630    begin
6631       Binary_Op_Validity_Checks (N);
6632
6633       if Is_Array_Type (Etype (N)) then
6634          Expand_Boolean_Operator (N);
6635
6636       elsif Is_Boolean_Type (Etype (N)) then
6637          Adjust_Condition (Left_Opnd (N));
6638          Adjust_Condition (Right_Opnd (N));
6639          Set_Etype (N, Standard_Boolean);
6640          Adjust_Result_Type (N, Typ);
6641       end if;
6642    end Expand_N_Op_Xor;
6643
6644    ----------------------
6645    -- Expand_N_Or_Else --
6646    ----------------------
6647
6648    --  Expand into conditional expression if Actions present, and also
6649    --  deal with optimizing case of arguments being True or False.
6650
6651    procedure Expand_N_Or_Else (N : Node_Id) is
6652       Loc     : constant Source_Ptr := Sloc (N);
6653       Typ     : constant Entity_Id  := Etype (N);
6654       Left    : constant Node_Id    := Left_Opnd (N);
6655       Right   : constant Node_Id    := Right_Opnd (N);
6656       Actlist : List_Id;
6657
6658    begin
6659       --  Deal with non-standard booleans
6660
6661       if Is_Boolean_Type (Typ) then
6662          Adjust_Condition (Left);
6663          Adjust_Condition (Right);
6664          Set_Etype (N, Standard_Boolean);
6665       end if;
6666
6667       --  Check for cases of left argument is True or False
6668
6669       if Nkind (Left) = N_Identifier then
6670
6671          --  If left argument is False, change (False or else Right) to Right.
6672          --  Any actions associated with Right will be executed unconditionally
6673          --  and can thus be inserted into the tree unconditionally.
6674
6675          if Entity (Left) = Standard_False then
6676             if Present (Actions (N)) then
6677                Insert_Actions (N, Actions (N));
6678             end if;
6679
6680             Rewrite (N, Right);
6681             Adjust_Result_Type (N, Typ);
6682             return;
6683
6684          --  If left argument is True, change (True and then Right) to True. In
6685          --  this case we can forget the actions associated with Right, since
6686          --  they will never be executed.
6687
6688          elsif Entity (Left) = Standard_True then
6689             Kill_Dead_Code (Right);
6690             Kill_Dead_Code (Actions (N));
6691             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6692             Adjust_Result_Type (N, Typ);
6693             return;
6694          end if;
6695       end if;
6696
6697       --  If Actions are present, we expand
6698
6699       --     left or else right
6700
6701       --  into
6702
6703       --     if left then True else right end
6704
6705       --  with the actions becoming the Else_Actions of the conditional
6706       --  expression. This conditional expression is then further expanded
6707       --  (and will eventually disappear)
6708
6709       if Present (Actions (N)) then
6710          Actlist := Actions (N);
6711          Rewrite (N,
6712             Make_Conditional_Expression (Loc,
6713               Expressions => New_List (
6714                 Left,
6715                 New_Occurrence_Of (Standard_True, Loc),
6716                 Right)));
6717
6718          Set_Else_Actions (N, Actlist);
6719          Analyze_And_Resolve (N, Standard_Boolean);
6720          Adjust_Result_Type (N, Typ);
6721          return;
6722       end if;
6723
6724       --  No actions present, check for cases of right argument True/False
6725
6726       if Nkind (Right) = N_Identifier then
6727
6728          --  Change (Left or else False) to Left. Note that we know there are
6729          --  no actions associated with the True operand, since we just checked
6730          --  for this case above.
6731
6732          if Entity (Right) = Standard_False then
6733             Rewrite (N, Left);
6734
6735          --  Change (Left or else True) to True, making sure to preserve any
6736          --  side effects associated with the Left operand.
6737
6738          elsif Entity (Right) = Standard_True then
6739             Remove_Side_Effects (Left);
6740             Rewrite
6741               (N, New_Occurrence_Of (Standard_True, Loc));
6742          end if;
6743       end if;
6744
6745       Adjust_Result_Type (N, Typ);
6746    end Expand_N_Or_Else;
6747
6748    -----------------------------------
6749    -- Expand_N_Qualified_Expression --
6750    -----------------------------------
6751
6752    procedure Expand_N_Qualified_Expression (N : Node_Id) is
6753       Operand     : constant Node_Id   := Expression (N);
6754       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
6755
6756    begin
6757       --  Do validity check if validity checking operands
6758
6759       if Validity_Checks_On
6760         and then Validity_Check_Operands
6761       then
6762          Ensure_Valid (Operand);
6763       end if;
6764
6765       --  Apply possible constraint check
6766
6767       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
6768    end Expand_N_Qualified_Expression;
6769
6770    ---------------------------------
6771    -- Expand_N_Selected_Component --
6772    ---------------------------------
6773
6774    --  If the selector is a discriminant of a concurrent object, rewrite the
6775    --  prefix to denote the corresponding record type.
6776
6777    procedure Expand_N_Selected_Component (N : Node_Id) is
6778       Loc   : constant Source_Ptr := Sloc (N);
6779       Par   : constant Node_Id    := Parent (N);
6780       P     : constant Node_Id    := Prefix (N);
6781       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
6782       Disc  : Entity_Id;
6783       New_N : Node_Id;
6784       Dcon  : Elmt_Id;
6785
6786       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
6787       --  Gigi needs a temporary for prefixes that depend on a discriminant,
6788       --  unless the context of an assignment can provide size information.
6789       --  Don't we have a general routine that does this???
6790
6791       -----------------------
6792       -- In_Left_Hand_Side --
6793       -----------------------
6794
6795       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
6796       begin
6797          return (Nkind (Parent (Comp)) = N_Assignment_Statement
6798                    and then Comp = Name (Parent (Comp)))
6799            or else (Present (Parent (Comp))
6800                       and then Nkind (Parent (Comp)) in N_Subexpr
6801                       and then In_Left_Hand_Side (Parent (Comp)));
6802       end In_Left_Hand_Side;
6803
6804    --  Start of processing for Expand_N_Selected_Component
6805
6806    begin
6807       --  Insert explicit dereference if required
6808
6809       if Is_Access_Type (Ptyp) then
6810          Insert_Explicit_Dereference (P);
6811          Analyze_And_Resolve (P, Designated_Type (Ptyp));
6812
6813          if Ekind (Etype (P)) = E_Private_Subtype
6814            and then Is_For_Access_Subtype (Etype (P))
6815          then
6816             Set_Etype (P, Base_Type (Etype (P)));
6817          end if;
6818
6819          Ptyp := Etype (P);
6820       end if;
6821
6822       --  Deal with discriminant check required
6823
6824       if Do_Discriminant_Check (N) then
6825
6826          --  Present the discriminant checking function to the backend, so that
6827          --  it can inline the call to the function.
6828
6829          Add_Inlined_Body
6830            (Discriminant_Checking_Func
6831              (Original_Record_Component (Entity (Selector_Name (N)))));
6832
6833          --  Now reset the flag and generate the call
6834
6835          Set_Do_Discriminant_Check (N, False);
6836          Generate_Discriminant_Check (N);
6837       end if;
6838
6839       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6840       --  function, then additional actuals must be passed.
6841
6842       if Ada_Version >= Ada_05
6843         and then Is_Build_In_Place_Function_Call (P)
6844       then
6845          Make_Build_In_Place_Call_In_Anonymous_Context (P);
6846       end if;
6847
6848       --  Gigi cannot handle unchecked conversions that are the prefix of a
6849       --  selected component with discriminants. This must be checked during
6850       --  expansion, because during analysis the type of the selector is not
6851       --  known at the point the prefix is analyzed. If the conversion is the
6852       --  target of an assignment, then we cannot force the evaluation.
6853
6854       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
6855         and then Has_Discriminants (Etype (N))
6856         and then not In_Left_Hand_Side (N)
6857       then
6858          Force_Evaluation (Prefix (N));
6859       end if;
6860
6861       --  Remaining processing applies only if selector is a discriminant
6862
6863       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
6864
6865          --  If the selector is a discriminant of a constrained record type,
6866          --  we may be able to rewrite the expression with the actual value
6867          --  of the discriminant, a useful optimization in some cases.
6868
6869          if Is_Record_Type (Ptyp)
6870            and then Has_Discriminants (Ptyp)
6871            and then Is_Constrained (Ptyp)
6872          then
6873             --  Do this optimization for discrete types only, and not for
6874             --  access types (access discriminants get us into trouble!)
6875
6876             if not Is_Discrete_Type (Etype (N)) then
6877                null;
6878
6879             --  Don't do this on the left hand of an assignment statement.
6880             --  Normally one would think that references like this would
6881             --  not occur, but they do in generated code, and mean that
6882             --  we really do want to assign the discriminant!
6883
6884             elsif Nkind (Par) = N_Assignment_Statement
6885               and then Name (Par) = N
6886             then
6887                null;
6888
6889             --  Don't do this optimization for the prefix of an attribute or
6890             --  the operand of an object renaming declaration since these are
6891             --  contexts where we do not want the value anyway.
6892
6893             elsif (Nkind (Par) = N_Attribute_Reference
6894                      and then Prefix (Par) = N)
6895               or else Is_Renamed_Object (N)
6896             then
6897                null;
6898
6899             --  Don't do this optimization if we are within the code for a
6900             --  discriminant check, since the whole point of such a check may
6901             --  be to verify the condition on which the code below depends!
6902
6903             elsif Is_In_Discriminant_Check (N) then
6904                null;
6905
6906             --  Green light to see if we can do the optimization. There is
6907             --  still one condition that inhibits the optimization below but
6908             --  now is the time to check the particular discriminant.
6909
6910             else
6911                --  Loop through discriminants to find the matching discriminant
6912                --  constraint to see if we can copy it.
6913
6914                Disc := First_Discriminant (Ptyp);
6915                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
6916                Discr_Loop : while Present (Dcon) loop
6917
6918                   --  Check if this is the matching discriminant
6919
6920                   if Disc = Entity (Selector_Name (N)) then
6921
6922                      --  Here we have the matching discriminant. Check for
6923                      --  the case of a discriminant of a component that is
6924                      --  constrained by an outer discriminant, which cannot
6925                      --  be optimized away.
6926
6927                      if
6928                        Denotes_Discriminant
6929                         (Node (Dcon), Check_Concurrent => True)
6930                      then
6931                         exit Discr_Loop;
6932
6933                      --  In the context of a case statement, the expression may
6934                      --  have the base type of the discriminant, and we need to
6935                      --  preserve the constraint to avoid spurious errors on
6936                      --  missing cases.
6937
6938                      elsif Nkind (Parent (N)) = N_Case_Statement
6939                        and then Etype (Node (Dcon)) /= Etype (Disc)
6940                      then
6941                         Rewrite (N,
6942                           Make_Qualified_Expression (Loc,
6943                             Subtype_Mark =>
6944                               New_Occurrence_Of (Etype (Disc), Loc),
6945                             Expression   =>
6946                               New_Copy_Tree (Node (Dcon))));
6947                         Analyze_And_Resolve (N, Etype (Disc));
6948
6949                         --  In case that comes out as a static expression,
6950                         --  reset it (a selected component is never static).
6951
6952                         Set_Is_Static_Expression (N, False);
6953                         return;
6954
6955                      --  Otherwise we can just copy the constraint, but the
6956                      --  result is certainly not static! In some cases the
6957                      --  discriminant constraint has been analyzed in the
6958                      --  context of the original subtype indication, but for
6959                      --  itypes the constraint might not have been analyzed
6960                      --  yet, and this must be done now.
6961
6962                      else
6963                         Rewrite (N, New_Copy_Tree (Node (Dcon)));
6964                         Analyze_And_Resolve (N);
6965                         Set_Is_Static_Expression (N, False);
6966                         return;
6967                      end if;
6968                   end if;
6969
6970                   Next_Elmt (Dcon);
6971                   Next_Discriminant (Disc);
6972                end loop Discr_Loop;
6973
6974                --  Note: the above loop should always find a matching
6975                --  discriminant, but if it does not, we just missed an
6976                --  optimization due to some glitch (perhaps a previous error),
6977                --  so ignore.
6978
6979             end if;
6980          end if;
6981
6982          --  The only remaining processing is in the case of a discriminant of
6983          --  a concurrent object, where we rewrite the prefix to denote the
6984          --  corresponding record type. If the type is derived and has renamed
6985          --  discriminants, use corresponding discriminant, which is the one
6986          --  that appears in the corresponding record.
6987
6988          if not Is_Concurrent_Type (Ptyp) then
6989             return;
6990          end if;
6991
6992          Disc := Entity (Selector_Name (N));
6993
6994          if Is_Derived_Type (Ptyp)
6995            and then Present (Corresponding_Discriminant (Disc))
6996          then
6997             Disc := Corresponding_Discriminant (Disc);
6998          end if;
6999
7000          New_N :=
7001            Make_Selected_Component (Loc,
7002              Prefix =>
7003                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
7004                  New_Copy_Tree (P)),
7005              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
7006
7007          Rewrite (N, New_N);
7008          Analyze (N);
7009       end if;
7010    end Expand_N_Selected_Component;
7011
7012    --------------------
7013    -- Expand_N_Slice --
7014    --------------------
7015
7016    procedure Expand_N_Slice (N : Node_Id) is
7017       Loc  : constant Source_Ptr := Sloc (N);
7018       Typ  : constant Entity_Id  := Etype (N);
7019       Pfx  : constant Node_Id    := Prefix (N);
7020       Ptp  : Entity_Id           := Etype (Pfx);
7021
7022       function Is_Procedure_Actual (N : Node_Id) return Boolean;
7023       --  Check whether the argument is an actual for a procedure call, in
7024       --  which case the expansion of a bit-packed slice is deferred until the
7025       --  call itself is expanded. The reason this is required is that we might
7026       --  have an IN OUT or OUT parameter, and the copy out is essential, and
7027       --  that copy out would be missed if we created a temporary here in
7028       --  Expand_N_Slice. Note that we don't bother to test specifically for an
7029       --  IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7030       --  is harmless to defer expansion in the IN case, since the call
7031       --  processing will still generate the appropriate copy in operation,
7032       --  which will take care of the slice.
7033
7034       procedure Make_Temporary;
7035       --  Create a named variable for the value of the slice, in cases where
7036       --  the back-end cannot handle it properly, e.g. when packed types or
7037       --  unaligned slices are involved.
7038
7039       -------------------------
7040       -- Is_Procedure_Actual --
7041       -------------------------
7042
7043       function Is_Procedure_Actual (N : Node_Id) return Boolean is
7044          Par : Node_Id := Parent (N);
7045
7046       begin
7047          loop
7048             --  If our parent is a procedure call we can return
7049
7050             if Nkind (Par) = N_Procedure_Call_Statement then
7051                return True;
7052
7053             --  If our parent is a type conversion, keep climbing the tree,
7054             --  since a type conversion can be a procedure actual. Also keep
7055             --  climbing if parameter association or a qualified expression,
7056             --  since these are additional cases that do can appear on
7057             --  procedure actuals.
7058
7059             elsif Nkind_In (Par, N_Type_Conversion,
7060                                  N_Parameter_Association,
7061                                  N_Qualified_Expression)
7062             then
7063                Par := Parent (Par);
7064
7065                --  Any other case is not what we are looking for
7066
7067             else
7068                return False;
7069             end if;
7070          end loop;
7071       end Is_Procedure_Actual;
7072
7073       --------------------
7074       -- Make_Temporary --
7075       --------------------
7076
7077       procedure Make_Temporary is
7078          Decl : Node_Id;
7079          Ent  : constant Entity_Id :=
7080                   Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
7081       begin
7082          Decl :=
7083            Make_Object_Declaration (Loc,
7084              Defining_Identifier => Ent,
7085              Object_Definition   => New_Occurrence_Of (Typ, Loc));
7086
7087          Set_No_Initialization (Decl);
7088
7089          Insert_Actions (N, New_List (
7090            Decl,
7091            Make_Assignment_Statement (Loc,
7092              Name => New_Occurrence_Of (Ent, Loc),
7093              Expression => Relocate_Node (N))));
7094
7095          Rewrite (N, New_Occurrence_Of (Ent, Loc));
7096          Analyze_And_Resolve (N, Typ);
7097       end Make_Temporary;
7098
7099    --  Start of processing for Expand_N_Slice
7100
7101    begin
7102       --  Special handling for access types
7103
7104       if Is_Access_Type (Ptp) then
7105
7106          Ptp := Designated_Type (Ptp);
7107
7108          Rewrite (Pfx,
7109            Make_Explicit_Dereference (Sloc (N),
7110             Prefix => Relocate_Node (Pfx)));
7111
7112          Analyze_And_Resolve (Pfx, Ptp);
7113       end if;
7114
7115       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7116       --  function, then additional actuals must be passed.
7117
7118       if Ada_Version >= Ada_05
7119         and then Is_Build_In_Place_Function_Call (Pfx)
7120       then
7121          Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
7122       end if;
7123
7124       --  Range checks are potentially also needed for cases involving a slice
7125       --  indexed by a subtype indication, but Do_Range_Check can currently
7126       --  only be set for expressions ???
7127
7128       if not Index_Checks_Suppressed (Ptp)
7129         and then (not Is_Entity_Name (Pfx)
7130                    or else not Index_Checks_Suppressed (Entity (Pfx)))
7131         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
7132
7133          --  Do not enable range check to nodes associated with the frontend
7134          --  expansion of the dispatch table. We first check if Ada.Tags is
7135          --  already loaded to avoid the addition of an undesired dependence
7136          --  on such run-time unit.
7137
7138         and then
7139           (VM_Target /= No_VM
7140             or else not
7141              (RTU_Loaded (Ada_Tags)
7142                and then Nkind (Prefix (N)) = N_Selected_Component
7143                and then Present (Entity (Selector_Name (Prefix (N))))
7144                and then Entity (Selector_Name (Prefix (N))) =
7145                                   RTE_Record_Component (RE_Prims_Ptr)))
7146       then
7147          Enable_Range_Check (Discrete_Range (N));
7148       end if;
7149
7150       --  The remaining case to be handled is packed slices. We can leave
7151       --  packed slices as they are in the following situations:
7152
7153       --    1. Right or left side of an assignment (we can handle this
7154       --       situation correctly in the assignment statement expansion).
7155
7156       --    2. Prefix of indexed component (the slide is optimized away in this
7157       --       case, see the start of Expand_N_Slice.)
7158
7159       --    3. Object renaming declaration, since we want the name of the
7160       --       slice, not the value.
7161
7162       --    4. Argument to procedure call, since copy-in/copy-out handling may
7163       --       be required, and this is handled in the expansion of call
7164       --       itself.
7165
7166       --    5. Prefix of an address attribute (this is an error which is caught
7167       --       elsewhere, and the expansion would interfere with generating the
7168       --       error message).
7169
7170       if not Is_Packed (Typ) then
7171
7172          --  Apply transformation for actuals of a function call, where
7173          --  Expand_Actuals is not used.
7174
7175          if Nkind (Parent (N)) = N_Function_Call
7176            and then Is_Possibly_Unaligned_Slice (N)
7177          then
7178             Make_Temporary;
7179          end if;
7180
7181       elsif Nkind (Parent (N)) = N_Assignment_Statement
7182         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
7183                    and then Parent (N) = Name (Parent (Parent (N))))
7184       then
7185          return;
7186
7187       elsif Nkind (Parent (N)) = N_Indexed_Component
7188         or else Is_Renamed_Object (N)
7189         or else Is_Procedure_Actual (N)
7190       then
7191          return;
7192
7193       elsif Nkind (Parent (N)) = N_Attribute_Reference
7194         and then Attribute_Name (Parent (N)) = Name_Address
7195       then
7196          return;
7197
7198       else
7199          Make_Temporary;
7200       end if;
7201    end Expand_N_Slice;
7202
7203    ------------------------------
7204    -- Expand_N_Type_Conversion --
7205    ------------------------------
7206
7207    procedure Expand_N_Type_Conversion (N : Node_Id) is
7208       Loc          : constant Source_Ptr := Sloc (N);
7209       Operand      : constant Node_Id    := Expression (N);
7210       Target_Type  : constant Entity_Id  := Etype (N);
7211       Operand_Type : Entity_Id           := Etype (Operand);
7212
7213       procedure Handle_Changed_Representation;
7214       --  This is called in the case of record and array type conversions to
7215       --  see if there is a change of representation to be handled. Change of
7216       --  representation is actually handled at the assignment statement level,
7217       --  and what this procedure does is rewrite node N conversion as an
7218       --  assignment to temporary. If there is no change of representation,
7219       --  then the conversion node is unchanged.
7220
7221       procedure Real_Range_Check;
7222       --  Handles generation of range check for real target value
7223
7224       -----------------------------------
7225       -- Handle_Changed_Representation --
7226       -----------------------------------
7227
7228       procedure Handle_Changed_Representation is
7229          Temp : Entity_Id;
7230          Decl : Node_Id;
7231          Odef : Node_Id;
7232          Disc : Node_Id;
7233          N_Ix : Node_Id;
7234          Cons : List_Id;
7235
7236       begin
7237          --  Nothing else to do if no change of representation
7238
7239          if Same_Representation (Operand_Type, Target_Type) then
7240             return;
7241
7242          --  The real change of representation work is done by the assignment
7243          --  statement processing. So if this type conversion is appearing as
7244          --  the expression of an assignment statement, nothing needs to be
7245          --  done to the conversion.
7246
7247          elsif Nkind (Parent (N)) = N_Assignment_Statement then
7248             return;
7249
7250          --  Otherwise we need to generate a temporary variable, and do the
7251          --  change of representation assignment into that temporary variable.
7252          --  The conversion is then replaced by a reference to this variable.
7253
7254          else
7255             Cons := No_List;
7256
7257             --  If type is unconstrained we have to add a constraint, copied
7258             --  from the actual value of the left hand side.
7259
7260             if not Is_Constrained (Target_Type) then
7261                if Has_Discriminants (Operand_Type) then
7262                   Disc := First_Discriminant (Operand_Type);
7263
7264                   if Disc /= First_Stored_Discriminant (Operand_Type) then
7265                      Disc := First_Stored_Discriminant (Operand_Type);
7266                   end if;
7267
7268                   Cons := New_List;
7269                   while Present (Disc) loop
7270                      Append_To (Cons,
7271                        Make_Selected_Component (Loc,
7272                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
7273                          Selector_Name =>
7274                            Make_Identifier (Loc, Chars (Disc))));
7275                      Next_Discriminant (Disc);
7276                   end loop;
7277
7278                elsif Is_Array_Type (Operand_Type) then
7279                   N_Ix := First_Index (Target_Type);
7280                   Cons := New_List;
7281
7282                   for J in 1 .. Number_Dimensions (Operand_Type) loop
7283
7284                      --  We convert the bounds explicitly. We use an unchecked
7285                      --  conversion because bounds checks are done elsewhere.
7286
7287                      Append_To (Cons,
7288                        Make_Range (Loc,
7289                          Low_Bound =>
7290                            Unchecked_Convert_To (Etype (N_Ix),
7291                              Make_Attribute_Reference (Loc,
7292                                Prefix =>
7293                                  Duplicate_Subexpr_No_Checks
7294                                    (Operand, Name_Req => True),
7295                                Attribute_Name => Name_First,
7296                                Expressions    => New_List (
7297                                  Make_Integer_Literal (Loc, J)))),
7298
7299                          High_Bound =>
7300                            Unchecked_Convert_To (Etype (N_Ix),
7301                              Make_Attribute_Reference (Loc,
7302                                Prefix =>
7303                                  Duplicate_Subexpr_No_Checks
7304                                    (Operand, Name_Req => True),
7305                                Attribute_Name => Name_Last,
7306                                Expressions    => New_List (
7307                                  Make_Integer_Literal (Loc, J))))));
7308
7309                      Next_Index (N_Ix);
7310                   end loop;
7311                end if;
7312             end if;
7313
7314             Odef := New_Occurrence_Of (Target_Type, Loc);
7315
7316             if Present (Cons) then
7317                Odef :=
7318                  Make_Subtype_Indication (Loc,
7319                    Subtype_Mark => Odef,
7320                    Constraint =>
7321                      Make_Index_Or_Discriminant_Constraint (Loc,
7322                        Constraints => Cons));
7323             end if;
7324
7325             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
7326             Decl :=
7327               Make_Object_Declaration (Loc,
7328                 Defining_Identifier => Temp,
7329                 Object_Definition   => Odef);
7330
7331             Set_No_Initialization (Decl, True);
7332
7333             --  Insert required actions. It is essential to suppress checks
7334             --  since we have suppressed default initialization, which means
7335             --  that the variable we create may have no discriminants.
7336
7337             Insert_Actions (N,
7338               New_List (
7339                 Decl,
7340                 Make_Assignment_Statement (Loc,
7341                   Name => New_Occurrence_Of (Temp, Loc),
7342                   Expression => Relocate_Node (N))),
7343                 Suppress => All_Checks);
7344
7345             Rewrite (N, New_Occurrence_Of (Temp, Loc));
7346             return;
7347          end if;
7348       end Handle_Changed_Representation;
7349
7350       ----------------------
7351       -- Real_Range_Check --
7352       ----------------------
7353
7354       --  Case of conversions to floating-point or fixed-point. If range checks
7355       --  are enabled and the target type has a range constraint, we convert:
7356
7357       --     typ (x)
7358
7359       --       to
7360
7361       --     Tnn : typ'Base := typ'Base (x);
7362       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7363       --     Tnn
7364
7365       --  This is necessary when there is a conversion of integer to float or
7366       --  to fixed-point to ensure that the correct checks are made. It is not
7367       --  necessary for float to float where it is enough to simply set the
7368       --  Do_Range_Check flag.
7369
7370       procedure Real_Range_Check is
7371          Btyp : constant Entity_Id := Base_Type (Target_Type);
7372          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
7373          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
7374          Xtyp : constant Entity_Id := Etype (Operand);
7375          Conv : Node_Id;
7376          Tnn  : Entity_Id;
7377
7378       begin
7379          --  Nothing to do if conversion was rewritten
7380
7381          if Nkind (N) /= N_Type_Conversion then
7382             return;
7383          end if;
7384
7385          --  Nothing to do if range checks suppressed, or target has the same
7386          --  range as the base type (or is the base type).
7387
7388          if Range_Checks_Suppressed (Target_Type)
7389            or else (Lo = Type_Low_Bound (Btyp)
7390                       and then
7391                     Hi = Type_High_Bound (Btyp))
7392          then
7393             return;
7394          end if;
7395
7396          --  Nothing to do if expression is an entity on which checks have been
7397          --  suppressed.
7398
7399          if Is_Entity_Name (Operand)
7400            and then Range_Checks_Suppressed (Entity (Operand))
7401          then
7402             return;
7403          end if;
7404
7405          --  Nothing to do if bounds are all static and we can tell that the
7406          --  expression is within the bounds of the target. Note that if the
7407          --  operand is of an unconstrained floating-point type, then we do
7408          --  not trust it to be in range (might be infinite)
7409
7410          declare
7411             S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
7412             S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
7413
7414          begin
7415             if (not Is_Floating_Point_Type (Xtyp)
7416                  or else Is_Constrained (Xtyp))
7417               and then Compile_Time_Known_Value (S_Lo)
7418               and then Compile_Time_Known_Value (S_Hi)
7419               and then Compile_Time_Known_Value (Hi)
7420               and then Compile_Time_Known_Value (Lo)
7421             then
7422                declare
7423                   D_Lov : constant Ureal := Expr_Value_R (Lo);
7424                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
7425                   S_Lov : Ureal;
7426                   S_Hiv : Ureal;
7427
7428                begin
7429                   if Is_Real_Type (Xtyp) then
7430                      S_Lov := Expr_Value_R (S_Lo);
7431                      S_Hiv := Expr_Value_R (S_Hi);
7432                   else
7433                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
7434                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
7435                   end if;
7436
7437                   if D_Hiv > D_Lov
7438                     and then S_Lov >= D_Lov
7439                     and then S_Hiv <= D_Hiv
7440                   then
7441                      Set_Do_Range_Check (Operand, False);
7442                      return;
7443                   end if;
7444                end;
7445             end if;
7446          end;
7447
7448          --  For float to float conversions, we are done
7449
7450          if Is_Floating_Point_Type (Xtyp)
7451               and then
7452             Is_Floating_Point_Type (Btyp)
7453          then
7454             return;
7455          end if;
7456
7457          --  Otherwise rewrite the conversion as described above
7458
7459          Conv := Relocate_Node (N);
7460          Rewrite
7461            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
7462          Set_Etype (Conv, Btyp);
7463
7464          --  Enable overflow except for case of integer to float conversions,
7465          --  where it is never required, since we can never have overflow in
7466          --  this case.
7467
7468          if not Is_Integer_Type (Etype (Operand)) then
7469             Enable_Overflow_Check (Conv);
7470          end if;
7471
7472          Tnn :=
7473            Make_Defining_Identifier (Loc,
7474              Chars => New_Internal_Name ('T'));
7475
7476          Insert_Actions (N, New_List (
7477            Make_Object_Declaration (Loc,
7478              Defining_Identifier => Tnn,
7479              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
7480              Expression => Conv),
7481
7482            Make_Raise_Constraint_Error (Loc,
7483              Condition =>
7484               Make_Or_Else (Loc,
7485                 Left_Opnd =>
7486                   Make_Op_Lt (Loc,
7487                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
7488                     Right_Opnd =>
7489                       Make_Attribute_Reference (Loc,
7490                         Attribute_Name => Name_First,
7491                         Prefix =>
7492                           New_Occurrence_Of (Target_Type, Loc))),
7493
7494                 Right_Opnd =>
7495                   Make_Op_Gt (Loc,
7496                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
7497                     Right_Opnd =>
7498                       Make_Attribute_Reference (Loc,
7499                         Attribute_Name => Name_Last,
7500                         Prefix =>
7501                           New_Occurrence_Of (Target_Type, Loc)))),
7502              Reason => CE_Range_Check_Failed)));
7503
7504          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
7505          Analyze_And_Resolve (N, Btyp);
7506       end Real_Range_Check;
7507
7508    --  Start of processing for Expand_N_Type_Conversion
7509
7510    begin
7511       --  Nothing at all to do if conversion is to the identical type so remove
7512       --  the conversion completely, it is useless.
7513
7514       if Operand_Type = Target_Type then
7515          Rewrite (N, Relocate_Node (Operand));
7516          return;
7517       end if;
7518
7519       --  Nothing to do if this is the second argument of read. This is a
7520       --  "backwards" conversion that will be handled by the specialized code
7521       --  in attribute processing.
7522
7523       if Nkind (Parent (N)) = N_Attribute_Reference
7524         and then Attribute_Name (Parent (N)) = Name_Read
7525         and then Next (First (Expressions (Parent (N)))) = N
7526       then
7527          return;
7528       end if;
7529
7530       --  Here if we may need to expand conversion
7531
7532       --  Do validity check if validity checking operands
7533
7534       if Validity_Checks_On
7535         and then Validity_Check_Operands
7536       then
7537          Ensure_Valid (Operand);
7538       end if;
7539
7540       --  Special case of converting from non-standard boolean type
7541
7542       if Is_Boolean_Type (Operand_Type)
7543         and then (Nonzero_Is_True (Operand_Type))
7544       then
7545          Adjust_Condition (Operand);
7546          Set_Etype (Operand, Standard_Boolean);
7547          Operand_Type := Standard_Boolean;
7548       end if;
7549
7550       --  Case of converting to an access type
7551
7552       if Is_Access_Type (Target_Type) then
7553
7554          --  Apply an accessibility check when the conversion operand is an
7555          --  access parameter (or a renaming thereof), unless conversion was
7556          --  expanded from an Unchecked_ or Unrestricted_Access attribute.
7557          --  Note that other checks may still need to be applied below (such
7558          --  as tagged type checks).
7559
7560          if Is_Entity_Name (Operand)
7561            and then
7562              (Is_Formal (Entity (Operand))
7563                or else
7564                  (Present (Renamed_Object (Entity (Operand)))
7565                    and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
7566                    and then Is_Formal
7567                               (Entity (Renamed_Object (Entity (Operand))))))
7568            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
7569            and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
7570                       or else Attribute_Name (Original_Node (N)) = Name_Access)
7571          then
7572             Apply_Accessibility_Check
7573               (Operand, Target_Type, Insert_Node => Operand);
7574
7575          --  If the level of the operand type is statically deeper than the
7576          --  level of the target type, then force Program_Error. Note that this
7577          --  can only occur for cases where the attribute is within the body of
7578          --  an instantiation (otherwise the conversion will already have been
7579          --  rejected as illegal). Note: warnings are issued by the analyzer
7580          --  for the instance cases.
7581
7582          elsif In_Instance_Body
7583            and then Type_Access_Level (Operand_Type) >
7584                     Type_Access_Level (Target_Type)
7585          then
7586             Rewrite (N,
7587               Make_Raise_Program_Error (Sloc (N),
7588                 Reason => PE_Accessibility_Check_Failed));
7589             Set_Etype (N, Target_Type);
7590
7591          --  When the operand is a selected access discriminant the check needs
7592          --  to be made against the level of the object denoted by the prefix
7593          --  of the selected name. Force Program_Error for this case as well
7594          --  (this accessibility violation can only happen if within the body
7595          --  of an instantiation).
7596
7597          elsif In_Instance_Body
7598            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
7599            and then Nkind (Operand) = N_Selected_Component
7600            and then Object_Access_Level (Operand) >
7601                       Type_Access_Level (Target_Type)
7602          then
7603             Rewrite (N,
7604               Make_Raise_Program_Error (Sloc (N),
7605                 Reason => PE_Accessibility_Check_Failed));
7606             Set_Etype (N, Target_Type);
7607          end if;
7608       end if;
7609
7610       --  Case of conversions of tagged types and access to tagged types
7611
7612       --  When needed, that is to say when the expression is class-wide, Add
7613       --  runtime a tag check for (strict) downward conversion by using the
7614       --  membership test, generating:
7615
7616       --      [constraint_error when Operand not in Target_Type'Class]
7617
7618       --  or in the access type case
7619
7620       --      [constraint_error
7621       --        when Operand /= null
7622       --          and then Operand.all not in
7623       --            Designated_Type (Target_Type)'Class]
7624
7625       if (Is_Access_Type (Target_Type)
7626            and then Is_Tagged_Type (Designated_Type (Target_Type)))
7627         or else Is_Tagged_Type (Target_Type)
7628       then
7629          --  Do not do any expansion in the access type case if the parent is a
7630          --  renaming, since this is an error situation which will be caught by
7631          --  Sem_Ch8, and the expansion can interfere with this error check.
7632
7633          if Is_Access_Type (Target_Type)
7634            and then Is_Renamed_Object (N)
7635          then
7636             return;
7637          end if;
7638
7639          --  Otherwise, proceed with processing tagged conversion
7640
7641          declare
7642             Actual_Op_Typ   : Entity_Id;
7643             Actual_Targ_Typ : Entity_Id;
7644             Make_Conversion : Boolean := False;
7645             Root_Op_Typ     : Entity_Id;
7646
7647             procedure Make_Tag_Check (Targ_Typ : Entity_Id);
7648             --  Create a membership check to test whether Operand is a member
7649             --  of Targ_Typ. If the original Target_Type is an access, include
7650             --  a test for null value. The check is inserted at N.
7651
7652             --------------------
7653             -- Make_Tag_Check --
7654             --------------------
7655
7656             procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
7657                Cond : Node_Id;
7658
7659             begin
7660                --  Generate:
7661                --    [Constraint_Error
7662                --       when Operand /= null
7663                --         and then Operand.all not in Targ_Typ]
7664
7665                if Is_Access_Type (Target_Type) then
7666                   Cond :=
7667                     Make_And_Then (Loc,
7668                       Left_Opnd =>
7669                         Make_Op_Ne (Loc,
7670                           Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
7671                           Right_Opnd => Make_Null (Loc)),
7672
7673                       Right_Opnd =>
7674                         Make_Not_In (Loc,
7675                           Left_Opnd  =>
7676                             Make_Explicit_Dereference (Loc,
7677                               Prefix => Duplicate_Subexpr_No_Checks (Operand)),
7678                           Right_Opnd => New_Reference_To (Targ_Typ, Loc)));
7679
7680                --  Generate:
7681                --    [Constraint_Error when Operand not in Targ_Typ]
7682
7683                else
7684                   Cond :=
7685                     Make_Not_In (Loc,
7686                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
7687                       Right_Opnd => New_Reference_To (Targ_Typ, Loc));
7688                end if;
7689
7690                Insert_Action (N,
7691                  Make_Raise_Constraint_Error (Loc,
7692                    Condition => Cond,
7693                    Reason    => CE_Tag_Check_Failed));
7694             end Make_Tag_Check;
7695
7696          --  Start of processing
7697
7698          begin
7699             if Is_Access_Type (Target_Type) then
7700                Actual_Op_Typ   := Designated_Type (Operand_Type);
7701                Actual_Targ_Typ := Designated_Type (Target_Type);
7702
7703             else
7704                Actual_Op_Typ   := Operand_Type;
7705                Actual_Targ_Typ := Target_Type;
7706             end if;
7707
7708             Root_Op_Typ := Root_Type (Actual_Op_Typ);
7709
7710             --  Ada 2005 (AI-251): Handle interface type conversion
7711
7712             if Is_Interface (Actual_Op_Typ) then
7713                Expand_Interface_Conversion (N, Is_Static => False);
7714                return;
7715             end if;
7716
7717             if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
7718
7719                --  Create a runtime tag check for a downward class-wide type
7720                --  conversion.
7721
7722                if Is_Class_Wide_Type (Actual_Op_Typ)
7723                  and then Root_Op_Typ /= Actual_Targ_Typ
7724                  and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
7725                then
7726                   Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
7727                   Make_Conversion := True;
7728                end if;
7729
7730                --  AI05-0073: If the result subtype of the function is defined
7731                --  by an access_definition designating a specific tagged type
7732                --  T, a check is made that the result value is null or the tag
7733                --  of the object designated by the result value identifies T.
7734                --  Constraint_Error is raised if this check fails.
7735
7736                if Nkind (Parent (N)) = Sinfo.N_Return_Statement then
7737                   declare
7738                      Func     : Entity_Id;
7739                      Func_Typ : Entity_Id;
7740
7741                   begin
7742                      --  Climb scope stack looking for the enclosing function
7743
7744                      Func := Current_Scope;
7745                      while Present (Func)
7746                        and then Ekind (Func) /= E_Function
7747                      loop
7748                         Func := Scope (Func);
7749                      end loop;
7750
7751                      --  The function's return subtype must be defined using
7752                      --  an access definition.
7753
7754                      if Nkind (Result_Definition (Parent (Func))) =
7755                           N_Access_Definition
7756                      then
7757                         Func_Typ := Directly_Designated_Type (Etype (Func));
7758
7759                         --  The return subtype denotes a specific tagged type,
7760                         --  in other words, a non class-wide type.
7761
7762                         if Is_Tagged_Type (Func_Typ)
7763                           and then not Is_Class_Wide_Type (Func_Typ)
7764                         then
7765                            Make_Tag_Check (Actual_Targ_Typ);
7766                            Make_Conversion := True;
7767                         end if;
7768                      end if;
7769                   end;
7770                end if;
7771
7772                --  We have generated a tag check for either a class-wide type
7773                --  conversion or for AI05-0073.
7774
7775                if Make_Conversion then
7776                   declare
7777                      Conv : Node_Id;
7778                   begin
7779                      Conv :=
7780                        Make_Unchecked_Type_Conversion (Loc,
7781                          Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
7782                          Expression   => Relocate_Node (Expression (N)));
7783                      Rewrite (N, Conv);
7784                      Analyze_And_Resolve (N, Target_Type);
7785                   end;
7786                end if;
7787             end if;
7788          end;
7789
7790       --  Case of other access type conversions
7791
7792       elsif Is_Access_Type (Target_Type) then
7793          Apply_Constraint_Check (Operand, Target_Type);
7794
7795       --  Case of conversions from a fixed-point type
7796
7797       --  These conversions require special expansion and processing, found in
7798       --  the Exp_Fixd package. We ignore cases where Conversion_OK is set,
7799       --  since from a semantic point of view, these are simple integer
7800       --  conversions, which do not need further processing.
7801
7802       elsif Is_Fixed_Point_Type (Operand_Type)
7803         and then not Conversion_OK (N)
7804       then
7805          --  We should never see universal fixed at this case, since the
7806          --  expansion of the constituent divide or multiply should have
7807          --  eliminated the explicit mention of universal fixed.
7808
7809          pragma Assert (Operand_Type /= Universal_Fixed);
7810
7811          --  Check for special case of the conversion to universal real that
7812          --  occurs as a result of the use of a round attribute. In this case,
7813          --  the real type for the conversion is taken from the target type of
7814          --  the Round attribute and the result must be marked as rounded.
7815
7816          if Target_Type = Universal_Real
7817            and then Nkind (Parent (N)) = N_Attribute_Reference
7818            and then Attribute_Name (Parent (N)) = Name_Round
7819          then
7820             Set_Rounded_Result (N);
7821             Set_Etype (N, Etype (Parent (N)));
7822          end if;
7823
7824          --  Otherwise do correct fixed-conversion, but skip these if the
7825          --  Conversion_OK flag is set, because from a semantic point of
7826          --  view these are simple integer conversions needing no further
7827          --  processing (the backend will simply treat them as integers)
7828
7829          if not Conversion_OK (N) then
7830             if Is_Fixed_Point_Type (Etype (N)) then
7831                Expand_Convert_Fixed_To_Fixed (N);
7832                Real_Range_Check;
7833
7834             elsif Is_Integer_Type (Etype (N)) then
7835                Expand_Convert_Fixed_To_Integer (N);
7836
7837             else
7838                pragma Assert (Is_Floating_Point_Type (Etype (N)));
7839                Expand_Convert_Fixed_To_Float (N);
7840                Real_Range_Check;
7841             end if;
7842          end if;
7843
7844       --  Case of conversions to a fixed-point type
7845
7846       --  These conversions require special expansion and processing, found in
7847       --  the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
7848       --  since from a semantic point of view, these are simple integer
7849       --  conversions, which do not need further processing.
7850
7851       elsif Is_Fixed_Point_Type (Target_Type)
7852         and then not Conversion_OK (N)
7853       then
7854          if Is_Integer_Type (Operand_Type) then
7855             Expand_Convert_Integer_To_Fixed (N);
7856             Real_Range_Check;
7857          else
7858             pragma Assert (Is_Floating_Point_Type (Operand_Type));
7859             Expand_Convert_Float_To_Fixed (N);
7860             Real_Range_Check;
7861          end if;
7862
7863       --  Case of float-to-integer conversions
7864
7865       --  We also handle float-to-fixed conversions with Conversion_OK set
7866       --  since semantically the fixed-point target is treated as though it
7867       --  were an integer in such cases.
7868
7869       elsif Is_Floating_Point_Type (Operand_Type)
7870         and then
7871           (Is_Integer_Type (Target_Type)
7872             or else
7873           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
7874       then
7875          --  One more check here, gcc is still not able to do conversions of
7876          --  this type with proper overflow checking, and so gigi is doing an
7877          --  approximation of what is required by doing floating-point compares
7878          --  with the end-point. But that can lose precision in some cases, and
7879          --  give a wrong result. Converting the operand to Universal_Real is
7880          --  helpful, but still does not catch all cases with 64-bit integers
7881          --  on targets with only 64-bit floats
7882
7883          --  The above comment seems obsoleted by Apply_Float_Conversion_Check
7884          --  Can this code be removed ???
7885
7886          if Do_Range_Check (Operand) then
7887             Rewrite (Operand,
7888               Make_Type_Conversion (Loc,
7889                 Subtype_Mark =>
7890                   New_Occurrence_Of (Universal_Real, Loc),
7891                 Expression =>
7892                   Relocate_Node (Operand)));
7893
7894             Set_Etype (Operand, Universal_Real);
7895             Enable_Range_Check (Operand);
7896             Set_Do_Range_Check (Expression (Operand), False);
7897          end if;
7898
7899       --  Case of array conversions
7900
7901       --  Expansion of array conversions, add required length/range checks but
7902       --  only do this if there is no change of representation. For handling of
7903       --  this case, see Handle_Changed_Representation.
7904
7905       elsif Is_Array_Type (Target_Type) then
7906
7907          if Is_Constrained (Target_Type) then
7908             Apply_Length_Check (Operand, Target_Type);
7909          else
7910             Apply_Range_Check (Operand, Target_Type);
7911          end if;
7912
7913          Handle_Changed_Representation;
7914
7915       --  Case of conversions of discriminated types
7916
7917       --  Add required discriminant checks if target is constrained. Again this
7918       --  change is skipped if we have a change of representation.
7919
7920       elsif Has_Discriminants (Target_Type)
7921         and then Is_Constrained (Target_Type)
7922       then
7923          Apply_Discriminant_Check (Operand, Target_Type);
7924          Handle_Changed_Representation;
7925
7926       --  Case of all other record conversions. The only processing required
7927       --  is to check for a change of representation requiring the special
7928       --  assignment processing.
7929
7930       elsif Is_Record_Type (Target_Type) then
7931
7932          --  Ada 2005 (AI-216): Program_Error is raised when converting from
7933          --  a derived Unchecked_Union type to an unconstrained type that is
7934          --  not Unchecked_Union if the operand lacks inferable discriminants.
7935
7936          if Is_Derived_Type (Operand_Type)
7937            and then Is_Unchecked_Union (Base_Type (Operand_Type))
7938            and then not Is_Constrained (Target_Type)
7939            and then not Is_Unchecked_Union (Base_Type (Target_Type))
7940            and then not Has_Inferable_Discriminants (Operand)
7941          then
7942             --  To prevent Gigi from generating illegal code, we generate a
7943             --  Program_Error node, but we give it the target type of the
7944             --  conversion.
7945
7946             declare
7947                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
7948                       Reason => PE_Unchecked_Union_Restriction);
7949
7950             begin
7951                Set_Etype (PE, Target_Type);
7952                Rewrite (N, PE);
7953
7954             end;
7955          else
7956             Handle_Changed_Representation;
7957          end if;
7958
7959       --  Case of conversions of enumeration types
7960
7961       elsif Is_Enumeration_Type (Target_Type) then
7962
7963          --  Special processing is required if there is a change of
7964          --  representation (from enumeration representation clauses)
7965
7966          if not Same_Representation (Target_Type, Operand_Type) then
7967
7968             --  Convert: x(y) to x'val (ytyp'val (y))
7969
7970             Rewrite (N,
7971                Make_Attribute_Reference (Loc,
7972                  Prefix => New_Occurrence_Of (Target_Type, Loc),
7973                  Attribute_Name => Name_Val,
7974                  Expressions => New_List (
7975                    Make_Attribute_Reference (Loc,
7976                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
7977                      Attribute_Name => Name_Pos,
7978                      Expressions => New_List (Operand)))));
7979
7980             Analyze_And_Resolve (N, Target_Type);
7981          end if;
7982
7983       --  Case of conversions to floating-point
7984
7985       elsif Is_Floating_Point_Type (Target_Type) then
7986          Real_Range_Check;
7987       end if;
7988
7989       --  At this stage, either the conversion node has been transformed into
7990       --  some other equivalent expression, or left as a conversion that can
7991       --  be handled by Gigi. The conversions that Gigi can handle are the
7992       --  following:
7993
7994       --    Conversions with no change of representation or type
7995
7996       --    Numeric conversions involving integer, floating- and fixed-point
7997       --    values. Fixed-point values are allowed only if Conversion_OK is
7998       --    set, i.e. if the fixed-point values are to be treated as integers.
7999
8000       --  No other conversions should be passed to Gigi
8001
8002       --  Check: are these rules stated in sinfo??? if so, why restate here???
8003
8004       --  The only remaining step is to generate a range check if we still have
8005       --  a type conversion at this stage and Do_Range_Check is set. For now we
8006       --  do this only for conversions of discrete types.
8007
8008       if Nkind (N) = N_Type_Conversion
8009         and then Is_Discrete_Type (Etype (N))
8010       then
8011          declare
8012             Expr : constant Node_Id := Expression (N);
8013             Ftyp : Entity_Id;
8014             Ityp : Entity_Id;
8015
8016          begin
8017             if Do_Range_Check (Expr)
8018               and then Is_Discrete_Type (Etype (Expr))
8019             then
8020                Set_Do_Range_Check (Expr, False);
8021
8022                --  Before we do a range check, we have to deal with treating a
8023                --  fixed-point operand as an integer. The way we do this is
8024                --  simply to do an unchecked conversion to an appropriate
8025                --  integer type large enough to hold the result.
8026
8027                --  This code is not active yet, because we are only dealing
8028                --  with discrete types so far ???
8029
8030                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
8031                  and then Treat_Fixed_As_Integer (Expr)
8032                then
8033                   Ftyp := Base_Type (Etype (Expr));
8034
8035                   if Esize (Ftyp) >= Esize (Standard_Integer) then
8036                      Ityp := Standard_Long_Long_Integer;
8037                   else
8038                      Ityp := Standard_Integer;
8039                   end if;
8040
8041                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
8042                end if;
8043
8044                --  Reset overflow flag, since the range check will include
8045                --  dealing with possible overflow, and generate the check If
8046                --  Address is either a source type or target type, suppress
8047                --  range check to avoid typing anomalies when it is a visible
8048                --  integer type.
8049
8050                Set_Do_Overflow_Check (N, False);
8051                if not Is_Descendent_Of_Address (Etype (Expr))
8052                  and then not Is_Descendent_Of_Address (Target_Type)
8053                then
8054                   Generate_Range_Check
8055                     (Expr, Target_Type, CE_Range_Check_Failed);
8056                end if;
8057             end if;
8058          end;
8059       end if;
8060
8061       --  Final step, if the result is a type conversion involving Vax_Float
8062       --  types, then it is subject for further special processing.
8063
8064       if Nkind (N) = N_Type_Conversion
8065         and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
8066       then
8067          Expand_Vax_Conversion (N);
8068          return;
8069       end if;
8070    end Expand_N_Type_Conversion;
8071
8072    -----------------------------------
8073    -- Expand_N_Unchecked_Expression --
8074    -----------------------------------
8075
8076    --  Remove the unchecked expression node from the tree. It's job was simply
8077    --  to make sure that its constituent expression was handled with checks
8078    --  off, and now that that is done, we can remove it from the tree, and
8079    --  indeed must, since gigi does not expect to see these nodes.
8080
8081    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
8082       Exp : constant Node_Id := Expression (N);
8083
8084    begin
8085       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
8086       Rewrite (N, Exp);
8087    end Expand_N_Unchecked_Expression;
8088
8089    ----------------------------------------
8090    -- Expand_N_Unchecked_Type_Conversion --
8091    ----------------------------------------
8092
8093    --  If this cannot be handled by Gigi and we haven't already made a
8094    --  temporary for it, do it now.
8095
8096    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
8097       Target_Type  : constant Entity_Id := Etype (N);
8098       Operand      : constant Node_Id   := Expression (N);
8099       Operand_Type : constant Entity_Id := Etype (Operand);
8100
8101    begin
8102       --  If we have a conversion of a compile time known value to a target
8103       --  type and the value is in range of the target type, then we can simply
8104       --  replace the construct by an integer literal of the correct type. We
8105       --  only apply this to integer types being converted. Possibly it may
8106       --  apply in other cases, but it is too much trouble to worry about.
8107
8108       --  Note that we do not do this transformation if the Kill_Range_Check
8109       --  flag is set, since then the value may be outside the expected range.
8110       --  This happens in the Normalize_Scalars case.
8111
8112       --  We also skip this if either the target or operand type is biased
8113       --  because in this case, the unchecked conversion is supposed to
8114       --  preserve the bit pattern, not the integer value.
8115
8116       if Is_Integer_Type (Target_Type)
8117         and then not Has_Biased_Representation (Target_Type)
8118         and then Is_Integer_Type (Operand_Type)
8119         and then not Has_Biased_Representation (Operand_Type)
8120         and then Compile_Time_Known_Value (Operand)
8121         and then not Kill_Range_Check (N)
8122       then
8123          declare
8124             Val : constant Uint := Expr_Value (Operand);
8125
8126          begin
8127             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
8128                  and then
8129                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
8130                  and then
8131                Val >= Expr_Value (Type_Low_Bound (Target_Type))
8132                  and then
8133                Val <= Expr_Value (Type_High_Bound (Target_Type))
8134             then
8135                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
8136
8137                --  If Address is the target type, just set the type to avoid a
8138                --  spurious type error on the literal when Address is a visible
8139                --  integer type.
8140
8141                if Is_Descendent_Of_Address (Target_Type) then
8142                   Set_Etype (N, Target_Type);
8143                else
8144                   Analyze_And_Resolve (N, Target_Type);
8145                end if;
8146
8147                return;
8148             end if;
8149          end;
8150       end if;
8151
8152       --  Nothing to do if conversion is safe
8153
8154       if Safe_Unchecked_Type_Conversion (N) then
8155          return;
8156       end if;
8157
8158       --  Otherwise force evaluation unless Assignment_OK flag is set (this
8159       --  flag indicates ??? -- more comments needed here)
8160
8161       if Assignment_OK (N) then
8162          null;
8163       else
8164          Force_Evaluation (N);
8165       end if;
8166    end Expand_N_Unchecked_Type_Conversion;
8167
8168    ----------------------------
8169    -- Expand_Record_Equality --
8170    ----------------------------
8171
8172    --  For non-variant records, Equality is expanded when needed into:
8173
8174    --      and then Lhs.Discr1 = Rhs.Discr1
8175    --      and then ...
8176    --      and then Lhs.Discrn = Rhs.Discrn
8177    --      and then Lhs.Cmp1 = Rhs.Cmp1
8178    --      and then ...
8179    --      and then Lhs.Cmpn = Rhs.Cmpn
8180
8181    --  The expression is folded by the back-end for adjacent fields. This
8182    --  function is called for tagged record in only one occasion: for imple-
8183    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
8184    --  otherwise the primitive "=" is used directly.
8185
8186    function Expand_Record_Equality
8187      (Nod    : Node_Id;
8188       Typ    : Entity_Id;
8189       Lhs    : Node_Id;
8190       Rhs    : Node_Id;
8191       Bodies : List_Id) return Node_Id
8192    is
8193       Loc : constant Source_Ptr := Sloc (Nod);
8194
8195       Result : Node_Id;
8196       C      : Entity_Id;
8197
8198       First_Time : Boolean := True;
8199
8200       function Suitable_Element (C : Entity_Id) return Entity_Id;
8201       --  Return the first field to compare beginning with C, skipping the
8202       --  inherited components.
8203
8204       ----------------------
8205       -- Suitable_Element --
8206       ----------------------
8207
8208       function Suitable_Element (C : Entity_Id) return Entity_Id is
8209       begin
8210          if No (C) then
8211             return Empty;
8212
8213          elsif Ekind (C) /= E_Discriminant
8214            and then Ekind (C) /= E_Component
8215          then
8216             return Suitable_Element (Next_Entity (C));
8217
8218          elsif Is_Tagged_Type (Typ)
8219            and then C /= Original_Record_Component (C)
8220          then
8221             return Suitable_Element (Next_Entity (C));
8222
8223          elsif Chars (C) = Name_uController
8224            or else Chars (C) = Name_uTag
8225          then
8226             return Suitable_Element (Next_Entity (C));
8227
8228          elsif Is_Interface (Etype (C)) then
8229             return Suitable_Element (Next_Entity (C));
8230
8231          else
8232             return C;
8233          end if;
8234       end Suitable_Element;
8235
8236    --  Start of processing for Expand_Record_Equality
8237
8238    begin
8239       --  Generates the following code: (assuming that Typ has one Discr and
8240       --  component C2 is also a record)
8241
8242       --   True
8243       --     and then Lhs.Discr1 = Rhs.Discr1
8244       --     and then Lhs.C1 = Rhs.C1
8245       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8246       --     and then ...
8247       --     and then Lhs.Cmpn = Rhs.Cmpn
8248
8249       Result := New_Reference_To (Standard_True, Loc);
8250       C := Suitable_Element (First_Entity (Typ));
8251
8252       while Present (C) loop
8253          declare
8254             New_Lhs : Node_Id;
8255             New_Rhs : Node_Id;
8256             Check   : Node_Id;
8257
8258          begin
8259             if First_Time then
8260                First_Time := False;
8261                New_Lhs := Lhs;
8262                New_Rhs := Rhs;
8263             else
8264                New_Lhs := New_Copy_Tree (Lhs);
8265                New_Rhs := New_Copy_Tree (Rhs);
8266             end if;
8267
8268             Check :=
8269               Expand_Composite_Equality (Nod, Etype (C),
8270                Lhs =>
8271                  Make_Selected_Component (Loc,
8272                    Prefix => New_Lhs,
8273                    Selector_Name => New_Reference_To (C, Loc)),
8274                Rhs =>
8275                  Make_Selected_Component (Loc,
8276                    Prefix => New_Rhs,
8277                    Selector_Name => New_Reference_To (C, Loc)),
8278                Bodies => Bodies);
8279
8280             --  If some (sub)component is an unchecked_union, the whole
8281             --  operation will raise program error.
8282
8283             if Nkind (Check) = N_Raise_Program_Error then
8284                Result := Check;
8285                Set_Etype (Result, Standard_Boolean);
8286                exit;
8287             else
8288                Result :=
8289                  Make_And_Then (Loc,
8290                    Left_Opnd  => Result,
8291                    Right_Opnd => Check);
8292             end if;
8293          end;
8294
8295          C := Suitable_Element (Next_Entity (C));
8296       end loop;
8297
8298       return Result;
8299    end Expand_Record_Equality;
8300
8301    -------------------------------------
8302    -- Fixup_Universal_Fixed_Operation --
8303    -------------------------------------
8304
8305    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
8306       Conv : constant Node_Id := Parent (N);
8307
8308    begin
8309       --  We must have a type conversion immediately above us
8310
8311       pragma Assert (Nkind (Conv) = N_Type_Conversion);
8312
8313       --  Normally the type conversion gives our target type. The exception
8314       --  occurs in the case of the Round attribute, where the conversion
8315       --  will be to universal real, and our real type comes from the Round
8316       --  attribute (as well as an indication that we must round the result)
8317
8318       if Nkind (Parent (Conv)) = N_Attribute_Reference
8319         and then Attribute_Name (Parent (Conv)) = Name_Round
8320       then
8321          Set_Etype (N, Etype (Parent (Conv)));
8322          Set_Rounded_Result (N);
8323
8324       --  Normal case where type comes from conversion above us
8325
8326       else
8327          Set_Etype (N, Etype (Conv));
8328       end if;
8329    end Fixup_Universal_Fixed_Operation;
8330
8331    ------------------------------
8332    -- Get_Allocator_Final_List --
8333    ------------------------------
8334
8335    function Get_Allocator_Final_List
8336      (N    : Node_Id;
8337       T    : Entity_Id;
8338       PtrT : Entity_Id) return Entity_Id
8339    is
8340       Loc : constant Source_Ptr := Sloc (N);
8341
8342       Owner : Entity_Id := PtrT;
8343       --  The entity whose finalization list must be used to attach the
8344       --  allocated object.
8345
8346    begin
8347       if Ekind (PtrT) = E_Anonymous_Access_Type then
8348
8349          --  If the context is an access parameter, we need to create a
8350          --  non-anonymous access type in order to have a usable final list,
8351          --  because there is otherwise no pool to which the allocated object
8352          --  can belong. We create both the type and the finalization chain
8353          --  here, because freezing an internal type does not create such a
8354          --  chain. The Final_Chain that is thus created is shared by the
8355          --  access parameter. The access type is tested against the result
8356          --  type of the function to exclude allocators whose type is an
8357          --  anonymous access result type.
8358
8359          if Nkind (Associated_Node_For_Itype (PtrT))
8360               in N_Subprogram_Specification
8361            and then
8362              PtrT /=
8363                Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT)))
8364          then
8365             Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
8366             Insert_Action (N,
8367               Make_Full_Type_Declaration (Loc,
8368                 Defining_Identifier => Owner,
8369                 Type_Definition =>
8370                    Make_Access_To_Object_Definition (Loc,
8371                      Subtype_Indication =>
8372                        New_Occurrence_Of (T, Loc))));
8373
8374             Build_Final_List (N, Owner);
8375             Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
8376
8377          --  Ada 2005 (AI-318-02): If the context is a return object
8378          --  declaration, then the anonymous return subtype is defined to have
8379          --  the same accessibility level as that of the function's result
8380          --  subtype, which means that we want the scope where the function is
8381          --  declared.
8382
8383          elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration
8384            and then Ekind (Scope (PtrT)) = E_Return_Statement
8385          then
8386             Owner := Scope (Return_Applies_To (Scope (PtrT)));
8387
8388          --  Case of an access discriminant, or (Ada 2005), of an anonymous
8389          --  access component or anonymous access function result: find the
8390          --  final list associated with the scope of the type. (In the
8391          --  anonymous access component kind, a list controller will have
8392          --  been allocated when freezing the record type, and PtrT has an
8393          --  Associated_Final_Chain attribute designating it.)
8394
8395          elsif No (Associated_Final_Chain (PtrT)) then
8396             Owner := Scope (PtrT);
8397          end if;
8398       end if;
8399
8400       return Find_Final_List (Owner);
8401    end Get_Allocator_Final_List;
8402
8403    ---------------------------------
8404    -- Has_Inferable_Discriminants --
8405    ---------------------------------
8406
8407    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
8408
8409       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
8410       --  Determines whether the left-most prefix of a selected component is a
8411       --  formal parameter in a subprogram. Assumes N is a selected component.
8412
8413       --------------------------------
8414       -- Prefix_Is_Formal_Parameter --
8415       --------------------------------
8416
8417       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
8418          Sel_Comp : Node_Id := N;
8419
8420       begin
8421          --  Move to the left-most prefix by climbing up the tree
8422
8423          while Present (Parent (Sel_Comp))
8424            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
8425          loop
8426             Sel_Comp := Parent (Sel_Comp);
8427          end loop;
8428
8429          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
8430       end Prefix_Is_Formal_Parameter;
8431
8432    --  Start of processing for Has_Inferable_Discriminants
8433
8434    begin
8435       --  For identifiers and indexed components, it is sufficient to have a
8436       --  constrained Unchecked_Union nominal subtype.
8437
8438       if Nkind_In (N, N_Identifier, N_Indexed_Component) then
8439          return Is_Unchecked_Union (Base_Type (Etype (N)))
8440                   and then
8441                 Is_Constrained (Etype (N));
8442
8443       --  For selected components, the subtype of the selector must be a
8444       --  constrained Unchecked_Union. If the component is subject to a
8445       --  per-object constraint, then the enclosing object must have inferable
8446       --  discriminants.
8447
8448       elsif Nkind (N) = N_Selected_Component then
8449          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
8450
8451             --  A small hack. If we have a per-object constrained selected
8452             --  component of a formal parameter, return True since we do not
8453             --  know the actual parameter association yet.
8454
8455             if Prefix_Is_Formal_Parameter (N) then
8456                return True;
8457             end if;
8458
8459             --  Otherwise, check the enclosing object and the selector
8460
8461             return Has_Inferable_Discriminants (Prefix (N))
8462                      and then
8463                    Has_Inferable_Discriminants (Selector_Name (N));
8464          end if;
8465
8466          --  The call to Has_Inferable_Discriminants will determine whether
8467          --  the selector has a constrained Unchecked_Union nominal type.
8468
8469          return Has_Inferable_Discriminants (Selector_Name (N));
8470
8471       --  A qualified expression has inferable discriminants if its subtype
8472       --  mark is a constrained Unchecked_Union subtype.
8473
8474       elsif Nkind (N) = N_Qualified_Expression then
8475          return Is_Unchecked_Union (Subtype_Mark (N))
8476                   and then
8477                 Is_Constrained (Subtype_Mark (N));
8478
8479       end if;
8480
8481       return False;
8482    end Has_Inferable_Discriminants;
8483
8484    -------------------------------
8485    -- Insert_Dereference_Action --
8486    -------------------------------
8487
8488    procedure Insert_Dereference_Action (N : Node_Id) is
8489       Loc  : constant Source_Ptr := Sloc (N);
8490       Typ  : constant Entity_Id  := Etype (N);
8491       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
8492       Pnod : constant Node_Id    := Parent (N);
8493
8494       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
8495       --  Return true if type of P is derived from Checked_Pool;
8496
8497       -----------------------------
8498       -- Is_Checked_Storage_Pool --
8499       -----------------------------
8500
8501       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
8502          T : Entity_Id;
8503
8504       begin
8505          if No (P) then
8506             return False;
8507          end if;
8508
8509          T := Etype (P);
8510          while T /= Etype (T) loop
8511             if Is_RTE (T, RE_Checked_Pool) then
8512                return True;
8513             else
8514                T := Etype (T);
8515             end if;
8516          end loop;
8517
8518          return False;
8519       end Is_Checked_Storage_Pool;
8520
8521    --  Start of processing for Insert_Dereference_Action
8522
8523    begin
8524       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
8525
8526       if not (Is_Checked_Storage_Pool (Pool)
8527               and then Comes_From_Source (Original_Node (Pnod)))
8528       then
8529          return;
8530       end if;
8531
8532       Insert_Action (N,
8533         Make_Procedure_Call_Statement (Loc,
8534           Name => New_Reference_To (
8535             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
8536
8537           Parameter_Associations => New_List (
8538
8539             --  Pool
8540
8541              New_Reference_To (Pool, Loc),
8542
8543             --  Storage_Address. We use the attribute Pool_Address, which uses
8544             --  the pointer itself to find the address of the object, and which
8545             --  handles unconstrained arrays properly by computing the address
8546             --  of the template. i.e. the correct address of the corresponding
8547             --  allocation.
8548
8549              Make_Attribute_Reference (Loc,
8550                Prefix         => Duplicate_Subexpr_Move_Checks (N),
8551                Attribute_Name => Name_Pool_Address),
8552
8553             --  Size_In_Storage_Elements
8554
8555              Make_Op_Divide (Loc,
8556                Left_Opnd  =>
8557                 Make_Attribute_Reference (Loc,
8558                   Prefix         =>
8559                     Make_Explicit_Dereference (Loc,
8560                       Duplicate_Subexpr_Move_Checks (N)),
8561                   Attribute_Name => Name_Size),
8562                Right_Opnd =>
8563                  Make_Integer_Literal (Loc, System_Storage_Unit)),
8564
8565             --  Alignment
8566
8567              Make_Attribute_Reference (Loc,
8568                Prefix         =>
8569                  Make_Explicit_Dereference (Loc,
8570                    Duplicate_Subexpr_Move_Checks (N)),
8571                Attribute_Name => Name_Alignment))));
8572
8573    exception
8574       when RE_Not_Available =>
8575          return;
8576    end Insert_Dereference_Action;
8577
8578    ------------------------------
8579    -- Make_Array_Comparison_Op --
8580    ------------------------------
8581
8582    --  This is a hand-coded expansion of the following generic function:
8583
8584    --  generic
8585    --    type elem is  (<>);
8586    --    type index is (<>);
8587    --    type a is array (index range <>) of elem;
8588
8589    --  function Gnnn (X : a; Y: a) return boolean is
8590    --    J : index := Y'first;
8591
8592    --  begin
8593    --    if X'length = 0 then
8594    --       return false;
8595
8596    --    elsif Y'length = 0 then
8597    --       return true;
8598
8599    --    else
8600    --      for I in X'range loop
8601    --        if X (I) = Y (J) then
8602    --          if J = Y'last then
8603    --            exit;
8604    --          else
8605    --            J := index'succ (J);
8606    --          end if;
8607
8608    --        else
8609    --           return X (I) > Y (J);
8610    --        end if;
8611    --      end loop;
8612
8613    --      return X'length > Y'length;
8614    --    end if;
8615    --  end Gnnn;
8616
8617    --  Note that since we are essentially doing this expansion by hand, we
8618    --  do not need to generate an actual or formal generic part, just the
8619    --  instantiated function itself.
8620
8621    function Make_Array_Comparison_Op
8622      (Typ : Entity_Id;
8623       Nod : Node_Id) return Node_Id
8624    is
8625       Loc : constant Source_Ptr := Sloc (Nod);
8626
8627       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
8628       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
8629       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
8630       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8631
8632       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
8633
8634       Loop_Statement : Node_Id;
8635       Loop_Body      : Node_Id;
8636       If_Stat        : Node_Id;
8637       Inner_If       : Node_Id;
8638       Final_Expr     : Node_Id;
8639       Func_Body      : Node_Id;
8640       Func_Name      : Entity_Id;
8641       Formals        : List_Id;
8642       Length1        : Node_Id;
8643       Length2        : Node_Id;
8644
8645    begin
8646       --  if J = Y'last then
8647       --     exit;
8648       --  else
8649       --     J := index'succ (J);
8650       --  end if;
8651
8652       Inner_If :=
8653         Make_Implicit_If_Statement (Nod,
8654           Condition =>
8655             Make_Op_Eq (Loc,
8656               Left_Opnd => New_Reference_To (J, Loc),
8657               Right_Opnd =>
8658                 Make_Attribute_Reference (Loc,
8659                   Prefix => New_Reference_To (Y, Loc),
8660                   Attribute_Name => Name_Last)),
8661
8662           Then_Statements => New_List (
8663                 Make_Exit_Statement (Loc)),
8664
8665           Else_Statements =>
8666             New_List (
8667               Make_Assignment_Statement (Loc,
8668                 Name => New_Reference_To (J, Loc),
8669                 Expression =>
8670                   Make_Attribute_Reference (Loc,
8671                     Prefix => New_Reference_To (Index, Loc),
8672                     Attribute_Name => Name_Succ,
8673                     Expressions => New_List (New_Reference_To (J, Loc))))));
8674
8675       --  if X (I) = Y (J) then
8676       --     if ... end if;
8677       --  else
8678       --     return X (I) > Y (J);
8679       --  end if;
8680
8681       Loop_Body :=
8682         Make_Implicit_If_Statement (Nod,
8683           Condition =>
8684             Make_Op_Eq (Loc,
8685               Left_Opnd =>
8686                 Make_Indexed_Component (Loc,
8687                   Prefix      => New_Reference_To (X, Loc),
8688                   Expressions => New_List (New_Reference_To (I, Loc))),
8689
8690               Right_Opnd =>
8691                 Make_Indexed_Component (Loc,
8692                   Prefix      => New_Reference_To (Y, Loc),
8693                   Expressions => New_List (New_Reference_To (J, Loc)))),
8694
8695           Then_Statements => New_List (Inner_If),
8696
8697           Else_Statements => New_List (
8698             Make_Simple_Return_Statement (Loc,
8699               Expression =>
8700                 Make_Op_Gt (Loc,
8701                   Left_Opnd =>
8702                     Make_Indexed_Component (Loc,
8703                       Prefix      => New_Reference_To (X, Loc),
8704                       Expressions => New_List (New_Reference_To (I, Loc))),
8705
8706                   Right_Opnd =>
8707                     Make_Indexed_Component (Loc,
8708                       Prefix      => New_Reference_To (Y, Loc),
8709                       Expressions => New_List (
8710                         New_Reference_To (J, Loc)))))));
8711
8712       --  for I in X'range loop
8713       --     if ... end if;
8714       --  end loop;
8715
8716       Loop_Statement :=
8717         Make_Implicit_Loop_Statement (Nod,
8718           Identifier => Empty,
8719
8720           Iteration_Scheme =>
8721             Make_Iteration_Scheme (Loc,
8722               Loop_Parameter_Specification =>
8723                 Make_Loop_Parameter_Specification (Loc,
8724                   Defining_Identifier => I,
8725                   Discrete_Subtype_Definition =>
8726                     Make_Attribute_Reference (Loc,
8727                       Prefix => New_Reference_To (X, Loc),
8728                       Attribute_Name => Name_Range))),
8729
8730           Statements => New_List (Loop_Body));
8731
8732       --    if X'length = 0 then
8733       --       return false;
8734       --    elsif Y'length = 0 then
8735       --       return true;
8736       --    else
8737       --      for ... loop ... end loop;
8738       --      return X'length > Y'length;
8739       --    end if;
8740
8741       Length1 :=
8742         Make_Attribute_Reference (Loc,
8743           Prefix => New_Reference_To (X, Loc),
8744           Attribute_Name => Name_Length);
8745
8746       Length2 :=
8747         Make_Attribute_Reference (Loc,
8748           Prefix => New_Reference_To (Y, Loc),
8749           Attribute_Name => Name_Length);
8750
8751       Final_Expr :=
8752         Make_Op_Gt (Loc,
8753           Left_Opnd  => Length1,
8754           Right_Opnd => Length2);
8755
8756       If_Stat :=
8757         Make_Implicit_If_Statement (Nod,
8758           Condition =>
8759             Make_Op_Eq (Loc,
8760               Left_Opnd =>
8761                 Make_Attribute_Reference (Loc,
8762                   Prefix => New_Reference_To (X, Loc),
8763                   Attribute_Name => Name_Length),
8764               Right_Opnd =>
8765                 Make_Integer_Literal (Loc, 0)),
8766
8767           Then_Statements =>
8768             New_List (
8769               Make_Simple_Return_Statement (Loc,
8770                 Expression => New_Reference_To (Standard_False, Loc))),
8771
8772           Elsif_Parts => New_List (
8773             Make_Elsif_Part (Loc,
8774               Condition =>
8775                 Make_Op_Eq (Loc,
8776                   Left_Opnd =>
8777                     Make_Attribute_Reference (Loc,
8778                       Prefix => New_Reference_To (Y, Loc),
8779                       Attribute_Name => Name_Length),
8780                   Right_Opnd =>
8781                     Make_Integer_Literal (Loc, 0)),
8782
8783               Then_Statements =>
8784                 New_List (
8785                   Make_Simple_Return_Statement (Loc,
8786                      Expression => New_Reference_To (Standard_True, Loc))))),
8787
8788           Else_Statements => New_List (
8789             Loop_Statement,
8790             Make_Simple_Return_Statement (Loc,
8791               Expression => Final_Expr)));
8792
8793       --  (X : a; Y: a)
8794
8795       Formals := New_List (
8796         Make_Parameter_Specification (Loc,
8797           Defining_Identifier => X,
8798           Parameter_Type      => New_Reference_To (Typ, Loc)),
8799
8800         Make_Parameter_Specification (Loc,
8801           Defining_Identifier => Y,
8802           Parameter_Type      => New_Reference_To (Typ, Loc)));
8803
8804       --  function Gnnn (...) return boolean is
8805       --    J : index := Y'first;
8806       --  begin
8807       --    if ... end if;
8808       --  end Gnnn;
8809
8810       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
8811
8812       Func_Body :=
8813         Make_Subprogram_Body (Loc,
8814           Specification =>
8815             Make_Function_Specification (Loc,
8816               Defining_Unit_Name       => Func_Name,
8817               Parameter_Specifications => Formals,
8818               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
8819
8820           Declarations => New_List (
8821             Make_Object_Declaration (Loc,
8822               Defining_Identifier => J,
8823               Object_Definition   => New_Reference_To (Index, Loc),
8824               Expression =>
8825                 Make_Attribute_Reference (Loc,
8826                   Prefix => New_Reference_To (Y, Loc),
8827                   Attribute_Name => Name_First))),
8828
8829           Handled_Statement_Sequence =>
8830             Make_Handled_Sequence_Of_Statements (Loc,
8831               Statements => New_List (If_Stat)));
8832
8833       return Func_Body;
8834    end Make_Array_Comparison_Op;
8835
8836    ---------------------------
8837    -- Make_Boolean_Array_Op --
8838    ---------------------------
8839
8840    --  For logical operations on boolean arrays, expand in line the following,
8841    --  replacing 'and' with 'or' or 'xor' where needed:
8842
8843    --    function Annn (A : typ; B: typ) return typ is
8844    --       C : typ;
8845    --    begin
8846    --       for J in A'range loop
8847    --          C (J) := A (J) op B (J);
8848    --       end loop;
8849    --       return C;
8850    --    end Annn;
8851
8852    --  Here typ is the boolean array type
8853
8854    function Make_Boolean_Array_Op
8855      (Typ : Entity_Id;
8856       N   : Node_Id) return Node_Id
8857    is
8858       Loc : constant Source_Ptr := Sloc (N);
8859
8860       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
8861       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
8862       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
8863       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8864
8865       A_J : Node_Id;
8866       B_J : Node_Id;
8867       C_J : Node_Id;
8868       Op  : Node_Id;
8869
8870       Formals        : List_Id;
8871       Func_Name      : Entity_Id;
8872       Func_Body      : Node_Id;
8873       Loop_Statement : Node_Id;
8874
8875    begin
8876       A_J :=
8877         Make_Indexed_Component (Loc,
8878           Prefix      => New_Reference_To (A, Loc),
8879           Expressions => New_List (New_Reference_To (J, Loc)));
8880
8881       B_J :=
8882         Make_Indexed_Component (Loc,
8883           Prefix      => New_Reference_To (B, Loc),
8884           Expressions => New_List (New_Reference_To (J, Loc)));
8885
8886       C_J :=
8887         Make_Indexed_Component (Loc,
8888           Prefix      => New_Reference_To (C, Loc),
8889           Expressions => New_List (New_Reference_To (J, Loc)));
8890
8891       if Nkind (N) = N_Op_And then
8892          Op :=
8893            Make_Op_And (Loc,
8894              Left_Opnd  => A_J,
8895              Right_Opnd => B_J);
8896
8897       elsif Nkind (N) = N_Op_Or then
8898          Op :=
8899            Make_Op_Or (Loc,
8900              Left_Opnd  => A_J,
8901              Right_Opnd => B_J);
8902
8903       else
8904          Op :=
8905            Make_Op_Xor (Loc,
8906              Left_Opnd  => A_J,
8907              Right_Opnd => B_J);
8908       end if;
8909
8910       Loop_Statement :=
8911         Make_Implicit_Loop_Statement (N,
8912           Identifier => Empty,
8913
8914           Iteration_Scheme =>
8915             Make_Iteration_Scheme (Loc,
8916               Loop_Parameter_Specification =>
8917                 Make_Loop_Parameter_Specification (Loc,
8918                   Defining_Identifier => J,
8919                   Discrete_Subtype_Definition =>
8920                     Make_Attribute_Reference (Loc,
8921                       Prefix => New_Reference_To (A, Loc),
8922                       Attribute_Name => Name_Range))),
8923
8924           Statements => New_List (
8925             Make_Assignment_Statement (Loc,
8926               Name       => C_J,
8927               Expression => Op)));
8928
8929       Formals := New_List (
8930         Make_Parameter_Specification (Loc,
8931           Defining_Identifier => A,
8932           Parameter_Type      => New_Reference_To (Typ, Loc)),
8933
8934         Make_Parameter_Specification (Loc,
8935           Defining_Identifier => B,
8936           Parameter_Type      => New_Reference_To (Typ, Loc)));
8937
8938       Func_Name :=
8939         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8940       Set_Is_Inlined (Func_Name);
8941
8942       Func_Body :=
8943         Make_Subprogram_Body (Loc,
8944           Specification =>
8945             Make_Function_Specification (Loc,
8946               Defining_Unit_Name       => Func_Name,
8947               Parameter_Specifications => Formals,
8948               Result_Definition        => New_Reference_To (Typ, Loc)),
8949
8950           Declarations => New_List (
8951             Make_Object_Declaration (Loc,
8952               Defining_Identifier => C,
8953               Object_Definition   => New_Reference_To (Typ, Loc))),
8954
8955           Handled_Statement_Sequence =>
8956             Make_Handled_Sequence_Of_Statements (Loc,
8957               Statements => New_List (
8958                 Loop_Statement,
8959                 Make_Simple_Return_Statement (Loc,
8960                   Expression => New_Reference_To (C, Loc)))));
8961
8962       return Func_Body;
8963    end Make_Boolean_Array_Op;
8964
8965    ------------------------
8966    -- Rewrite_Comparison --
8967    ------------------------
8968
8969    procedure Rewrite_Comparison (N : Node_Id) is
8970    begin
8971       if Nkind (N) = N_Type_Conversion then
8972          Rewrite_Comparison (Expression (N));
8973          return;
8974
8975       elsif Nkind (N) not in N_Op_Compare then
8976          return;
8977       end if;
8978
8979       declare
8980          Typ : constant Entity_Id := Etype (N);
8981          Op1 : constant Node_Id   := Left_Opnd (N);
8982          Op2 : constant Node_Id   := Right_Opnd (N);
8983
8984          Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
8985          --  Res indicates if compare outcome can be compile time determined
8986
8987          True_Result  : Boolean;
8988          False_Result : Boolean;
8989
8990       begin
8991          case N_Op_Compare (Nkind (N)) is
8992             when N_Op_Eq =>
8993                True_Result  := Res = EQ;
8994                False_Result := Res = LT or else Res = GT or else Res = NE;
8995
8996             when N_Op_Ge =>
8997                True_Result  := Res in Compare_GE;
8998                False_Result := Res = LT;
8999
9000                if Res = LE
9001                  and then Constant_Condition_Warnings
9002                  and then Comes_From_Source (Original_Node (N))
9003                  and then Nkind (Original_Node (N)) = N_Op_Ge
9004                  and then not In_Instance
9005                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
9006                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
9007                then
9008                   Error_Msg_N
9009                     ("can never be greater than, could replace by ""'=""?", N);
9010                end if;
9011
9012             when N_Op_Gt =>
9013                True_Result  := Res = GT;
9014                False_Result := Res in Compare_LE;
9015
9016             when N_Op_Lt =>
9017                True_Result  := Res = LT;
9018                False_Result := Res in Compare_GE;
9019
9020             when N_Op_Le =>
9021                True_Result  := Res in Compare_LE;
9022                False_Result := Res = GT;
9023
9024                if Res = GE
9025                  and then Constant_Condition_Warnings
9026                  and then Comes_From_Source (Original_Node (N))
9027                  and then Nkind (Original_Node (N)) = N_Op_Le
9028                  and then not In_Instance
9029                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
9030                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
9031                then
9032                   Error_Msg_N
9033                     ("can never be less than, could replace by ""'=""?", N);
9034                end if;
9035
9036             when N_Op_Ne =>
9037                True_Result  := Res = NE or else Res = GT or else Res = LT;
9038                False_Result := Res = EQ;
9039          end case;
9040
9041          if True_Result then
9042             Rewrite (N,
9043               Convert_To (Typ,
9044                 New_Occurrence_Of (Standard_True, Sloc (N))));
9045             Analyze_And_Resolve (N, Typ);
9046             Warn_On_Known_Condition (N);
9047
9048          elsif False_Result then
9049             Rewrite (N,
9050               Convert_To (Typ,
9051                 New_Occurrence_Of (Standard_False, Sloc (N))));
9052             Analyze_And_Resolve (N, Typ);
9053             Warn_On_Known_Condition (N);
9054          end if;
9055       end;
9056    end Rewrite_Comparison;
9057
9058    ----------------------------
9059    -- Safe_In_Place_Array_Op --
9060    ----------------------------
9061
9062    function Safe_In_Place_Array_Op
9063      (Lhs : Node_Id;
9064       Op1 : Node_Id;
9065       Op2 : Node_Id) return Boolean
9066    is
9067       Target : Entity_Id;
9068
9069       function Is_Safe_Operand (Op : Node_Id) return Boolean;
9070       --  Operand is safe if it cannot overlap part of the target of the
9071       --  operation. If the operand and the target are identical, the operand
9072       --  is safe. The operand can be empty in the case of negation.
9073
9074       function Is_Unaliased (N : Node_Id) return Boolean;
9075       --  Check that N is a stand-alone entity
9076
9077       ------------------
9078       -- Is_Unaliased --
9079       ------------------
9080
9081       function Is_Unaliased (N : Node_Id) return Boolean is
9082       begin
9083          return
9084            Is_Entity_Name (N)
9085              and then No (Address_Clause (Entity (N)))
9086              and then No (Renamed_Object (Entity (N)));
9087       end Is_Unaliased;
9088
9089       ---------------------
9090       -- Is_Safe_Operand --
9091       ---------------------
9092
9093       function Is_Safe_Operand (Op : Node_Id) return Boolean is
9094       begin
9095          if No (Op) then
9096             return True;
9097
9098          elsif Is_Entity_Name (Op) then
9099             return Is_Unaliased (Op);
9100
9101          elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
9102             return Is_Unaliased (Prefix (Op));
9103
9104          elsif Nkind (Op) = N_Slice then
9105             return
9106               Is_Unaliased (Prefix (Op))
9107                 and then Entity (Prefix (Op)) /= Target;
9108
9109          elsif Nkind (Op) = N_Op_Not then
9110             return Is_Safe_Operand (Right_Opnd (Op));
9111
9112          else
9113             return False;
9114          end if;
9115       end Is_Safe_Operand;
9116
9117       --  Start of processing for Is_Safe_In_Place_Array_Op
9118
9119    begin
9120       --  Skip this processing if the component size is different from system
9121       --  storage unit (since at least for NOT this would cause problems).
9122
9123       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
9124          return False;
9125
9126       --  Cannot do in place stuff on VM_Target since cannot pass addresses
9127
9128       elsif VM_Target /= No_VM then
9129          return False;
9130
9131       --  Cannot do in place stuff if non-standard Boolean representation
9132
9133       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
9134          return False;
9135
9136       elsif not Is_Unaliased (Lhs) then
9137          return False;
9138       else
9139          Target := Entity (Lhs);
9140
9141          return
9142            Is_Safe_Operand (Op1)
9143              and then Is_Safe_Operand (Op2);
9144       end if;
9145    end Safe_In_Place_Array_Op;
9146
9147    -----------------------
9148    -- Tagged_Membership --
9149    -----------------------
9150
9151    --  There are two different cases to consider depending on whether the right
9152    --  operand is a class-wide type or not. If not we just compare the actual
9153    --  tag of the left expr to the target type tag:
9154    --
9155    --     Left_Expr.Tag = Right_Type'Tag;
9156    --
9157    --  If it is a class-wide type we use the RT function CW_Membership which is
9158    --  usually implemented by looking in the ancestor tables contained in the
9159    --  dispatch table pointed by Left_Expr.Tag for Typ'Tag
9160
9161    --  Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9162    --  function IW_Membership which is usually implemented by looking in the
9163    --  table of abstract interface types plus the ancestor table contained in
9164    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9165
9166    function Tagged_Membership (N : Node_Id) return Node_Id is
9167       Left  : constant Node_Id    := Left_Opnd  (N);
9168       Right : constant Node_Id    := Right_Opnd (N);
9169       Loc   : constant Source_Ptr := Sloc (N);
9170
9171       Left_Type  : Entity_Id;
9172       Right_Type : Entity_Id;
9173       Obj_Tag    : Node_Id;
9174
9175    begin
9176       Left_Type  := Etype (Left);
9177       Right_Type := Etype (Right);
9178
9179       if Is_Class_Wide_Type (Left_Type) then
9180          Left_Type := Root_Type (Left_Type);
9181       end if;
9182
9183       Obj_Tag :=
9184         Make_Selected_Component (Loc,
9185           Prefix        => Relocate_Node (Left),
9186           Selector_Name =>
9187             New_Reference_To (First_Tag_Component (Left_Type), Loc));
9188
9189       if Is_Class_Wide_Type (Right_Type) then
9190
9191          --  No need to issue a run-time check if we statically know that the
9192          --  result of this membership test is always true. For example,
9193          --  considering the following declarations:
9194
9195          --    type Iface is interface;
9196          --    type T     is tagged null record;
9197          --    type DT    is new T and Iface with null record;
9198
9199          --    Obj1 : T;
9200          --    Obj2 : DT;
9201
9202          --  These membership tests are always true:
9203
9204          --    Obj1 in T'Class
9205          --    Obj2 in T'Class;
9206          --    Obj2 in Iface'Class;
9207
9208          --  We do not need to handle cases where the membership is illegal.
9209          --  For example:
9210
9211          --    Obj1 in DT'Class;     --  Compile time error
9212          --    Obj1 in Iface'Class;  --  Compile time error
9213
9214          if not Is_Class_Wide_Type (Left_Type)
9215            and then (Is_Ancestor (Etype (Right_Type), Left_Type)
9216                        or else (Is_Interface (Etype (Right_Type))
9217                                  and then Interface_Present_In_Ancestor
9218                                            (Typ   => Left_Type,
9219                                             Iface => Etype (Right_Type))))
9220          then
9221             return New_Reference_To (Standard_True, Loc);
9222          end if;
9223
9224          --  Ada 2005 (AI-251): Class-wide applied to interfaces
9225
9226          if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
9227
9228             --   Support to: "Iface_CW_Typ in Typ'Class"
9229
9230            or else Is_Interface (Left_Type)
9231          then
9232             --  Issue error if IW_Membership operation not available in a
9233             --  configurable run time setting.
9234
9235             if not RTE_Available (RE_IW_Membership) then
9236                Error_Msg_CRT
9237                  ("dynamic membership test on interface types", N);
9238                return Empty;
9239             end if;
9240
9241             return
9242               Make_Function_Call (Loc,
9243                  Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
9244                  Parameter_Associations => New_List (
9245                    Make_Attribute_Reference (Loc,
9246                      Prefix => Obj_Tag,
9247                      Attribute_Name => Name_Address),
9248                    New_Reference_To (
9249                      Node (First_Elmt
9250                             (Access_Disp_Table (Root_Type (Right_Type)))),
9251                      Loc)));
9252
9253          --  Ada 95: Normal case
9254
9255          else
9256             return
9257               Build_CW_Membership (Loc,
9258                 Obj_Tag_Node => Obj_Tag,
9259                 Typ_Tag_Node =>
9260                    New_Reference_To (
9261                      Node (First_Elmt
9262                             (Access_Disp_Table (Root_Type (Right_Type)))),
9263                      Loc));
9264          end if;
9265
9266       --  Right_Type is not a class-wide type
9267
9268       else
9269          --  No need to check the tag of the object if Right_Typ is abstract
9270
9271          if Is_Abstract_Type (Right_Type) then
9272             return New_Reference_To (Standard_False, Loc);
9273
9274          else
9275             return
9276               Make_Op_Eq (Loc,
9277                 Left_Opnd  => Obj_Tag,
9278                 Right_Opnd =>
9279                   New_Reference_To
9280                     (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
9281          end if;
9282       end if;
9283    end Tagged_Membership;
9284
9285    ------------------------------
9286    -- Unary_Op_Validity_Checks --
9287    ------------------------------
9288
9289    procedure Unary_Op_Validity_Checks (N : Node_Id) is
9290    begin
9291       if Validity_Checks_On and Validity_Check_Operands then
9292          Ensure_Valid (Right_Opnd (N));
9293       end if;
9294    end Unary_Op_Validity_Checks;
9295
9296 end Exp_Ch4;