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 accomodate 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 (Nod, Typ);
3444                         end if;
3445
3446                         Next_Elmt (Discr);
3447                      end loop;
3448                   end if;
3449                end;
3450
3451                --  We set the allocator as analyzed so that when we analyze the
3452                --  expression actions node, we do not get an unwanted recursive
3453                --  expansion of the allocator expression.
3454
3455                Set_Analyzed (N, True);
3456                Nod := Relocate_Node (N);
3457
3458                --  Here is the transformation:
3459                --    input:  new T
3460                --    output: Temp : constant ptr_T := new T;
3461                --            Init (Temp.all, ...);
3462                --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
3463                --    <CTRL>  Initialize (Finalizable (Temp.all));
3464
3465                --  Here ptr_T is the pointer type for the allocator, and is the
3466                --  subtype of the allocator.
3467
3468                Temp_Decl :=
3469                  Make_Object_Declaration (Loc,
3470                    Defining_Identifier => Temp,
3471                    Constant_Present    => True,
3472                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
3473                    Expression          => Nod);
3474
3475                Set_Assignment_OK (Temp_Decl);
3476                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
3477
3478                --  If the designated type is a task type or contains tasks,
3479                --  create block to activate created tasks, and insert
3480                --  declaration for Task_Image variable ahead of call.
3481
3482                if Has_Task (T) then
3483                   declare
3484                      L   : constant List_Id := New_List;
3485                      Blk : Node_Id;
3486                   begin
3487                      Build_Task_Allocate_Block (L, Nod, Args);
3488                      Blk := Last (L);
3489                      Insert_List_Before (First (Declarations (Blk)), Decls);
3490                      Insert_Actions (N, L);
3491                   end;
3492
3493                else
3494                   Insert_Action (N,
3495                     Make_Procedure_Call_Statement (Loc,
3496                       Name                   => New_Reference_To (Init, Loc),
3497                       Parameter_Associations => Args));
3498                end if;
3499
3500                if Controlled_Type (T) then
3501
3502                   --  Postpone the generation of a finalization call for the
3503                   --  current allocator if it acts as a coextension.
3504
3505                   if Is_Dynamic_Coextension (N) then
3506                      if No (Coextensions (N)) then
3507                         Set_Coextensions (N, New_Elmt_List);
3508                      end if;
3509
3510                      Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
3511
3512                   else
3513                      Flist :=
3514                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
3515
3516                      --  Anonymous access types created for access parameters
3517                      --  are attached to an explicitly constructed controller,
3518                      --  which ensures that they can be finalized properly,
3519                      --  even if their deallocation might not happen. The list
3520                      --  associated with the controller is doubly-linked. For
3521                      --  other anonymous access types, the object may end up
3522                      --  on the global final list which is singly-linked.
3523                      --  Work needed for access discriminants in Ada 2005 ???
3524
3525                      if Ekind (PtrT) = E_Anonymous_Access_Type
3526                        and then
3527                          Nkind (Associated_Node_For_Itype (PtrT))
3528                      not in N_Subprogram_Specification
3529                      then
3530                         Attach_Level := Uint_1;
3531                      else
3532                         Attach_Level := Uint_2;
3533                      end if;
3534
3535                      Insert_Actions (N,
3536                        Make_Init_Call (
3537                          Ref          => New_Copy_Tree (Arg1),
3538                          Typ          => T,
3539                          Flist_Ref    => Flist,
3540                          With_Attach  => Make_Integer_Literal (Loc,
3541                                            Intval => Attach_Level)));
3542                   end if;
3543                end if;
3544
3545                Rewrite (N, New_Reference_To (Temp, Loc));
3546                Analyze_And_Resolve (N, PtrT);
3547             end if;
3548          end if;
3549       end;
3550
3551       --  Ada 2005 (AI-251): If the allocator is for a class-wide interface
3552       --  object that has been rewritten as a reference, we displace "this"
3553       --  to reference properly its secondary dispatch table.
3554
3555       if Nkind (N) = N_Identifier
3556         and then Is_Interface (Dtyp)
3557       then
3558          Displace_Allocator_Pointer (N);
3559       end if;
3560
3561    exception
3562       when RE_Not_Available =>
3563          return;
3564    end Expand_N_Allocator;
3565
3566    -----------------------
3567    -- Expand_N_And_Then --
3568    -----------------------
3569
3570    --  Expand into conditional expression if Actions present, and also deal
3571    --  with optimizing case of arguments being True or False.
3572
3573    procedure Expand_N_And_Then (N : Node_Id) is
3574       Loc     : constant Source_Ptr := Sloc (N);
3575       Typ     : constant Entity_Id  := Etype (N);
3576       Left    : constant Node_Id    := Left_Opnd (N);
3577       Right   : constant Node_Id    := Right_Opnd (N);
3578       Actlist : List_Id;
3579
3580    begin
3581       --  Deal with non-standard booleans
3582
3583       if Is_Boolean_Type (Typ) then
3584          Adjust_Condition (Left);
3585          Adjust_Condition (Right);
3586          Set_Etype (N, Standard_Boolean);
3587       end if;
3588
3589       --  Check for cases of left argument is True or False
3590
3591       if Nkind (Left) = N_Identifier then
3592
3593          --  If left argument is True, change (True and then Right) to Right.
3594          --  Any actions associated with Right will be executed unconditionally
3595          --  and can thus be inserted into the tree unconditionally.
3596
3597          if Entity (Left) = Standard_True then
3598             if Present (Actions (N)) then
3599                Insert_Actions (N, Actions (N));
3600             end if;
3601
3602             Rewrite (N, Right);
3603             Adjust_Result_Type (N, Typ);
3604             return;
3605
3606          --  If left argument is False, change (False and then Right) to False.
3607          --  In this case we can forget the actions associated with Right,
3608          --  since they will never be executed.
3609
3610          elsif Entity (Left) = Standard_False then
3611             Kill_Dead_Code (Right);
3612             Kill_Dead_Code (Actions (N));
3613             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3614             Adjust_Result_Type (N, Typ);
3615             return;
3616          end if;
3617       end if;
3618
3619       --  If Actions are present, we expand
3620
3621       --     left and then right
3622
3623       --  into
3624
3625       --     if left then right else false end
3626
3627       --  with the actions becoming the Then_Actions of the conditional
3628       --  expression. This conditional expression is then further expanded
3629       --  (and will eventually disappear)
3630
3631       if Present (Actions (N)) then
3632          Actlist := Actions (N);
3633          Rewrite (N,
3634             Make_Conditional_Expression (Loc,
3635               Expressions => New_List (
3636                 Left,
3637                 Right,
3638                 New_Occurrence_Of (Standard_False, Loc))));
3639
3640          Set_Then_Actions (N, Actlist);
3641          Analyze_And_Resolve (N, Standard_Boolean);
3642          Adjust_Result_Type (N, Typ);
3643          return;
3644       end if;
3645
3646       --  No actions present, check for cases of right argument True/False
3647
3648       if Nkind (Right) = N_Identifier then
3649
3650          --  Change (Left and then True) to Left. Note that we know there are
3651          --  no actions associated with the True operand, since we just checked
3652          --  for this case above.
3653
3654          if Entity (Right) = Standard_True then
3655             Rewrite (N, Left);
3656
3657          --  Change (Left and then False) to False, making sure to preserve any
3658          --  side effects associated with the Left operand.
3659
3660          elsif Entity (Right) = Standard_False then
3661             Remove_Side_Effects (Left);
3662             Rewrite
3663               (N, New_Occurrence_Of (Standard_False, Loc));
3664          end if;
3665       end if;
3666
3667       Adjust_Result_Type (N, Typ);
3668    end Expand_N_And_Then;
3669
3670    -------------------------------------
3671    -- Expand_N_Conditional_Expression --
3672    -------------------------------------
3673
3674    --  Expand into expression actions if then/else actions present
3675
3676    procedure Expand_N_Conditional_Expression (N : Node_Id) is
3677       Loc    : constant Source_Ptr := Sloc (N);
3678       Cond   : constant Node_Id    := First (Expressions (N));
3679       Thenx  : constant Node_Id    := Next (Cond);
3680       Elsex  : constant Node_Id    := Next (Thenx);
3681       Typ    : constant Entity_Id  := Etype (N);
3682       Cnn    : Entity_Id;
3683       New_If : Node_Id;
3684
3685    begin
3686       --  If either then or else actions are present, then given:
3687
3688       --     if cond then then-expr else else-expr end
3689
3690       --  we insert the following sequence of actions (using Insert_Actions):
3691
3692       --      Cnn : typ;
3693       --      if cond then
3694       --         <<then actions>>
3695       --         Cnn := then-expr;
3696       --      else
3697       --         <<else actions>>
3698       --         Cnn := else-expr
3699       --      end if;
3700
3701       --  and replace the conditional expression by a reference to Cnn
3702
3703       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
3704          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
3705
3706          New_If :=
3707            Make_Implicit_If_Statement (N,
3708              Condition => Relocate_Node (Cond),
3709
3710              Then_Statements => New_List (
3711                Make_Assignment_Statement (Sloc (Thenx),
3712                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
3713                  Expression => Relocate_Node (Thenx))),
3714
3715              Else_Statements => New_List (
3716                Make_Assignment_Statement (Sloc (Elsex),
3717                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
3718                  Expression => Relocate_Node (Elsex))));
3719
3720          Set_Assignment_OK (Name (First (Then_Statements (New_If))));
3721          Set_Assignment_OK (Name (First (Else_Statements (New_If))));
3722
3723          if Present (Then_Actions (N)) then
3724             Insert_List_Before
3725               (First (Then_Statements (New_If)), Then_Actions (N));
3726          end if;
3727
3728          if Present (Else_Actions (N)) then
3729             Insert_List_Before
3730               (First (Else_Statements (New_If)), Else_Actions (N));
3731          end if;
3732
3733          Rewrite (N, New_Occurrence_Of (Cnn, Loc));
3734
3735          Insert_Action (N,
3736            Make_Object_Declaration (Loc,
3737              Defining_Identifier => Cnn,
3738              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
3739
3740          Insert_Action (N, New_If);
3741          Analyze_And_Resolve (N, Typ);
3742       end if;
3743    end Expand_N_Conditional_Expression;
3744
3745    -----------------------------------
3746    -- Expand_N_Explicit_Dereference --
3747    -----------------------------------
3748
3749    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
3750    begin
3751       --  Insert explicit dereference call for the checked storage pool case
3752
3753       Insert_Dereference_Action (Prefix (N));
3754    end Expand_N_Explicit_Dereference;
3755
3756    -----------------
3757    -- Expand_N_In --
3758    -----------------
3759
3760    procedure Expand_N_In (N : Node_Id) is
3761       Loc    : constant Source_Ptr := Sloc (N);
3762       Rtyp   : constant Entity_Id  := Etype (N);
3763       Lop    : constant Node_Id    := Left_Opnd (N);
3764       Rop    : constant Node_Id    := Right_Opnd (N);
3765       Static : constant Boolean    := Is_OK_Static_Expression (N);
3766
3767       procedure Substitute_Valid_Check;
3768       --  Replaces node N by Lop'Valid. This is done when we have an explicit
3769       --  test for the left operand being in range of its subtype.
3770
3771       ----------------------------
3772       -- Substitute_Valid_Check --
3773       ----------------------------
3774
3775       procedure Substitute_Valid_Check is
3776       begin
3777          Rewrite (N,
3778            Make_Attribute_Reference (Loc,
3779              Prefix         => Relocate_Node (Lop),
3780              Attribute_Name => Name_Valid));
3781
3782          Analyze_And_Resolve (N, Rtyp);
3783
3784          Error_Msg_N ("?explicit membership test may be optimized away", N);
3785          Error_Msg_N ("\?use ''Valid attribute instead", N);
3786          return;
3787       end Substitute_Valid_Check;
3788
3789    --  Start of processing for Expand_N_In
3790
3791    begin
3792       --  Check case of explicit test for an expression in range of its
3793       --  subtype. This is suspicious usage and we replace it with a 'Valid
3794       --  test and give a warning.
3795
3796       if Is_Scalar_Type (Etype (Lop))
3797         and then Nkind (Rop) in N_Has_Entity
3798         and then Etype (Lop) = Entity (Rop)
3799         and then Comes_From_Source (N)
3800         and then VM_Target = No_VM
3801       then
3802          Substitute_Valid_Check;
3803          return;
3804       end if;
3805
3806       --  Do validity check on operands
3807
3808       if Validity_Checks_On and Validity_Check_Operands then
3809          Ensure_Valid (Left_Opnd (N));
3810          Validity_Check_Range (Right_Opnd (N));
3811       end if;
3812
3813       --  Case of explicit range
3814
3815       if Nkind (Rop) = N_Range then
3816          declare
3817             Lo : constant Node_Id := Low_Bound (Rop);
3818             Hi : constant Node_Id := High_Bound (Rop);
3819
3820             Ltyp : constant Entity_Id := Etype (Lop);
3821
3822             Lo_Orig : constant Node_Id := Original_Node (Lo);
3823             Hi_Orig : constant Node_Id := Original_Node (Hi);
3824
3825             Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
3826             Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
3827
3828             Warn1 : constant Boolean :=
3829                       Constant_Condition_Warnings
3830                         and then Comes_From_Source (N);
3831             --  This must be true for any of the optimization warnings, we
3832             --  clearly want to give them only for source with the flag on.
3833
3834             Warn2 : constant Boolean :=
3835                       Warn1
3836                         and then Nkind (Original_Node (Rop)) = N_Range
3837                         and then Is_Integer_Type (Etype (Lo));
3838             --  For the case where only one bound warning is elided, we also
3839             --  insist on an explicit range and an integer type. The reason is
3840             --  that the use of enumeration ranges including an end point is
3841             --  common, as is the use of a subtype name, one of whose bounds
3842             --  is the same as the type of the expression.
3843
3844          begin
3845             --  If test is explicit x'first .. x'last, replace by valid check
3846
3847             if Is_Scalar_Type (Ltyp)
3848               and then Nkind (Lo_Orig) = N_Attribute_Reference
3849               and then Attribute_Name (Lo_Orig) = Name_First
3850               and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
3851               and then Entity (Prefix (Lo_Orig)) = Ltyp
3852               and then Nkind (Hi_Orig) = N_Attribute_Reference
3853               and then Attribute_Name (Hi_Orig) = Name_Last
3854               and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
3855               and then Entity (Prefix (Hi_Orig)) = Ltyp
3856               and then Comes_From_Source (N)
3857               and then VM_Target = No_VM
3858             then
3859                Substitute_Valid_Check;
3860                return;
3861             end if;
3862
3863             --  If bounds of type are known at compile time, and the end points
3864             --  are known at compile time and identical, this is another case
3865             --  for substituting a valid test. We only do this for discrete
3866             --  types, since it won't arise in practice for float types.
3867
3868             if Comes_From_Source (N)
3869               and then Is_Discrete_Type (Ltyp)
3870               and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
3871               and then Compile_Time_Known_Value (Type_Low_Bound  (Ltyp))
3872               and then Compile_Time_Known_Value (Lo)
3873               and then Compile_Time_Known_Value (Hi)
3874               and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
3875               and then Expr_Value (Type_Low_Bound  (Ltyp)) = Expr_Value (Lo)
3876             then
3877                Substitute_Valid_Check;
3878                return;
3879             end if;
3880
3881             --  If we have an explicit range, do a bit of optimization based
3882             --  on range analysis (we may be able to kill one or both checks).
3883
3884             --  If either check is known to fail, replace result by False since
3885             --  the other check does not matter. Preserve the static flag for
3886             --  legality checks, because we are constant-folding beyond RM 4.9.
3887
3888             if Lcheck = LT or else Ucheck = GT then
3889                if Warn1 then
3890                   Error_Msg_N ("?range test optimized away", N);
3891                   Error_Msg_N ("\?value is known to be out of range", N);
3892                end if;
3893
3894                Rewrite (N,
3895                  New_Reference_To (Standard_False, Loc));
3896                Analyze_And_Resolve (N, Rtyp);
3897                Set_Is_Static_Expression (N, Static);
3898
3899                return;
3900
3901             --  If both checks are known to succeed, replace result by True,
3902             --  since we know we are in range.
3903
3904             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
3905                if Warn1 then
3906                   Error_Msg_N ("?range test optimized away", N);
3907                   Error_Msg_N ("\?value is known to be in range", N);
3908                end if;
3909
3910                Rewrite (N,
3911                  New_Reference_To (Standard_True, Loc));
3912                Analyze_And_Resolve (N, Rtyp);
3913                Set_Is_Static_Expression (N, Static);
3914
3915                return;
3916
3917             --  If lower bound check succeeds and upper bound check is not
3918             --  known to succeed or fail, then replace the range check with
3919             --  a comparison against the upper bound.
3920
3921             elsif Lcheck in Compare_GE then
3922                if Warn2 then
3923                   Error_Msg_N ("?lower bound test optimized away", Lo);
3924                   Error_Msg_N ("\?value is known to be in range", Lo);
3925                end if;
3926
3927                Rewrite (N,
3928                  Make_Op_Le (Loc,
3929                    Left_Opnd  => Lop,
3930                    Right_Opnd => High_Bound (Rop)));
3931                Analyze_And_Resolve (N, Rtyp);
3932
3933                return;
3934
3935             --  If upper bound check succeeds and lower bound check is not
3936             --  known to succeed or fail, then replace the range check with
3937             --  a comparison against the lower bound.
3938
3939             elsif Ucheck in Compare_LE then
3940                if Warn2 then
3941                   Error_Msg_N ("?upper bound test optimized away", Hi);
3942                   Error_Msg_N ("\?value is known to be in range", Hi);
3943                end if;
3944
3945                Rewrite (N,
3946                  Make_Op_Ge (Loc,
3947                    Left_Opnd  => Lop,
3948                    Right_Opnd => Low_Bound (Rop)));
3949                Analyze_And_Resolve (N, Rtyp);
3950
3951                return;
3952             end if;
3953          end;
3954
3955          --  For all other cases of an explicit range, nothing to be done
3956
3957          return;
3958
3959       --  Here right operand is a subtype mark
3960
3961       else
3962          declare
3963             Typ    : Entity_Id        := Etype (Rop);
3964             Is_Acc : constant Boolean := Is_Access_Type (Typ);
3965             Obj    : Node_Id          := Lop;
3966             Cond   : Node_Id          := Empty;
3967
3968          begin
3969             Remove_Side_Effects (Obj);
3970
3971             --  For tagged type, do tagged membership operation
3972
3973             if Is_Tagged_Type (Typ) then
3974
3975                --  No expansion will be performed when VM_Target, as the VM
3976                --  back-ends will handle the membership tests directly (tags
3977                --  are not explicitly represented in Java objects, so the
3978                --  normal tagged membership expansion is not what we want).
3979
3980                if VM_Target = No_VM then
3981                   Rewrite (N, Tagged_Membership (N));
3982                   Analyze_And_Resolve (N, Rtyp);
3983                end if;
3984
3985                return;
3986
3987             --  If type is scalar type, rewrite as x in t'first .. t'last.
3988             --  This reason we do this is that the bounds may have the wrong
3989             --  type if they come from the original type definition.
3990
3991             elsif Is_Scalar_Type (Typ) then
3992                Rewrite (Rop,
3993                  Make_Range (Loc,
3994                    Low_Bound =>
3995                      Make_Attribute_Reference (Loc,
3996                        Attribute_Name => Name_First,
3997                        Prefix => New_Reference_To (Typ, Loc)),
3998
3999                    High_Bound =>
4000                      Make_Attribute_Reference (Loc,
4001                        Attribute_Name => Name_Last,
4002                        Prefix => New_Reference_To (Typ, Loc))));
4003                Analyze_And_Resolve (N, Rtyp);
4004                return;
4005
4006             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
4007             --  a membership test if the subtype mark denotes a constrained
4008             --  Unchecked_Union subtype and the expression lacks inferable
4009             --  discriminants.
4010
4011             elsif Is_Unchecked_Union (Base_Type (Typ))
4012               and then Is_Constrained (Typ)
4013               and then not Has_Inferable_Discriminants (Lop)
4014             then
4015                Insert_Action (N,
4016                  Make_Raise_Program_Error (Loc,
4017                    Reason => PE_Unchecked_Union_Restriction));
4018
4019                --  Prevent Gigi from generating incorrect code by rewriting
4020                --  the test as a standard False.
4021
4022                Rewrite (N,
4023                  New_Occurrence_Of (Standard_False, Loc));
4024
4025                return;
4026             end if;
4027
4028             --  Here we have a non-scalar type
4029
4030             if Is_Acc then
4031                Typ := Designated_Type (Typ);
4032             end if;
4033
4034             if not Is_Constrained (Typ) then
4035                Rewrite (N,
4036                  New_Reference_To (Standard_True, Loc));
4037                Analyze_And_Resolve (N, Rtyp);
4038
4039             --  For the constrained array case, we have to check the subscripts
4040             --  for an exact match if the lengths are non-zero (the lengths
4041             --  must match in any case).
4042
4043             elsif Is_Array_Type (Typ) then
4044
4045                Check_Subscripts : declare
4046                   function Construct_Attribute_Reference
4047                     (E   : Node_Id;
4048                      Nam : Name_Id;
4049                      Dim : Nat) return Node_Id;
4050                   --  Build attribute reference E'Nam(Dim)
4051
4052                   -----------------------------------
4053                   -- Construct_Attribute_Reference --
4054                   -----------------------------------
4055
4056                   function Construct_Attribute_Reference
4057                     (E   : Node_Id;
4058                      Nam : Name_Id;
4059                      Dim : Nat) return Node_Id
4060                   is
4061                   begin
4062                      return
4063                        Make_Attribute_Reference (Loc,
4064                          Prefix => E,
4065                          Attribute_Name => Nam,
4066                          Expressions => New_List (
4067                            Make_Integer_Literal (Loc, Dim)));
4068                   end Construct_Attribute_Reference;
4069
4070                --  Start processing for Check_Subscripts
4071
4072                begin
4073                   for J in 1 .. Number_Dimensions (Typ) loop
4074                      Evolve_And_Then (Cond,
4075                        Make_Op_Eq (Loc,
4076                          Left_Opnd  =>
4077                            Construct_Attribute_Reference
4078                              (Duplicate_Subexpr_No_Checks (Obj),
4079                               Name_First, J),
4080                          Right_Opnd =>
4081                            Construct_Attribute_Reference
4082                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
4083
4084                      Evolve_And_Then (Cond,
4085                        Make_Op_Eq (Loc,
4086                          Left_Opnd  =>
4087                            Construct_Attribute_Reference
4088                              (Duplicate_Subexpr_No_Checks (Obj),
4089                               Name_Last, J),
4090                          Right_Opnd =>
4091                            Construct_Attribute_Reference
4092                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
4093                   end loop;
4094
4095                   if Is_Acc then
4096                      Cond :=
4097                        Make_Or_Else (Loc,
4098                          Left_Opnd =>
4099                            Make_Op_Eq (Loc,
4100                              Left_Opnd  => Obj,
4101                              Right_Opnd => Make_Null (Loc)),
4102                          Right_Opnd => Cond);
4103                   end if;
4104
4105                   Rewrite (N, Cond);
4106                   Analyze_And_Resolve (N, Rtyp);
4107                end Check_Subscripts;
4108
4109             --  These are the cases where constraint checks may be required,
4110             --  e.g. records with possible discriminants
4111
4112             else
4113                --  Expand the test into a series of discriminant comparisons.
4114                --  The expression that is built is the negation of the one that
4115                --  is used for checking discriminant constraints.
4116
4117                Obj := Relocate_Node (Left_Opnd (N));
4118
4119                if Has_Discriminants (Typ) then
4120                   Cond := Make_Op_Not (Loc,
4121                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
4122
4123                   if Is_Acc then
4124                      Cond := Make_Or_Else (Loc,
4125                        Left_Opnd =>
4126                          Make_Op_Eq (Loc,
4127                            Left_Opnd  => Obj,
4128                            Right_Opnd => Make_Null (Loc)),
4129                        Right_Opnd => Cond);
4130                   end if;
4131
4132                else
4133                   Cond := New_Occurrence_Of (Standard_True, Loc);
4134                end if;
4135
4136                Rewrite (N, Cond);
4137                Analyze_And_Resolve (N, Rtyp);
4138             end if;
4139          end;
4140       end if;
4141    end Expand_N_In;
4142
4143    --------------------------------
4144    -- Expand_N_Indexed_Component --
4145    --------------------------------
4146
4147    procedure Expand_N_Indexed_Component (N : Node_Id) is
4148       Loc : constant Source_Ptr := Sloc (N);
4149       Typ : constant Entity_Id  := Etype (N);
4150       P   : constant Node_Id    := Prefix (N);
4151       T   : constant Entity_Id  := Etype (P);
4152
4153    begin
4154       --  A special optimization, if we have an indexed component that is
4155       --  selecting from a slice, then we can eliminate the slice, since, for
4156       --  example, x (i .. j)(k) is identical to x(k). The only difference is
4157       --  the range check required by the slice. The range check for the slice
4158       --  itself has already been generated. The range check for the
4159       --  subscripting operation is ensured by converting the subject to
4160       --  the subtype of the slice.
4161
4162       --  This optimization not only generates better code, avoiding slice
4163       --  messing especially in the packed case, but more importantly bypasses
4164       --  some problems in handling this peculiar case, for example, the issue
4165       --  of dealing specially with object renamings.
4166
4167       if Nkind (P) = N_Slice then
4168          Rewrite (N,
4169            Make_Indexed_Component (Loc,
4170              Prefix => Prefix (P),
4171              Expressions => New_List (
4172                Convert_To
4173                  (Etype (First_Index (Etype (P))),
4174                   First (Expressions (N))))));
4175          Analyze_And_Resolve (N, Typ);
4176          return;
4177       end if;
4178
4179       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4180       --  function, then additional actuals must be passed.
4181
4182       if Ada_Version >= Ada_05
4183         and then Is_Build_In_Place_Function_Call (P)
4184       then
4185          Make_Build_In_Place_Call_In_Anonymous_Context (P);
4186       end if;
4187
4188       --  If the prefix is an access type, then we unconditionally rewrite if
4189       --  as an explicit deference. This simplifies processing for several
4190       --  cases, including packed array cases and certain cases in which checks
4191       --  must be generated. We used to try to do this only when it was
4192       --  necessary, but it cleans up the code to do it all the time.
4193
4194       if Is_Access_Type (T) then
4195          Insert_Explicit_Dereference (P);
4196          Analyze_And_Resolve (P, Designated_Type (T));
4197       end if;
4198
4199       --  Generate index and validity checks
4200
4201       Generate_Index_Checks (N);
4202
4203       if Validity_Checks_On and then Validity_Check_Subscripts then
4204          Apply_Subscript_Validity_Checks (N);
4205       end if;
4206
4207       --  All done for the non-packed case
4208
4209       if not Is_Packed (Etype (Prefix (N))) then
4210          return;
4211       end if;
4212
4213       --  For packed arrays that are not bit-packed (i.e. the case of an array
4214       --  with one or more index types with a non-contiguous enumeration type),
4215       --  we can always use the normal packed element get circuit.
4216
4217       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
4218          Expand_Packed_Element_Reference (N);
4219          return;
4220       end if;
4221
4222       --  For a reference to a component of a bit packed array, we have to
4223       --  convert it to a reference to the corresponding Packed_Array_Type.
4224       --  We only want to do this for simple references, and not for:
4225
4226       --    Left side of assignment, or prefix of left side of assignment, or
4227       --    prefix of the prefix, to handle packed arrays of packed arrays,
4228       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4229
4230       --    Renaming objects in renaming associations
4231       --      This case is handled when a use of the renamed variable occurs
4232
4233       --    Actual parameters for a procedure call
4234       --      This case is handled in Exp_Ch6.Expand_Actuals
4235
4236       --    The second expression in a 'Read attribute reference
4237
4238       --    The prefix of an address or size attribute reference
4239
4240       --  The following circuit detects these exceptions
4241
4242       declare
4243          Child : Node_Id := N;
4244          Parnt : Node_Id := Parent (N);
4245
4246       begin
4247          loop
4248             if Nkind (Parnt) = N_Unchecked_Expression then
4249                null;
4250
4251             elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
4252                                    N_Procedure_Call_Statement)
4253               or else (Nkind (Parnt) = N_Parameter_Association
4254                         and then
4255                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
4256             then
4257                return;
4258
4259             elsif Nkind (Parnt) = N_Attribute_Reference
4260               and then (Attribute_Name (Parnt) = Name_Address
4261                          or else
4262                         Attribute_Name (Parnt) = Name_Size)
4263               and then Prefix (Parnt) = Child
4264             then
4265                return;
4266
4267             elsif Nkind (Parnt) = N_Assignment_Statement
4268               and then Name (Parnt) = Child
4269             then
4270                return;
4271
4272             --  If the expression is an index of an indexed component, it must
4273             --  be expanded regardless of context.
4274
4275             elsif Nkind (Parnt) = N_Indexed_Component
4276               and then Child /= Prefix (Parnt)
4277             then
4278                Expand_Packed_Element_Reference (N);
4279                return;
4280
4281             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
4282               and then Name (Parent (Parnt)) = Parnt
4283             then
4284                return;
4285
4286             elsif Nkind (Parnt) = N_Attribute_Reference
4287               and then Attribute_Name (Parnt) = Name_Read
4288               and then Next (First (Expressions (Parnt))) = Child
4289             then
4290                return;
4291
4292             elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
4293                and then Prefix (Parnt) = Child
4294             then
4295                null;
4296
4297             else
4298                Expand_Packed_Element_Reference (N);
4299                return;
4300             end if;
4301
4302             --  Keep looking up tree for unchecked expression, or if we are the
4303             --  prefix of a possible assignment left side.
4304
4305             Child := Parnt;
4306             Parnt := Parent (Child);
4307          end loop;
4308       end;
4309    end Expand_N_Indexed_Component;
4310
4311    ---------------------
4312    -- Expand_N_Not_In --
4313    ---------------------
4314
4315    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
4316    --  can be done. This avoids needing to duplicate this expansion code.
4317
4318    procedure Expand_N_Not_In (N : Node_Id) is
4319       Loc : constant Source_Ptr := Sloc (N);
4320       Typ : constant Entity_Id  := Etype (N);
4321       Cfs : constant Boolean    := Comes_From_Source (N);
4322
4323    begin
4324       Rewrite (N,
4325         Make_Op_Not (Loc,
4326           Right_Opnd =>
4327             Make_In (Loc,
4328               Left_Opnd  => Left_Opnd (N),
4329               Right_Opnd => Right_Opnd (N))));
4330
4331       --  We want this to appear as coming from source if original does (see
4332       --  transformations in Expand_N_In).
4333
4334       Set_Comes_From_Source (N, Cfs);
4335       Set_Comes_From_Source (Right_Opnd (N), Cfs);
4336
4337       --  Now analyze transformed node
4338
4339       Analyze_And_Resolve (N, Typ);
4340    end Expand_N_Not_In;
4341
4342    -------------------
4343    -- Expand_N_Null --
4344    -------------------
4345
4346    --  The only replacement required is for the case of a null of type that is
4347    --  an access to protected subprogram. We represent such access values as a
4348    --  record, and so we must replace the occurrence of null by the equivalent
4349    --  record (with a null address and a null pointer in it), so that the
4350    --  backend creates the proper value.
4351
4352    procedure Expand_N_Null (N : Node_Id) is
4353       Loc : constant Source_Ptr := Sloc (N);
4354       Typ : constant Entity_Id  := Etype (N);
4355       Agg : Node_Id;
4356
4357    begin
4358       if Is_Access_Protected_Subprogram_Type (Typ) then
4359          Agg :=
4360            Make_Aggregate (Loc,
4361              Expressions => New_List (
4362                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
4363                Make_Null (Loc)));
4364
4365          Rewrite (N, Agg);
4366          Analyze_And_Resolve (N, Equivalent_Type (Typ));
4367
4368          --  For subsequent semantic analysis, the node must retain its type.
4369          --  Gigi in any case replaces this type by the corresponding record
4370          --  type before processing the node.
4371
4372          Set_Etype (N, Typ);
4373       end if;
4374
4375    exception
4376       when RE_Not_Available =>
4377          return;
4378    end Expand_N_Null;
4379
4380    ---------------------
4381    -- Expand_N_Op_Abs --
4382    ---------------------
4383
4384    procedure Expand_N_Op_Abs (N : Node_Id) is
4385       Loc  : constant Source_Ptr := Sloc (N);
4386       Expr : constant Node_Id := Right_Opnd (N);
4387
4388    begin
4389       Unary_Op_Validity_Checks (N);
4390
4391       --  Deal with software overflow checking
4392
4393       if not Backend_Overflow_Checks_On_Target
4394          and then Is_Signed_Integer_Type (Etype (N))
4395          and then Do_Overflow_Check (N)
4396       then
4397          --  The only case to worry about is when the argument is equal to the
4398          --  largest negative number, so what we do is to insert the check:
4399
4400          --     [constraint_error when Expr = typ'Base'First]
4401
4402          --  with the usual Duplicate_Subexpr use coding for expr
4403
4404          Insert_Action (N,
4405            Make_Raise_Constraint_Error (Loc,
4406              Condition =>
4407                Make_Op_Eq (Loc,
4408                  Left_Opnd  => Duplicate_Subexpr (Expr),
4409                  Right_Opnd =>
4410                    Make_Attribute_Reference (Loc,
4411                      Prefix =>
4412                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
4413                      Attribute_Name => Name_First)),
4414              Reason => CE_Overflow_Check_Failed));
4415       end if;
4416
4417       --  Vax floating-point types case
4418
4419       if Vax_Float (Etype (N)) then
4420          Expand_Vax_Arith (N);
4421       end if;
4422    end Expand_N_Op_Abs;
4423
4424    ---------------------
4425    -- Expand_N_Op_Add --
4426    ---------------------
4427
4428    procedure Expand_N_Op_Add (N : Node_Id) is
4429       Typ : constant Entity_Id := Etype (N);
4430
4431    begin
4432       Binary_Op_Validity_Checks (N);
4433
4434       --  N + 0 = 0 + N = N for integer types
4435
4436       if Is_Integer_Type (Typ) then
4437          if Compile_Time_Known_Value (Right_Opnd (N))
4438            and then Expr_Value (Right_Opnd (N)) = Uint_0
4439          then
4440             Rewrite (N, Left_Opnd (N));
4441             return;
4442
4443          elsif Compile_Time_Known_Value (Left_Opnd (N))
4444            and then Expr_Value (Left_Opnd (N)) = Uint_0
4445          then
4446             Rewrite (N, Right_Opnd (N));
4447             return;
4448          end if;
4449       end if;
4450
4451       --  Arithmetic overflow checks for signed integer/fixed point types
4452
4453       if Is_Signed_Integer_Type (Typ)
4454         or else Is_Fixed_Point_Type (Typ)
4455       then
4456          Apply_Arithmetic_Overflow_Check (N);
4457          return;
4458
4459       --  Vax floating-point types case
4460
4461       elsif Vax_Float (Typ) then
4462          Expand_Vax_Arith (N);
4463       end if;
4464    end Expand_N_Op_Add;
4465
4466    ---------------------
4467    -- Expand_N_Op_And --
4468    ---------------------
4469
4470    procedure Expand_N_Op_And (N : Node_Id) is
4471       Typ : constant Entity_Id := Etype (N);
4472
4473    begin
4474       Binary_Op_Validity_Checks (N);
4475
4476       if Is_Array_Type (Etype (N)) then
4477          Expand_Boolean_Operator (N);
4478
4479       elsif Is_Boolean_Type (Etype (N)) then
4480          Adjust_Condition (Left_Opnd (N));
4481          Adjust_Condition (Right_Opnd (N));
4482          Set_Etype (N, Standard_Boolean);
4483          Adjust_Result_Type (N, Typ);
4484       end if;
4485    end Expand_N_Op_And;
4486
4487    ------------------------
4488    -- Expand_N_Op_Concat --
4489    ------------------------
4490
4491    Max_Available_String_Operands : Int := -1;
4492    --  This is initialized the first time this routine is called. It records
4493    --  a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4494    --  available in the run-time:
4495    --
4496    --    0  None available
4497    --    2  RE_Str_Concat available, RE_Str_Concat_3 not available
4498    --    3  RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4499    --    4  RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4500    --    5  All routines including RE_Str_Concat_5 available
4501
4502    Char_Concat_Available : Boolean;
4503    --  Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4504    --  all three are available, False if any one of these is unavailable.
4505
4506    procedure Expand_N_Op_Concat (N : Node_Id) is
4507       Opnds : List_Id;
4508       --  List of operands to be concatenated
4509
4510       Opnd  : Node_Id;
4511       --  Single operand for concatenation
4512
4513       Cnode : Node_Id;
4514       --  Node which is to be replaced by the result of concatenating the nodes
4515       --  in the list Opnds.
4516
4517       Atyp : Entity_Id;
4518       --  Array type of concatenation result type
4519
4520       Ctyp : Entity_Id;
4521       --  Component type of concatenation represented by Cnode
4522
4523    begin
4524       --  Initialize global variables showing run-time status
4525
4526       if Max_Available_String_Operands < 1 then
4527
4528          --  See what routines are available and set max operand count
4529          --  according to the highest count available in the run-time.
4530
4531          if not RTE_Available (RE_Str_Concat) then
4532             Max_Available_String_Operands := 0;
4533
4534          elsif not RTE_Available (RE_Str_Concat_3) then
4535             Max_Available_String_Operands := 2;
4536
4537          elsif not RTE_Available (RE_Str_Concat_4) then
4538             Max_Available_String_Operands := 3;
4539
4540          elsif not RTE_Available (RE_Str_Concat_5) then
4541             Max_Available_String_Operands := 4;
4542
4543          else
4544             Max_Available_String_Operands := 5;
4545          end if;
4546
4547          Char_Concat_Available :=
4548            RTE_Available (RE_Str_Concat_CC)
4549              and then
4550            RTE_Available (RE_Str_Concat_CS)
4551              and then
4552            RTE_Available (RE_Str_Concat_SC);
4553       end if;
4554
4555       --  Ensure validity of both operands
4556
4557       Binary_Op_Validity_Checks (N);
4558
4559       --  If we are the left operand of a concatenation higher up the tree,
4560       --  then do nothing for now, since we want to deal with a series of
4561       --  concatenations as a unit.
4562
4563       if Nkind (Parent (N)) = N_Op_Concat
4564         and then N = Left_Opnd (Parent (N))
4565       then
4566          return;
4567       end if;
4568
4569       --  We get here with a concatenation whose left operand may be a
4570       --  concatenation itself with a consistent type. We need to process
4571       --  these concatenation operands from left to right, which means
4572       --  from the deepest node in the tree to the highest node.
4573
4574       Cnode := N;
4575       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
4576          Cnode := Left_Opnd (Cnode);
4577       end loop;
4578
4579       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
4580       --  nodes above, so now we process bottom up, doing the operations. We
4581       --  gather a string that is as long as possible up to five operands
4582
4583       --  The outer loop runs more than once if there are more than five
4584       --  concatenations of type Standard.String, the most we handle for
4585       --  this case, or if more than one concatenation type is involved.
4586
4587       Outer : loop
4588          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
4589          Set_Parent (Opnds, N);
4590
4591          --  The inner loop gathers concatenation operands. We gather any
4592          --  number of these in the non-string case, or if no concatenation
4593          --  routines are available for string (since in that case we will
4594          --  treat string like any other non-string case). Otherwise we only
4595          --  gather as many operands as can be handled by the available
4596          --  procedures in the run-time library (normally 5, but may be
4597          --  less for the configurable run-time case).
4598
4599          Inner : while Cnode /= N
4600                    and then (Base_Type (Etype (Cnode)) /= Standard_String
4601                                or else
4602                              Max_Available_String_Operands = 0
4603                                or else
4604                              List_Length (Opnds) <
4605                                                Max_Available_String_Operands)
4606                    and then Base_Type (Etype (Cnode)) =
4607                             Base_Type (Etype (Parent (Cnode)))
4608          loop
4609             Cnode := Parent (Cnode);
4610             Append (Right_Opnd (Cnode), Opnds);
4611          end loop Inner;
4612
4613          --  Here we process the collected operands. First we convert singleton
4614          --  operands to singleton aggregates. This is skipped however for the
4615          --  case of two operands of type String since we have special routines
4616          --  for these cases.
4617
4618          Atyp := Base_Type (Etype (Cnode));
4619          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
4620
4621          if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
4622            or else not Char_Concat_Available
4623          then
4624             Opnd := First (Opnds);
4625             loop
4626                if Base_Type (Etype (Opnd)) = Ctyp then
4627                   Rewrite (Opnd,
4628                     Make_Aggregate (Sloc (Cnode),
4629                       Expressions => New_List (Relocate_Node (Opnd))));
4630                   Analyze_And_Resolve (Opnd, Atyp);
4631                end if;
4632
4633                Next (Opnd);
4634                exit when No (Opnd);
4635             end loop;
4636          end if;
4637
4638          --  Now call appropriate continuation routine
4639
4640          if Atyp = Standard_String
4641            and then Max_Available_String_Operands > 0
4642          then
4643             Expand_Concatenate_String (Cnode, Opnds);
4644          else
4645             Expand_Concatenate_Other (Cnode, Opnds);
4646          end if;
4647
4648          exit Outer when Cnode = N;
4649          Cnode := Parent (Cnode);
4650       end loop Outer;
4651    end Expand_N_Op_Concat;
4652
4653    ------------------------
4654    -- Expand_N_Op_Divide --
4655    ------------------------
4656
4657    procedure Expand_N_Op_Divide (N : Node_Id) is
4658       Loc   : constant Source_Ptr := Sloc (N);
4659       Lopnd : constant Node_Id    := Left_Opnd (N);
4660       Ropnd : constant Node_Id    := Right_Opnd (N);
4661       Ltyp  : constant Entity_Id  := Etype (Lopnd);
4662       Rtyp  : constant Entity_Id  := Etype (Ropnd);
4663       Typ   : Entity_Id           := Etype (N);
4664       Rknow : constant Boolean    := Is_Integer_Type (Typ)
4665                                        and then
4666                                          Compile_Time_Known_Value (Ropnd);
4667       Rval  : Uint;
4668
4669    begin
4670       Binary_Op_Validity_Checks (N);
4671
4672       if Rknow then
4673          Rval := Expr_Value (Ropnd);
4674       end if;
4675
4676       --  N / 1 = N for integer types
4677
4678       if Rknow and then Rval = Uint_1 then
4679          Rewrite (N, Lopnd);
4680          return;
4681       end if;
4682
4683       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4684       --  Is_Power_Of_2_For_Shift is set means that we know that our left
4685       --  operand is an unsigned integer, as required for this to work.
4686
4687       if Nkind (Ropnd) = N_Op_Expon
4688         and then Is_Power_Of_2_For_Shift (Ropnd)
4689
4690       --  We cannot do this transformation in configurable run time mode if we
4691       --  have 64-bit --  integers and long shifts are not available.
4692
4693         and then
4694           (Esize (Ltyp) <= 32
4695              or else Support_Long_Shifts_On_Target)
4696       then
4697          Rewrite (N,
4698            Make_Op_Shift_Right (Loc,
4699              Left_Opnd  => Lopnd,
4700              Right_Opnd =>
4701                Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
4702          Analyze_And_Resolve (N, Typ);
4703          return;
4704       end if;
4705
4706       --  Do required fixup of universal fixed operation
4707
4708       if Typ = Universal_Fixed then
4709          Fixup_Universal_Fixed_Operation (N);
4710          Typ := Etype (N);
4711       end if;
4712
4713       --  Divisions with fixed-point results
4714
4715       if Is_Fixed_Point_Type (Typ) then
4716
4717          --  No special processing if Treat_Fixed_As_Integer is set, since
4718          --  from a semantic point of view such operations are simply integer
4719          --  operations and will be treated that way.
4720
4721          if not Treat_Fixed_As_Integer (N) then
4722             if Is_Integer_Type (Rtyp) then
4723                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
4724             else
4725                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
4726             end if;
4727          end if;
4728
4729       --  Other cases of division of fixed-point operands. Again we exclude the
4730       --  case where Treat_Fixed_As_Integer is set.
4731
4732       elsif (Is_Fixed_Point_Type (Ltyp) or else
4733              Is_Fixed_Point_Type (Rtyp))
4734         and then not Treat_Fixed_As_Integer (N)
4735       then
4736          if Is_Integer_Type (Typ) then
4737             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
4738          else
4739             pragma Assert (Is_Floating_Point_Type (Typ));
4740             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
4741          end if;
4742
4743       --  Mixed-mode operations can appear in a non-static universal context,
4744       --  in which case the integer argument must be converted explicitly.
4745
4746       elsif Typ = Universal_Real
4747         and then Is_Integer_Type (Rtyp)
4748       then
4749          Rewrite (Ropnd,
4750            Convert_To (Universal_Real, Relocate_Node (Ropnd)));
4751
4752          Analyze_And_Resolve (Ropnd, Universal_Real);
4753
4754       elsif Typ = Universal_Real
4755         and then Is_Integer_Type (Ltyp)
4756       then
4757          Rewrite (Lopnd,
4758            Convert_To (Universal_Real, Relocate_Node (Lopnd)));
4759
4760          Analyze_And_Resolve (Lopnd, Universal_Real);
4761
4762       --  Non-fixed point cases, do integer zero divide and overflow checks
4763
4764       elsif Is_Integer_Type (Typ) then
4765          Apply_Divide_Check (N);
4766
4767          --  Check for 64-bit division available, or long shifts if the divisor
4768          --  is a small power of 2 (since such divides will be converted into
4769          --  long shifts.
4770
4771          if Esize (Ltyp) > 32
4772            and then not Support_64_Bit_Divides_On_Target
4773            and then
4774              (not Rknow
4775                 or else not Support_Long_Shifts_On_Target
4776                 or else (Rval /= Uint_2  and then
4777                          Rval /= Uint_4  and then
4778                          Rval /= Uint_8  and then
4779                          Rval /= Uint_16 and then
4780                          Rval /= Uint_32 and then
4781                          Rval /= Uint_64))
4782          then
4783             Error_Msg_CRT ("64-bit division", N);
4784          end if;
4785
4786       --  Deal with Vax_Float
4787
4788       elsif Vax_Float (Typ) then
4789          Expand_Vax_Arith (N);
4790          return;
4791       end if;
4792    end Expand_N_Op_Divide;
4793
4794    --------------------
4795    -- Expand_N_Op_Eq --
4796    --------------------
4797
4798    procedure Expand_N_Op_Eq (N : Node_Id) is
4799       Loc    : constant Source_Ptr := Sloc (N);
4800       Typ    : constant Entity_Id  := Etype (N);
4801       Lhs    : constant Node_Id    := Left_Opnd (N);
4802       Rhs    : constant Node_Id    := Right_Opnd (N);
4803       Bodies : constant List_Id    := New_List;
4804       A_Typ  : constant Entity_Id  := Etype (Lhs);
4805
4806       Typl    : Entity_Id := A_Typ;
4807       Op_Name : Entity_Id;
4808       Prim    : Elmt_Id;
4809
4810       procedure Build_Equality_Call (Eq : Entity_Id);
4811       --  If a constructed equality exists for the type or for its parent,
4812       --  build and analyze call, adding conversions if the operation is
4813       --  inherited.
4814
4815       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
4816       --  Determines whether a type has a subcomponent of an unconstrained
4817       --  Unchecked_Union subtype. Typ is a record type.
4818
4819       -------------------------
4820       -- Build_Equality_Call --
4821       -------------------------
4822
4823       procedure Build_Equality_Call (Eq : Entity_Id) is
4824          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
4825          L_Exp   : Node_Id := Relocate_Node (Lhs);
4826          R_Exp   : Node_Id := Relocate_Node (Rhs);
4827
4828       begin
4829          if Base_Type (Op_Type) /= Base_Type (A_Typ)
4830            and then not Is_Class_Wide_Type (A_Typ)
4831          then
4832             L_Exp := OK_Convert_To (Op_Type, L_Exp);
4833             R_Exp := OK_Convert_To (Op_Type, R_Exp);
4834          end if;
4835
4836          --  If we have an Unchecked_Union, we need to add the inferred
4837          --  discriminant values as actuals in the function call. At this
4838          --  point, the expansion has determined that both operands have
4839          --  inferable discriminants.
4840
4841          if Is_Unchecked_Union (Op_Type) then
4842             declare
4843                Lhs_Type      : constant Node_Id := Etype (L_Exp);
4844                Rhs_Type      : constant Node_Id := Etype (R_Exp);
4845                Lhs_Discr_Val : Node_Id;
4846                Rhs_Discr_Val : Node_Id;
4847
4848             begin
4849                --  Per-object constrained selected components require special
4850                --  attention. If the enclosing scope of the component is an
4851                --  Unchecked_Union, we cannot reference its discriminants
4852                --  directly. This is why we use the two extra parameters of
4853                --  the equality function of the enclosing Unchecked_Union.
4854
4855                --  type UU_Type (Discr : Integer := 0) is
4856                --     . . .
4857                --  end record;
4858                --  pragma Unchecked_Union (UU_Type);
4859
4860                --  1. Unchecked_Union enclosing record:
4861
4862                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
4863                --        . . .
4864                --        Comp : UU_Type (Discr);
4865                --        . . .
4866                --     end Enclosing_UU_Type;
4867                --     pragma Unchecked_Union (Enclosing_UU_Type);
4868
4869                --     Obj1 : Enclosing_UU_Type;
4870                --     Obj2 : Enclosing_UU_Type (1);
4871
4872                --     [. . .] Obj1 = Obj2 [. . .]
4873
4874                --     Generated code:
4875
4876                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4877
4878                --  A and B are the formal parameters of the equality function
4879                --  of Enclosing_UU_Type. The function always has two extra
4880                --  formals to capture the inferred discriminant values.
4881
4882                --  2. Non-Unchecked_Union enclosing record:
4883
4884                --     type
4885                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
4886                --     is record
4887                --        . . .
4888                --        Comp : UU_Type (Discr);
4889                --        . . .
4890                --     end Enclosing_Non_UU_Type;
4891
4892                --     Obj1 : Enclosing_Non_UU_Type;
4893                --     Obj2 : Enclosing_Non_UU_Type (1);
4894
4895                --     ...  Obj1 = Obj2 ...
4896
4897                --     Generated code:
4898
4899                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
4900                --                        obj1.discr, obj2.discr)) then
4901
4902                --  In this case we can directly reference the discriminants of
4903                --  the enclosing record.
4904
4905                --  Lhs of equality
4906
4907                if Nkind (Lhs) = N_Selected_Component
4908                  and then Has_Per_Object_Constraint
4909                             (Entity (Selector_Name (Lhs)))
4910                then
4911                   --  Enclosing record is an Unchecked_Union, use formal A
4912
4913                   if Is_Unchecked_Union (Scope
4914                        (Entity (Selector_Name (Lhs))))
4915                   then
4916                      Lhs_Discr_Val :=
4917                        Make_Identifier (Loc,
4918                          Chars => Name_A);
4919
4920                   --  Enclosing record is of a non-Unchecked_Union type, it is
4921                   --  possible to reference the discriminant.
4922
4923                   else
4924                      Lhs_Discr_Val :=
4925                        Make_Selected_Component (Loc,
4926                          Prefix => Prefix (Lhs),
4927                          Selector_Name =>
4928                            New_Copy
4929                              (Get_Discriminant_Value
4930                                 (First_Discriminant (Lhs_Type),
4931                                  Lhs_Type,
4932                                  Stored_Constraint (Lhs_Type))));
4933                   end if;
4934
4935                --  Comment needed here ???
4936
4937                else
4938                   --  Infer the discriminant value
4939
4940                   Lhs_Discr_Val :=
4941                     New_Copy
4942                       (Get_Discriminant_Value
4943                          (First_Discriminant (Lhs_Type),
4944                           Lhs_Type,
4945                           Stored_Constraint (Lhs_Type)));
4946                end if;
4947
4948                --  Rhs of equality
4949
4950                if Nkind (Rhs) = N_Selected_Component
4951                  and then Has_Per_Object_Constraint
4952                             (Entity (Selector_Name (Rhs)))
4953                then
4954                   if Is_Unchecked_Union
4955                        (Scope (Entity (Selector_Name (Rhs))))
4956                   then
4957                      Rhs_Discr_Val :=
4958                        Make_Identifier (Loc,
4959                          Chars => Name_B);
4960
4961                   else
4962                      Rhs_Discr_Val :=
4963                        Make_Selected_Component (Loc,
4964                          Prefix => Prefix (Rhs),
4965                          Selector_Name =>
4966                            New_Copy (Get_Discriminant_Value (
4967                              First_Discriminant (Rhs_Type),
4968                              Rhs_Type,
4969                              Stored_Constraint (Rhs_Type))));
4970
4971                   end if;
4972                else
4973                   Rhs_Discr_Val :=
4974                     New_Copy (Get_Discriminant_Value (
4975                       First_Discriminant (Rhs_Type),
4976                       Rhs_Type,
4977                       Stored_Constraint (Rhs_Type)));
4978
4979                end if;
4980
4981                Rewrite (N,
4982                  Make_Function_Call (Loc,
4983                    Name => New_Reference_To (Eq, Loc),
4984                    Parameter_Associations => New_List (
4985                      L_Exp,
4986                      R_Exp,
4987                      Lhs_Discr_Val,
4988                      Rhs_Discr_Val)));
4989             end;
4990
4991          --  Normal case, not an unchecked union
4992
4993          else
4994             Rewrite (N,
4995               Make_Function_Call (Loc,
4996                 Name => New_Reference_To (Eq, Loc),
4997                 Parameter_Associations => New_List (L_Exp, R_Exp)));
4998          end if;
4999
5000          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5001       end Build_Equality_Call;
5002
5003       ------------------------------------
5004       -- Has_Unconstrained_UU_Component --
5005       ------------------------------------
5006
5007       function Has_Unconstrained_UU_Component
5008         (Typ : Node_Id) return Boolean
5009       is
5010          Tdef  : constant Node_Id :=
5011                    Type_Definition (Declaration_Node (Base_Type (Typ)));
5012          Clist : Node_Id;
5013          Vpart : Node_Id;
5014
5015          function Component_Is_Unconstrained_UU
5016            (Comp : Node_Id) return Boolean;
5017          --  Determines whether the subtype of the component is an
5018          --  unconstrained Unchecked_Union.
5019
5020          function Variant_Is_Unconstrained_UU
5021            (Variant : Node_Id) return Boolean;
5022          --  Determines whether a component of the variant has an unconstrained
5023          --  Unchecked_Union subtype.
5024
5025          -----------------------------------
5026          -- Component_Is_Unconstrained_UU --
5027          -----------------------------------
5028
5029          function Component_Is_Unconstrained_UU
5030            (Comp : Node_Id) return Boolean
5031          is
5032          begin
5033             if Nkind (Comp) /= N_Component_Declaration then
5034                return False;
5035             end if;
5036
5037             declare
5038                Sindic : constant Node_Id :=
5039                           Subtype_Indication (Component_Definition (Comp));
5040
5041             begin
5042                --  Unconstrained nominal type. In the case of a constraint
5043                --  present, the node kind would have been N_Subtype_Indication.
5044
5045                if Nkind (Sindic) = N_Identifier then
5046                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
5047                end if;
5048
5049                return False;
5050             end;
5051          end Component_Is_Unconstrained_UU;
5052
5053          ---------------------------------
5054          -- Variant_Is_Unconstrained_UU --
5055          ---------------------------------
5056
5057          function Variant_Is_Unconstrained_UU
5058            (Variant : Node_Id) return Boolean
5059          is
5060             Clist : constant Node_Id := Component_List (Variant);
5061
5062          begin
5063             if Is_Empty_List (Component_Items (Clist)) then
5064                return False;
5065             end if;
5066
5067             --  We only need to test one component
5068
5069             declare
5070                Comp : Node_Id := First (Component_Items (Clist));
5071
5072             begin
5073                while Present (Comp) loop
5074                   if Component_Is_Unconstrained_UU (Comp) then
5075                      return True;
5076                   end if;
5077
5078                   Next (Comp);
5079                end loop;
5080             end;
5081
5082             --  None of the components withing the variant were of
5083             --  unconstrained Unchecked_Union type.
5084
5085             return False;
5086          end Variant_Is_Unconstrained_UU;
5087
5088       --  Start of processing for Has_Unconstrained_UU_Component
5089
5090       begin
5091          if Null_Present (Tdef) then
5092             return False;
5093          end if;
5094
5095          Clist := Component_List (Tdef);
5096          Vpart := Variant_Part (Clist);
5097
5098          --  Inspect available components
5099
5100          if Present (Component_Items (Clist)) then
5101             declare
5102                Comp : Node_Id := First (Component_Items (Clist));
5103
5104             begin
5105                while Present (Comp) loop
5106
5107                   --  One component is sufficient
5108
5109                   if Component_Is_Unconstrained_UU (Comp) then
5110                      return True;
5111                   end if;
5112
5113                   Next (Comp);
5114                end loop;
5115             end;
5116          end if;
5117
5118          --  Inspect available components withing variants
5119
5120          if Present (Vpart) then
5121             declare
5122                Variant : Node_Id := First (Variants (Vpart));
5123
5124             begin
5125                while Present (Variant) loop
5126
5127                   --  One component within a variant is sufficient
5128
5129                   if Variant_Is_Unconstrained_UU (Variant) then
5130                      return True;
5131                   end if;
5132
5133                   Next (Variant);
5134                end loop;
5135             end;
5136          end if;
5137
5138          --  Neither the available components, nor the components inside the
5139          --  variant parts were of an unconstrained Unchecked_Union subtype.
5140
5141          return False;
5142       end Has_Unconstrained_UU_Component;
5143
5144    --  Start of processing for Expand_N_Op_Eq
5145
5146    begin
5147       Binary_Op_Validity_Checks (N);
5148
5149       if Ekind (Typl) = E_Private_Type then
5150          Typl := Underlying_Type (Typl);
5151       elsif Ekind (Typl) = E_Private_Subtype then
5152          Typl := Underlying_Type (Base_Type (Typl));
5153       else
5154          null;
5155       end if;
5156
5157       --  It may happen in error situations that the underlying type is not
5158       --  set. The error will be detected later, here we just defend the
5159       --  expander code.
5160
5161       if No (Typl) then
5162          return;
5163       end if;
5164
5165       Typl := Base_Type (Typl);
5166
5167       --  Boolean types (requiring handling of non-standard case)
5168
5169       if Is_Boolean_Type (Typl) then
5170          Adjust_Condition (Left_Opnd (N));
5171          Adjust_Condition (Right_Opnd (N));
5172          Set_Etype (N, Standard_Boolean);
5173          Adjust_Result_Type (N, Typ);
5174
5175       --  Array types
5176
5177       elsif Is_Array_Type (Typl) then
5178
5179          --  If we are doing full validity checking, and it is possible for the
5180          --  array elements to be invalid then expand out array comparisons to
5181          --  make sure that we check the array elements.
5182
5183          if Validity_Check_Operands
5184            and then not Is_Known_Valid (Component_Type (Typl))
5185          then
5186             declare
5187                Save_Force_Validity_Checks : constant Boolean :=
5188                                               Force_Validity_Checks;
5189             begin
5190                Force_Validity_Checks := True;
5191                Rewrite (N,
5192                  Expand_Array_Equality
5193                   (N,
5194                    Relocate_Node (Lhs),
5195                    Relocate_Node (Rhs),
5196                    Bodies,
5197                    Typl));
5198                Insert_Actions (N, Bodies);
5199                Analyze_And_Resolve (N, Standard_Boolean);
5200                Force_Validity_Checks := Save_Force_Validity_Checks;
5201             end;
5202
5203          --  Packed case where both operands are known aligned
5204
5205          elsif Is_Bit_Packed_Array (Typl)
5206            and then not Is_Possibly_Unaligned_Object (Lhs)
5207            and then not Is_Possibly_Unaligned_Object (Rhs)
5208          then
5209             Expand_Packed_Eq (N);
5210
5211          --  Where the component type is elementary we can use a block bit
5212          --  comparison (if supported on the target) exception in the case
5213          --  of floating-point (negative zero issues require element by
5214          --  element comparison), and atomic types (where we must be sure
5215          --  to load elements independently) and possibly unaligned arrays.
5216
5217          elsif Is_Elementary_Type (Component_Type (Typl))
5218            and then not Is_Floating_Point_Type (Component_Type (Typl))
5219            and then not Is_Atomic (Component_Type (Typl))
5220            and then not Is_Possibly_Unaligned_Object (Lhs)
5221            and then not Is_Possibly_Unaligned_Object (Rhs)
5222            and then Support_Composite_Compare_On_Target
5223          then
5224             null;
5225
5226          --  For composite and floating-point cases, expand equality loop to
5227          --  make sure of using proper comparisons for tagged types, and
5228          --  correctly handling the floating-point case.
5229
5230          else
5231             Rewrite (N,
5232               Expand_Array_Equality
5233                 (N,
5234                  Relocate_Node (Lhs),
5235                  Relocate_Node (Rhs),
5236                  Bodies,
5237                  Typl));
5238             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5239             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5240          end if;
5241
5242       --  Record Types
5243
5244       elsif Is_Record_Type (Typl) then
5245
5246          --  For tagged types, use the primitive "="
5247
5248          if Is_Tagged_Type (Typl) then
5249
5250             --  No need to do anything else compiling under restriction
5251             --  No_Dispatching_Calls. During the semantic analysis we
5252             --  already notified such violation.
5253
5254             if Restriction_Active (No_Dispatching_Calls) then
5255                return;
5256             end if;
5257
5258             --  If this is derived from an untagged private type completed with
5259             --  a tagged type, it does not have a full view, so we use the
5260             --  primitive operations of the private type. This check should no
5261             --  longer be necessary when these types get their full views???
5262
5263             if Is_Private_Type (A_Typ)
5264               and then not Is_Tagged_Type (A_Typ)
5265               and then Is_Derived_Type (A_Typ)
5266               and then No (Full_View (A_Typ))
5267             then
5268                --  Search for equality operation, checking that the operands
5269                --  have the same type. Note that we must find a matching entry,
5270                --  or something is very wrong!
5271
5272                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
5273
5274                while Present (Prim) loop
5275                   exit when Chars (Node (Prim)) = Name_Op_Eq
5276                     and then Etype (First_Formal (Node (Prim))) =
5277                              Etype (Next_Formal (First_Formal (Node (Prim))))
5278                     and then
5279                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5280
5281                   Next_Elmt (Prim);
5282                end loop;
5283
5284                pragma Assert (Present (Prim));
5285                Op_Name := Node (Prim);
5286
5287             --  Find the type's predefined equality or an overriding
5288             --  user- defined equality. The reason for not simply calling
5289             --  Find_Prim_Op here is that there may be a user-defined
5290             --  overloaded equality op that precedes the equality that we want,
5291             --  so we have to explicitly search (e.g., there could be an
5292             --  equality with two different parameter types).
5293
5294             else
5295                if Is_Class_Wide_Type (Typl) then
5296                   Typl := Root_Type (Typl);
5297                end if;
5298
5299                Prim := First_Elmt (Primitive_Operations (Typl));
5300                while Present (Prim) loop
5301                   exit when Chars (Node (Prim)) = Name_Op_Eq
5302                     and then Etype (First_Formal (Node (Prim))) =
5303                              Etype (Next_Formal (First_Formal (Node (Prim))))
5304                     and then
5305                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5306
5307                   Next_Elmt (Prim);
5308                end loop;
5309
5310                pragma Assert (Present (Prim));
5311                Op_Name := Node (Prim);
5312             end if;
5313
5314             Build_Equality_Call (Op_Name);
5315
5316          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
5317          --  predefined equality operator for a type which has a subcomponent
5318          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
5319
5320          elsif Has_Unconstrained_UU_Component (Typl) then
5321             Insert_Action (N,
5322               Make_Raise_Program_Error (Loc,
5323                 Reason => PE_Unchecked_Union_Restriction));
5324
5325             --  Prevent Gigi from generating incorrect code by rewriting the
5326             --  equality as a standard False.
5327
5328             Rewrite (N,
5329               New_Occurrence_Of (Standard_False, Loc));
5330
5331          elsif Is_Unchecked_Union (Typl) then
5332
5333             --  If we can infer the discriminants of the operands, we make a
5334             --  call to the TSS equality function.
5335
5336             if Has_Inferable_Discriminants (Lhs)
5337                  and then
5338                Has_Inferable_Discriminants (Rhs)
5339             then
5340                Build_Equality_Call
5341                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
5342
5343             else
5344                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
5345                --  the predefined equality operator for an Unchecked_Union type
5346                --  if either of the operands lack inferable discriminants.
5347
5348                Insert_Action (N,
5349                  Make_Raise_Program_Error (Loc,
5350                    Reason => PE_Unchecked_Union_Restriction));
5351
5352                --  Prevent Gigi from generating incorrect code by rewriting
5353                --  the equality as a standard False.
5354
5355                Rewrite (N,
5356                  New_Occurrence_Of (Standard_False, Loc));
5357
5358             end if;
5359
5360          --  If a type support function is present (for complex cases), use it
5361
5362          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
5363             Build_Equality_Call
5364               (TSS (Root_Type (Typl), TSS_Composite_Equality));
5365
5366          --  Otherwise expand the component by component equality. Note that
5367          --  we never use block-bit comparisons for records, because of the
5368          --  problems with gaps. The backend will often be able to recombine
5369          --  the separate comparisons that we generate here.
5370
5371          else
5372             Remove_Side_Effects (Lhs);
5373             Remove_Side_Effects (Rhs);
5374             Rewrite (N,
5375               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
5376
5377             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5378             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5379          end if;
5380       end if;
5381
5382       --  Test if result is known at compile time
5383
5384       Rewrite_Comparison (N);
5385
5386       --  If we still have comparison for Vax_Float, process it
5387
5388       if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare  then
5389          Expand_Vax_Comparison (N);
5390          return;
5391       end if;
5392    end Expand_N_Op_Eq;
5393
5394    -----------------------
5395    -- Expand_N_Op_Expon --
5396    -----------------------
5397
5398    procedure Expand_N_Op_Expon (N : Node_Id) is
5399       Loc    : constant Source_Ptr := Sloc (N);
5400       Typ    : constant Entity_Id  := Etype (N);
5401       Rtyp   : constant Entity_Id  := Root_Type (Typ);
5402       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
5403       Bastyp : constant Node_Id    := Etype (Base);
5404       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
5405       Exptyp : constant Entity_Id  := Etype (Exp);
5406       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
5407       Expv   : Uint;
5408       Xnode  : Node_Id;
5409       Temp   : Node_Id;
5410       Rent   : RE_Id;
5411       Ent    : Entity_Id;
5412       Etyp   : Entity_Id;
5413
5414    begin
5415       Binary_Op_Validity_Checks (N);
5416
5417       --  If either operand is of a private type, then we have the use of an
5418       --  intrinsic operator, and we get rid of the privateness, by using root
5419       --  types of underlying types for the actual operation. Otherwise the
5420       --  private types will cause trouble if we expand multiplications or
5421       --  shifts etc. We also do this transformation if the result type is
5422       --  different from the base type.
5423
5424       if Is_Private_Type (Etype (Base))
5425            or else
5426          Is_Private_Type (Typ)
5427            or else
5428          Is_Private_Type (Exptyp)
5429            or else
5430          Rtyp /= Root_Type (Bastyp)
5431       then
5432          declare
5433             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
5434             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
5435
5436          begin
5437             Rewrite (N,
5438               Unchecked_Convert_To (Typ,
5439                 Make_Op_Expon (Loc,
5440                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
5441                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
5442             Analyze_And_Resolve (N, Typ);
5443             return;
5444          end;
5445       end if;
5446
5447       --  Test for case of known right argument
5448
5449       if Compile_Time_Known_Value (Exp) then
5450          Expv := Expr_Value (Exp);
5451
5452          --  We only fold small non-negative exponents. You might think we
5453          --  could fold small negative exponents for the real case, but we
5454          --  can't because we are required to raise Constraint_Error for
5455          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
5456          --  See ACVC test C4A012B.
5457
5458          if Expv >= 0 and then Expv <= 4 then
5459
5460             --  X ** 0 = 1 (or 1.0)
5461
5462             if Expv = 0 then
5463                if Ekind (Typ) in Integer_Kind then
5464                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
5465                else
5466                   Xnode := Make_Real_Literal (Loc, Ureal_1);
5467                end if;
5468
5469             --  X ** 1 = X
5470
5471             elsif Expv = 1 then
5472                Xnode := Base;
5473
5474             --  X ** 2 = X * X
5475
5476             elsif Expv = 2 then
5477                Xnode :=
5478                  Make_Op_Multiply (Loc,
5479                    Left_Opnd  => Duplicate_Subexpr (Base),
5480                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
5481
5482             --  X ** 3 = X * X * X
5483
5484             elsif Expv = 3 then
5485                Xnode :=
5486                  Make_Op_Multiply (Loc,
5487                    Left_Opnd =>
5488                      Make_Op_Multiply (Loc,
5489                        Left_Opnd  => Duplicate_Subexpr (Base),
5490                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
5491                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
5492
5493             --  X ** 4  ->
5494             --    En : constant base'type := base * base;
5495             --    ...
5496             --    En * En
5497
5498             else -- Expv = 4
5499                Temp :=
5500                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5501
5502                Insert_Actions (N, New_List (
5503                  Make_Object_Declaration (Loc,
5504                    Defining_Identifier => Temp,
5505                    Constant_Present    => True,
5506                    Object_Definition   => New_Reference_To (Typ, Loc),
5507                    Expression =>
5508                      Make_Op_Multiply (Loc,
5509                        Left_Opnd  => Duplicate_Subexpr (Base),
5510                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
5511
5512                Xnode :=
5513                  Make_Op_Multiply (Loc,
5514                    Left_Opnd  => New_Reference_To (Temp, Loc),
5515                    Right_Opnd => New_Reference_To (Temp, Loc));
5516             end if;
5517
5518             Rewrite (N, Xnode);
5519             Analyze_And_Resolve (N, Typ);
5520             return;
5521          end if;
5522       end if;
5523
5524       --  Case of (2 ** expression) appearing as an argument of an integer
5525       --  multiplication, or as the right argument of a division of a non-
5526       --  negative integer. In such cases we leave the node untouched, setting
5527       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5528       --  of the higher level node converts it into a shift.
5529
5530       --  Note: this transformation is not applicable for a modular type with
5531       --  a non-binary modulus in the multiplication case, since we get a wrong
5532       --  result if the shift causes an overflow before the modular reduction.
5533
5534       if Nkind (Base) = N_Integer_Literal
5535         and then Intval (Base) = 2
5536         and then Is_Integer_Type (Root_Type (Exptyp))
5537         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
5538         and then Is_Unsigned_Type (Exptyp)
5539         and then not Ovflo
5540         and then Nkind (Parent (N)) in N_Binary_Op
5541       then
5542          declare
5543             P : constant Node_Id := Parent (N);
5544             L : constant Node_Id := Left_Opnd (P);
5545             R : constant Node_Id := Right_Opnd (P);
5546
5547          begin
5548             if (Nkind (P) = N_Op_Multiply
5549                  and then not Non_Binary_Modulus (Typ)
5550                  and then
5551                    ((Is_Integer_Type (Etype (L)) and then R = N)
5552                        or else
5553                     (Is_Integer_Type (Etype (R)) and then L = N))
5554                  and then not Do_Overflow_Check (P))
5555
5556               or else
5557                 (Nkind (P) = N_Op_Divide
5558                   and then Is_Integer_Type (Etype (L))
5559                   and then Is_Unsigned_Type (Etype (L))
5560                   and then R = N
5561                   and then not Do_Overflow_Check (P))
5562             then
5563                Set_Is_Power_Of_2_For_Shift (N);
5564                return;
5565             end if;
5566          end;
5567       end if;
5568
5569       --  Fall through if exponentiation must be done using a runtime routine
5570
5571       --  First deal with modular case
5572
5573       if Is_Modular_Integer_Type (Rtyp) then
5574
5575          --  Non-binary case, we call the special exponentiation routine for
5576          --  the non-binary case, converting the argument to Long_Long_Integer
5577          --  and passing the modulus value. Then the result is converted back
5578          --  to the base type.
5579
5580          if Non_Binary_Modulus (Rtyp) then
5581             Rewrite (N,
5582               Convert_To (Typ,
5583                 Make_Function_Call (Loc,
5584                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
5585                   Parameter_Associations => New_List (
5586                     Convert_To (Standard_Integer, Base),
5587                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
5588                     Exp))));
5589
5590          --  Binary case, in this case, we call one of two routines, either the
5591          --  unsigned integer case, or the unsigned long long integer case,
5592          --  with a final "and" operation to do the required mod.
5593
5594          else
5595             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
5596                Ent := RTE (RE_Exp_Unsigned);
5597             else
5598                Ent := RTE (RE_Exp_Long_Long_Unsigned);
5599             end if;
5600
5601             Rewrite (N,
5602               Convert_To (Typ,
5603                 Make_Op_And (Loc,
5604                   Left_Opnd =>
5605                     Make_Function_Call (Loc,
5606                       Name => New_Reference_To (Ent, Loc),
5607                       Parameter_Associations => New_List (
5608                         Convert_To (Etype (First_Formal (Ent)), Base),
5609                         Exp)),
5610                    Right_Opnd =>
5611                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
5612
5613          end if;
5614
5615          --  Common exit point for modular type case
5616
5617          Analyze_And_Resolve (N, Typ);
5618          return;
5619
5620       --  Signed integer cases, done using either Integer or Long_Long_Integer.
5621       --  It is not worth having routines for Short_[Short_]Integer, since for
5622       --  most machines it would not help, and it would generate more code that
5623       --  might need certification when a certified run time is required.
5624
5625       --  In the integer cases, we have two routines, one for when overflow
5626       --  checks are required, and one when they are not required, since there
5627       --  is a real gain in omitting checks on many machines.
5628
5629       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
5630         or else (Rtyp = Base_Type (Standard_Long_Integer)
5631                    and then
5632                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
5633         or else (Rtyp = Universal_Integer)
5634       then
5635          Etyp := Standard_Long_Long_Integer;
5636
5637          if Ovflo then
5638             Rent := RE_Exp_Long_Long_Integer;
5639          else
5640             Rent := RE_Exn_Long_Long_Integer;
5641          end if;
5642
5643       elsif Is_Signed_Integer_Type (Rtyp) then
5644          Etyp := Standard_Integer;
5645
5646          if Ovflo then
5647             Rent := RE_Exp_Integer;
5648          else
5649             Rent := RE_Exn_Integer;
5650          end if;
5651
5652       --  Floating-point cases, always done using Long_Long_Float. We do not
5653       --  need separate routines for the overflow case here, since in the case
5654       --  of floating-point, we generate infinities anyway as a rule (either
5655       --  that or we automatically trap overflow), and if there is an infinity
5656       --  generated and a range check is required, the check will fail anyway.
5657
5658       else
5659          pragma Assert (Is_Floating_Point_Type (Rtyp));
5660          Etyp := Standard_Long_Long_Float;
5661          Rent := RE_Exn_Long_Long_Float;
5662       end if;
5663
5664       --  Common processing for integer cases and floating-point cases.
5665       --  If we are in the right type, we can call runtime routine directly
5666
5667       if Typ = Etyp
5668         and then Rtyp /= Universal_Integer
5669         and then Rtyp /= Universal_Real
5670       then
5671          Rewrite (N,
5672            Make_Function_Call (Loc,
5673              Name => New_Reference_To (RTE (Rent), Loc),
5674              Parameter_Associations => New_List (Base, Exp)));
5675
5676       --  Otherwise we have to introduce conversions (conversions are also
5677       --  required in the universal cases, since the runtime routine is
5678       --  typed using one of the standard types.
5679
5680       else
5681          Rewrite (N,
5682            Convert_To (Typ,
5683              Make_Function_Call (Loc,
5684                Name => New_Reference_To (RTE (Rent), Loc),
5685                Parameter_Associations => New_List (
5686                  Convert_To (Etyp, Base),
5687                  Exp))));
5688       end if;
5689
5690       Analyze_And_Resolve (N, Typ);
5691       return;
5692
5693    exception
5694       when RE_Not_Available =>
5695          return;
5696    end Expand_N_Op_Expon;
5697
5698    --------------------
5699    -- Expand_N_Op_Ge --
5700    --------------------
5701
5702    procedure Expand_N_Op_Ge (N : Node_Id) is
5703       Typ  : constant Entity_Id := Etype (N);
5704       Op1  : constant Node_Id   := Left_Opnd (N);
5705       Op2  : constant Node_Id   := Right_Opnd (N);
5706       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5707
5708    begin
5709       Binary_Op_Validity_Checks (N);
5710
5711       if Is_Array_Type (Typ1) then
5712          Expand_Array_Comparison (N);
5713          return;
5714       end if;
5715
5716       if Is_Boolean_Type (Typ1) then
5717          Adjust_Condition (Op1);
5718          Adjust_Condition (Op2);
5719          Set_Etype (N, Standard_Boolean);
5720          Adjust_Result_Type (N, Typ);
5721       end if;
5722
5723       Rewrite_Comparison (N);
5724
5725       --  If we still have comparison, and Vax_Float type, process it
5726
5727       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5728          Expand_Vax_Comparison (N);
5729          return;
5730       end if;
5731    end Expand_N_Op_Ge;
5732
5733    --------------------
5734    -- Expand_N_Op_Gt --
5735    --------------------
5736
5737    procedure Expand_N_Op_Gt (N : Node_Id) is
5738       Typ  : constant Entity_Id := Etype (N);
5739       Op1  : constant Node_Id   := Left_Opnd (N);
5740       Op2  : constant Node_Id   := Right_Opnd (N);
5741       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5742
5743    begin
5744       Binary_Op_Validity_Checks (N);
5745
5746       if Is_Array_Type (Typ1) then
5747          Expand_Array_Comparison (N);
5748          return;
5749       end if;
5750
5751       if Is_Boolean_Type (Typ1) then
5752          Adjust_Condition (Op1);
5753          Adjust_Condition (Op2);
5754          Set_Etype (N, Standard_Boolean);
5755          Adjust_Result_Type (N, Typ);
5756       end if;
5757
5758       Rewrite_Comparison (N);
5759
5760       --  If we still have comparison, and Vax_Float type, process it
5761
5762       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5763          Expand_Vax_Comparison (N);
5764          return;
5765       end if;
5766    end Expand_N_Op_Gt;
5767
5768    --------------------
5769    -- Expand_N_Op_Le --
5770    --------------------
5771
5772    procedure Expand_N_Op_Le (N : Node_Id) is
5773       Typ  : constant Entity_Id := Etype (N);
5774       Op1  : constant Node_Id   := Left_Opnd (N);
5775       Op2  : constant Node_Id   := Right_Opnd (N);
5776       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5777
5778    begin
5779       Binary_Op_Validity_Checks (N);
5780
5781       if Is_Array_Type (Typ1) then
5782          Expand_Array_Comparison (N);
5783          return;
5784       end if;
5785
5786       if Is_Boolean_Type (Typ1) then
5787          Adjust_Condition (Op1);
5788          Adjust_Condition (Op2);
5789          Set_Etype (N, Standard_Boolean);
5790          Adjust_Result_Type (N, Typ);
5791       end if;
5792
5793       Rewrite_Comparison (N);
5794
5795       --  If we still have comparison, and Vax_Float type, process it
5796
5797       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5798          Expand_Vax_Comparison (N);
5799          return;
5800       end if;
5801    end Expand_N_Op_Le;
5802
5803    --------------------
5804    -- Expand_N_Op_Lt --
5805    --------------------
5806
5807    procedure Expand_N_Op_Lt (N : Node_Id) is
5808       Typ  : constant Entity_Id := Etype (N);
5809       Op1  : constant Node_Id   := Left_Opnd (N);
5810       Op2  : constant Node_Id   := Right_Opnd (N);
5811       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5812
5813    begin
5814       Binary_Op_Validity_Checks (N);
5815
5816       if Is_Array_Type (Typ1) then
5817          Expand_Array_Comparison (N);
5818          return;
5819       end if;
5820
5821       if Is_Boolean_Type (Typ1) then
5822          Adjust_Condition (Op1);
5823          Adjust_Condition (Op2);
5824          Set_Etype (N, Standard_Boolean);
5825          Adjust_Result_Type (N, Typ);
5826       end if;
5827
5828       Rewrite_Comparison (N);
5829
5830       --  If we still have comparison, and Vax_Float type, process it
5831
5832       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5833          Expand_Vax_Comparison (N);
5834          return;
5835       end if;
5836    end Expand_N_Op_Lt;
5837
5838    -----------------------
5839    -- Expand_N_Op_Minus --
5840    -----------------------
5841
5842    procedure Expand_N_Op_Minus (N : Node_Id) is
5843       Loc : constant Source_Ptr := Sloc (N);
5844       Typ : constant Entity_Id  := Etype (N);
5845
5846    begin
5847       Unary_Op_Validity_Checks (N);
5848
5849       if not Backend_Overflow_Checks_On_Target
5850          and then Is_Signed_Integer_Type (Etype (N))
5851          and then Do_Overflow_Check (N)
5852       then
5853          --  Software overflow checking expands -expr into (0 - expr)
5854
5855          Rewrite (N,
5856            Make_Op_Subtract (Loc,
5857              Left_Opnd  => Make_Integer_Literal (Loc, 0),
5858              Right_Opnd => Right_Opnd (N)));
5859
5860          Analyze_And_Resolve (N, Typ);
5861
5862       --  Vax floating-point types case
5863
5864       elsif Vax_Float (Etype (N)) then
5865          Expand_Vax_Arith (N);
5866       end if;
5867    end Expand_N_Op_Minus;
5868
5869    ---------------------
5870    -- Expand_N_Op_Mod --
5871    ---------------------
5872
5873    procedure Expand_N_Op_Mod (N : Node_Id) is
5874       Loc   : constant Source_Ptr := Sloc (N);
5875       Typ   : constant Entity_Id  := Etype (N);
5876       Left  : constant Node_Id    := Left_Opnd (N);
5877       Right : constant Node_Id    := Right_Opnd (N);
5878       DOC   : constant Boolean    := Do_Overflow_Check (N);
5879       DDC   : constant Boolean    := Do_Division_Check (N);
5880
5881       LLB : Uint;
5882       Llo : Uint;
5883       Lhi : Uint;
5884       LOK : Boolean;
5885       Rlo : Uint;
5886       Rhi : Uint;
5887       ROK : Boolean;
5888
5889       pragma Warnings (Off, Lhi);
5890
5891    begin
5892       Binary_Op_Validity_Checks (N);
5893
5894       Determine_Range (Right, ROK, Rlo, Rhi);
5895       Determine_Range (Left,  LOK, Llo, Lhi);
5896
5897       --  Convert mod to rem if operands are known non-negative. We do this
5898       --  since it is quite likely that this will improve the quality of code,
5899       --  (the operation now corresponds to the hardware remainder), and it
5900       --  does not seem likely that it could be harmful.
5901
5902       if LOK and then Llo >= 0
5903            and then
5904          ROK and then Rlo >= 0
5905       then
5906          Rewrite (N,
5907            Make_Op_Rem (Sloc (N),
5908              Left_Opnd  => Left_Opnd (N),
5909              Right_Opnd => Right_Opnd (N)));
5910
5911          --  Instead of reanalyzing the node we do the analysis manually. This
5912          --  avoids anomalies when the replacement is done in an instance and
5913          --  is epsilon more efficient.
5914
5915          Set_Entity            (N, Standard_Entity (S_Op_Rem));
5916          Set_Etype             (N, Typ);
5917          Set_Do_Overflow_Check (N, DOC);
5918          Set_Do_Division_Check (N, DDC);
5919          Expand_N_Op_Rem (N);
5920          Set_Analyzed (N);
5921
5922       --  Otherwise, normal mod processing
5923
5924       else
5925          if Is_Integer_Type (Etype (N)) then
5926             Apply_Divide_Check (N);
5927          end if;
5928
5929          --  Apply optimization x mod 1 = 0. We don't really need that with
5930          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
5931          --  certainly harmless.
5932
5933          if Is_Integer_Type (Etype (N))
5934            and then Compile_Time_Known_Value (Right)
5935            and then Expr_Value (Right) = Uint_1
5936          then
5937             Rewrite (N, Make_Integer_Literal (Loc, 0));
5938             Analyze_And_Resolve (N, Typ);
5939             return;
5940          end if;
5941
5942          --  Deal with annoying case of largest negative number remainder
5943          --  minus one. Gigi does not handle this case correctly, because
5944          --  it generates a divide instruction which may trap in this case.
5945
5946          --  In fact the check is quite easy, if the right operand is -1, then
5947          --  the mod value is always 0, and we can just ignore the left operand
5948          --  completely in this case.
5949
5950          --  The operand type may be private (e.g. in the expansion of an an
5951          --  intrinsic operation) so we must use the underlying type to get the
5952          --  bounds, and convert the literals explicitly.
5953
5954          LLB :=
5955            Expr_Value
5956              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
5957
5958          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
5959            and then
5960             ((not LOK) or else (Llo = LLB))
5961          then
5962             Rewrite (N,
5963               Make_Conditional_Expression (Loc,
5964                 Expressions => New_List (
5965                   Make_Op_Eq (Loc,
5966                     Left_Opnd => Duplicate_Subexpr (Right),
5967                     Right_Opnd =>
5968                       Unchecked_Convert_To (Typ,
5969                         Make_Integer_Literal (Loc, -1))),
5970                   Unchecked_Convert_To (Typ,
5971                     Make_Integer_Literal (Loc, Uint_0)),
5972                   Relocate_Node (N))));
5973
5974             Set_Analyzed (Next (Next (First (Expressions (N)))));
5975             Analyze_And_Resolve (N, Typ);
5976          end if;
5977       end if;
5978    end Expand_N_Op_Mod;
5979
5980    --------------------------
5981    -- Expand_N_Op_Multiply --
5982    --------------------------
5983
5984    procedure Expand_N_Op_Multiply (N : Node_Id) is
5985       Loc  : constant Source_Ptr := Sloc (N);
5986       Lop  : constant Node_Id    := Left_Opnd (N);
5987       Rop  : constant Node_Id    := Right_Opnd (N);
5988
5989       Lp2  : constant Boolean :=
5990                Nkind (Lop) = N_Op_Expon
5991                  and then Is_Power_Of_2_For_Shift (Lop);
5992
5993       Rp2  : constant Boolean :=
5994                Nkind (Rop) = N_Op_Expon
5995                  and then Is_Power_Of_2_For_Shift (Rop);
5996
5997       Ltyp : constant Entity_Id  := Etype (Lop);
5998       Rtyp : constant Entity_Id  := Etype (Rop);
5999       Typ  : Entity_Id           := Etype (N);
6000
6001    begin
6002       Binary_Op_Validity_Checks (N);
6003
6004       --  Special optimizations for integer types
6005
6006       if Is_Integer_Type (Typ) then
6007
6008          --  N * 0 = 0 * N = 0 for integer types
6009
6010          if (Compile_Time_Known_Value (Rop)
6011               and then Expr_Value (Rop) = Uint_0)
6012            or else
6013             (Compile_Time_Known_Value (Lop)
6014               and then Expr_Value (Lop) = Uint_0)
6015          then
6016             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
6017             Analyze_And_Resolve (N, Typ);
6018             return;
6019          end if;
6020
6021          --  N * 1 = 1 * N = N for integer types
6022
6023          --  This optimisation is not done if we are going to
6024          --  rewrite the product 1 * 2 ** N to a shift.
6025
6026          if Compile_Time_Known_Value (Rop)
6027            and then Expr_Value (Rop) = Uint_1
6028            and then not Lp2
6029          then
6030             Rewrite (N, Lop);
6031             return;
6032
6033          elsif Compile_Time_Known_Value (Lop)
6034            and then Expr_Value (Lop) = Uint_1
6035            and then not Rp2
6036          then
6037             Rewrite (N, Rop);
6038             return;
6039          end if;
6040       end if;
6041
6042       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6043       --  Is_Power_Of_2_For_Shift is set means that we know that our left
6044       --  operand is an integer, as required for this to work.
6045
6046       if Rp2 then
6047          if Lp2 then
6048
6049             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
6050
6051             Rewrite (N,
6052               Make_Op_Expon (Loc,
6053                 Left_Opnd => Make_Integer_Literal (Loc, 2),
6054                 Right_Opnd =>
6055                   Make_Op_Add (Loc,
6056                     Left_Opnd  => Right_Opnd (Lop),
6057                     Right_Opnd => Right_Opnd (Rop))));
6058             Analyze_And_Resolve (N, Typ);
6059             return;
6060
6061          else
6062             Rewrite (N,
6063               Make_Op_Shift_Left (Loc,
6064                 Left_Opnd  => Lop,
6065                 Right_Opnd =>
6066                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
6067             Analyze_And_Resolve (N, Typ);
6068             return;
6069          end if;
6070
6071       --  Same processing for the operands the other way round
6072
6073       elsif Lp2 then
6074          Rewrite (N,
6075            Make_Op_Shift_Left (Loc,
6076              Left_Opnd  => Rop,
6077              Right_Opnd =>
6078                Convert_To (Standard_Natural, Right_Opnd (Lop))));
6079          Analyze_And_Resolve (N, Typ);
6080          return;
6081       end if;
6082
6083       --  Do required fixup of universal fixed operation
6084
6085       if Typ = Universal_Fixed then
6086          Fixup_Universal_Fixed_Operation (N);
6087          Typ := Etype (N);
6088       end if;
6089
6090       --  Multiplications with fixed-point results
6091
6092       if Is_Fixed_Point_Type (Typ) then
6093
6094          --  No special processing if Treat_Fixed_As_Integer is set, since from
6095          --  a semantic point of view such operations are simply integer
6096          --  operations and will be treated that way.
6097
6098          if not Treat_Fixed_As_Integer (N) then
6099
6100             --  Case of fixed * integer => fixed
6101
6102             if Is_Integer_Type (Rtyp) then
6103                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
6104
6105             --  Case of integer * fixed => fixed
6106
6107             elsif Is_Integer_Type (Ltyp) then
6108                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
6109
6110             --  Case of fixed * fixed => fixed
6111
6112             else
6113                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
6114             end if;
6115          end if;
6116
6117       --  Other cases of multiplication of fixed-point operands. Again we
6118       --  exclude the cases where Treat_Fixed_As_Integer flag is set.
6119
6120       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6121         and then not Treat_Fixed_As_Integer (N)
6122       then
6123          if Is_Integer_Type (Typ) then
6124             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
6125          else
6126             pragma Assert (Is_Floating_Point_Type (Typ));
6127             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
6128          end if;
6129
6130       --  Mixed-mode operations can appear in a non-static universal context,
6131       --  in which case the integer argument must be converted explicitly.
6132
6133       elsif Typ = Universal_Real
6134         and then Is_Integer_Type (Rtyp)
6135       then
6136          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
6137
6138          Analyze_And_Resolve (Rop, Universal_Real);
6139
6140       elsif Typ = Universal_Real
6141         and then Is_Integer_Type (Ltyp)
6142       then
6143          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
6144
6145          Analyze_And_Resolve (Lop, Universal_Real);
6146
6147       --  Non-fixed point cases, check software overflow checking required
6148
6149       elsif Is_Signed_Integer_Type (Etype (N)) then
6150          Apply_Arithmetic_Overflow_Check (N);
6151
6152       --  Deal with VAX float case
6153
6154       elsif Vax_Float (Typ) then
6155          Expand_Vax_Arith (N);
6156          return;
6157       end if;
6158    end Expand_N_Op_Multiply;
6159
6160    --------------------
6161    -- Expand_N_Op_Ne --
6162    --------------------
6163
6164    procedure Expand_N_Op_Ne (N : Node_Id) is
6165       Typ : constant Entity_Id := Etype (Left_Opnd (N));
6166
6167    begin
6168       --  Case of elementary type with standard operator
6169
6170       if Is_Elementary_Type (Typ)
6171         and then Sloc (Entity (N)) = Standard_Location
6172       then
6173          Binary_Op_Validity_Checks (N);
6174
6175          --  Boolean types (requiring handling of non-standard case)
6176
6177          if Is_Boolean_Type (Typ) then
6178             Adjust_Condition (Left_Opnd (N));
6179             Adjust_Condition (Right_Opnd (N));
6180             Set_Etype (N, Standard_Boolean);
6181             Adjust_Result_Type (N, Typ);
6182          end if;
6183
6184          Rewrite_Comparison (N);
6185
6186          --  If we still have comparison for Vax_Float, process it
6187
6188          if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare  then
6189             Expand_Vax_Comparison (N);
6190             return;
6191          end if;
6192
6193       --  For all cases other than elementary types, we rewrite node as the
6194       --  negation of an equality operation, and reanalyze. The equality to be
6195       --  used is defined in the same scope and has the same signature. This
6196       --  signature must be set explicitly since in an instance it may not have
6197       --  the same visibility as in the generic unit. This avoids duplicating
6198       --  or factoring the complex code for record/array equality tests etc.
6199
6200       else
6201          declare
6202             Loc : constant Source_Ptr := Sloc (N);
6203             Neg : Node_Id;
6204             Ne  : constant Entity_Id := Entity (N);
6205
6206          begin
6207             Binary_Op_Validity_Checks (N);
6208
6209             Neg :=
6210               Make_Op_Not (Loc,
6211                 Right_Opnd =>
6212                   Make_Op_Eq (Loc,
6213                     Left_Opnd =>  Left_Opnd (N),
6214                     Right_Opnd => Right_Opnd (N)));
6215             Set_Paren_Count (Right_Opnd (Neg), 1);
6216
6217             if Scope (Ne) /= Standard_Standard then
6218                Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
6219             end if;
6220
6221             --  For navigation purposes, the inequality is treated as an
6222             --  implicit reference to the corresponding equality. Preserve the
6223             --  Comes_From_ source flag so that the proper Xref entry is
6224             --  generated.
6225
6226             Preserve_Comes_From_Source (Neg, N);
6227             Preserve_Comes_From_Source (Right_Opnd (Neg), N);
6228             Rewrite (N, Neg);
6229             Analyze_And_Resolve (N, Standard_Boolean);
6230          end;
6231       end if;
6232    end Expand_N_Op_Ne;
6233
6234    ---------------------
6235    -- Expand_N_Op_Not --
6236    ---------------------
6237
6238    --  If the argument is other than a Boolean array type, there is no special
6239    --  expansion required.
6240
6241    --  For the packed case, we call the special routine in Exp_Pakd, except
6242    --  that if the component size is greater than one, we use the standard
6243    --  routine generating a gruesome loop (it is so peculiar to have packed
6244    --  arrays with non-standard Boolean representations anyway, so it does not
6245    --  matter that we do not handle this case efficiently).
6246
6247    --  For the unpacked case (and for the special packed case where we have non
6248    --  standard Booleans, as discussed above), we generate and insert into the
6249    --  tree the following function definition:
6250
6251    --     function Nnnn (A : arr) is
6252    --       B : arr;
6253    --     begin
6254    --       for J in a'range loop
6255    --          B (J) := not A (J);
6256    --       end loop;
6257    --       return B;
6258    --     end Nnnn;
6259
6260    --  Here arr is the actual subtype of the parameter (and hence always
6261    --  constrained). Then we replace the not with a call to this function.
6262
6263    procedure Expand_N_Op_Not (N : Node_Id) is
6264       Loc  : constant Source_Ptr := Sloc (N);
6265       Typ  : constant Entity_Id  := Etype (N);
6266       Opnd : Node_Id;
6267       Arr  : Entity_Id;
6268       A    : Entity_Id;
6269       B    : Entity_Id;
6270       J    : Entity_Id;
6271       A_J  : Node_Id;
6272       B_J  : Node_Id;
6273
6274       Func_Name      : Entity_Id;
6275       Loop_Statement : Node_Id;
6276
6277    begin
6278       Unary_Op_Validity_Checks (N);
6279
6280       --  For boolean operand, deal with non-standard booleans
6281
6282       if Is_Boolean_Type (Typ) then
6283          Adjust_Condition (Right_Opnd (N));
6284          Set_Etype (N, Standard_Boolean);
6285          Adjust_Result_Type (N, Typ);
6286          return;
6287       end if;
6288
6289       --  Only array types need any other processing
6290
6291       if not Is_Array_Type (Typ) then
6292          return;
6293       end if;
6294
6295       --  Case of array operand. If bit packed with a component size of 1,
6296       --  handle it in Exp_Pakd if the operand is known to be aligned.
6297
6298       if Is_Bit_Packed_Array (Typ)
6299         and then Component_Size (Typ) = 1
6300         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
6301       then
6302          Expand_Packed_Not (N);
6303          return;
6304       end if;
6305
6306       --  Case of array operand which is not bit-packed. If the context is
6307       --  a safe assignment, call in-place operation, If context is a larger
6308       --  boolean expression in the context of a safe assignment, expansion is
6309       --  done by enclosing operation.
6310
6311       Opnd := Relocate_Node (Right_Opnd (N));
6312       Convert_To_Actual_Subtype (Opnd);
6313       Arr := Etype (Opnd);
6314       Ensure_Defined (Arr, N);
6315       Silly_Boolean_Array_Not_Test (N, Arr);
6316
6317       if Nkind (Parent (N)) = N_Assignment_Statement then
6318          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
6319             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6320             return;
6321
6322          --  Special case the negation of a binary operation
6323
6324          elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
6325            and then Safe_In_Place_Array_Op
6326                       (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
6327          then
6328             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6329             return;
6330          end if;
6331
6332       elsif Nkind (Parent (N)) in N_Binary_Op
6333         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
6334       then
6335          declare
6336             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
6337             Op2 : constant Node_Id := Right_Opnd (Parent (N));
6338             Lhs : constant Node_Id := Name (Parent (Parent (N)));
6339
6340          begin
6341             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
6342                if N = Op1
6343                  and then Nkind (Op2) = N_Op_Not
6344                then
6345                   --  (not A) op (not B) can be reduced to a single call
6346
6347                   return;
6348
6349                elsif N = Op2
6350                  and then Nkind (Parent (N)) = N_Op_Xor
6351                then
6352                   --  A xor (not B) can also be special-cased
6353
6354                   return;
6355                end if;
6356             end if;
6357          end;
6358       end if;
6359
6360       A := Make_Defining_Identifier (Loc, Name_uA);
6361       B := Make_Defining_Identifier (Loc, Name_uB);
6362       J := Make_Defining_Identifier (Loc, Name_uJ);
6363
6364       A_J :=
6365         Make_Indexed_Component (Loc,
6366           Prefix      => New_Reference_To (A, Loc),
6367           Expressions => New_List (New_Reference_To (J, Loc)));
6368
6369       B_J :=
6370         Make_Indexed_Component (Loc,
6371           Prefix      => New_Reference_To (B, Loc),
6372           Expressions => New_List (New_Reference_To (J, Loc)));
6373
6374       Loop_Statement :=
6375         Make_Implicit_Loop_Statement (N,
6376           Identifier => Empty,
6377
6378           Iteration_Scheme =>
6379             Make_Iteration_Scheme (Loc,
6380               Loop_Parameter_Specification =>
6381                 Make_Loop_Parameter_Specification (Loc,
6382                   Defining_Identifier => J,
6383                   Discrete_Subtype_Definition =>
6384                     Make_Attribute_Reference (Loc,
6385                       Prefix => Make_Identifier (Loc, Chars (A)),
6386                       Attribute_Name => Name_Range))),
6387
6388           Statements => New_List (
6389             Make_Assignment_Statement (Loc,
6390               Name       => B_J,
6391               Expression => Make_Op_Not (Loc, A_J))));
6392
6393       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
6394       Set_Is_Inlined (Func_Name);
6395
6396       Insert_Action (N,
6397         Make_Subprogram_Body (Loc,
6398           Specification =>
6399             Make_Function_Specification (Loc,
6400               Defining_Unit_Name => Func_Name,
6401               Parameter_Specifications => New_List (
6402                 Make_Parameter_Specification (Loc,
6403                   Defining_Identifier => A,
6404                   Parameter_Type      => New_Reference_To (Typ, Loc))),
6405               Result_Definition => New_Reference_To (Typ, Loc)),
6406
6407           Declarations => New_List (
6408             Make_Object_Declaration (Loc,
6409               Defining_Identifier => B,
6410               Object_Definition   => New_Reference_To (Arr, Loc))),
6411
6412           Handled_Statement_Sequence =>
6413             Make_Handled_Sequence_Of_Statements (Loc,
6414               Statements => New_List (
6415                 Loop_Statement,
6416                 Make_Simple_Return_Statement (Loc,
6417                   Expression =>
6418                     Make_Identifier (Loc, Chars (B)))))));
6419
6420       Rewrite (N,
6421         Make_Function_Call (Loc,
6422           Name => New_Reference_To (Func_Name, Loc),
6423           Parameter_Associations => New_List (Opnd)));
6424
6425       Analyze_And_Resolve (N, Typ);
6426    end Expand_N_Op_Not;
6427
6428    --------------------
6429    -- Expand_N_Op_Or --
6430    --------------------
6431
6432    procedure Expand_N_Op_Or (N : Node_Id) is
6433       Typ : constant Entity_Id := Etype (N);
6434
6435    begin
6436       Binary_Op_Validity_Checks (N);
6437
6438       if Is_Array_Type (Etype (N)) then
6439          Expand_Boolean_Operator (N);
6440
6441       elsif Is_Boolean_Type (Etype (N)) then
6442          Adjust_Condition (Left_Opnd (N));
6443          Adjust_Condition (Right_Opnd (N));
6444          Set_Etype (N, Standard_Boolean);
6445          Adjust_Result_Type (N, Typ);
6446       end if;
6447    end Expand_N_Op_Or;
6448
6449    ----------------------
6450    -- Expand_N_Op_Plus --
6451    ----------------------
6452
6453    procedure Expand_N_Op_Plus (N : Node_Id) is
6454    begin
6455       Unary_Op_Validity_Checks (N);
6456    end Expand_N_Op_Plus;
6457
6458    ---------------------
6459    -- Expand_N_Op_Rem --
6460    ---------------------
6461
6462    procedure Expand_N_Op_Rem (N : Node_Id) is
6463       Loc : constant Source_Ptr := Sloc (N);
6464       Typ : constant Entity_Id  := Etype (N);
6465
6466       Left  : constant Node_Id := Left_Opnd (N);
6467       Right : constant Node_Id := Right_Opnd (N);
6468
6469       LLB : Uint;
6470       Llo : Uint;
6471       Lhi : Uint;
6472       LOK : Boolean;
6473       Rlo : Uint;
6474       Rhi : Uint;
6475       ROK : Boolean;
6476
6477       pragma Warnings (Off, Lhi);
6478
6479    begin
6480       Binary_Op_Validity_Checks (N);
6481
6482       if Is_Integer_Type (Etype (N)) then
6483          Apply_Divide_Check (N);
6484       end if;
6485
6486       --  Apply optimization x rem 1 = 0. We don't really need that with gcc,
6487       --  but it is useful with other back ends (e.g. AAMP), and is certainly
6488       --  harmless.
6489
6490       if Is_Integer_Type (Etype (N))
6491         and then Compile_Time_Known_Value (Right)
6492         and then Expr_Value (Right) = Uint_1
6493       then
6494          Rewrite (N, Make_Integer_Literal (Loc, 0));
6495          Analyze_And_Resolve (N, Typ);
6496          return;
6497       end if;
6498
6499       --  Deal with annoying case of largest negative number remainder minus
6500       --  one. Gigi does not handle this case correctly, because it generates
6501       --  a divide instruction which may trap in this case.
6502
6503       --  In fact the check is quite easy, if the right operand is -1, then
6504       --  the remainder is always 0, and we can just ignore the left operand
6505       --  completely in this case.
6506
6507       Determine_Range (Right, ROK, Rlo, Rhi);
6508       Determine_Range (Left, LOK, Llo, Lhi);
6509
6510       --  The operand type may be private (e.g. in the expansion of an an
6511       --  intrinsic operation) so we must use the underlying type to get the
6512       --  bounds, and convert the literals explicitly.
6513
6514       LLB :=
6515         Expr_Value
6516           (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
6517
6518       --  Now perform the test, generating code only if needed
6519
6520       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
6521         and then
6522          ((not LOK) or else (Llo = LLB))
6523       then
6524          Rewrite (N,
6525            Make_Conditional_Expression (Loc,
6526              Expressions => New_List (
6527                Make_Op_Eq (Loc,
6528                  Left_Opnd => Duplicate_Subexpr (Right),
6529                  Right_Opnd =>
6530                    Unchecked_Convert_To (Typ,
6531                      Make_Integer_Literal (Loc, -1))),
6532
6533                Unchecked_Convert_To (Typ,
6534                  Make_Integer_Literal (Loc, Uint_0)),
6535
6536                Relocate_Node (N))));
6537
6538          Set_Analyzed (Next (Next (First (Expressions (N)))));
6539          Analyze_And_Resolve (N, Typ);
6540       end if;
6541    end Expand_N_Op_Rem;
6542
6543    -----------------------------
6544    -- Expand_N_Op_Rotate_Left --
6545    -----------------------------
6546
6547    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
6548    begin
6549       Binary_Op_Validity_Checks (N);
6550    end Expand_N_Op_Rotate_Left;
6551
6552    ------------------------------
6553    -- Expand_N_Op_Rotate_Right --
6554    ------------------------------
6555
6556    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
6557    begin
6558       Binary_Op_Validity_Checks (N);
6559    end Expand_N_Op_Rotate_Right;
6560
6561    ----------------------------
6562    -- Expand_N_Op_Shift_Left --
6563    ----------------------------
6564
6565    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
6566    begin
6567       Binary_Op_Validity_Checks (N);
6568    end Expand_N_Op_Shift_Left;
6569
6570    -----------------------------
6571    -- Expand_N_Op_Shift_Right --
6572    -----------------------------
6573
6574    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
6575    begin
6576       Binary_Op_Validity_Checks (N);
6577    end Expand_N_Op_Shift_Right;
6578
6579    ----------------------------------------
6580    -- Expand_N_Op_Shift_Right_Arithmetic --
6581    ----------------------------------------
6582
6583    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
6584    begin
6585       Binary_Op_Validity_Checks (N);
6586    end Expand_N_Op_Shift_Right_Arithmetic;
6587
6588    --------------------------
6589    -- Expand_N_Op_Subtract --
6590    --------------------------
6591
6592    procedure Expand_N_Op_Subtract (N : Node_Id) is
6593       Typ : constant Entity_Id := Etype (N);
6594
6595    begin
6596       Binary_Op_Validity_Checks (N);
6597
6598       --  N - 0 = N for integer types
6599
6600       if Is_Integer_Type (Typ)
6601         and then Compile_Time_Known_Value (Right_Opnd (N))
6602         and then Expr_Value (Right_Opnd (N)) = 0
6603       then
6604          Rewrite (N, Left_Opnd (N));
6605          return;
6606       end if;
6607
6608       --  Arithmetic overflow checks for signed integer/fixed point types
6609
6610       if Is_Signed_Integer_Type (Typ)
6611         or else Is_Fixed_Point_Type (Typ)
6612       then
6613          Apply_Arithmetic_Overflow_Check (N);
6614
6615       --  Vax floating-point types case
6616
6617       elsif Vax_Float (Typ) then
6618          Expand_Vax_Arith (N);
6619       end if;
6620    end Expand_N_Op_Subtract;
6621
6622    ---------------------
6623    -- Expand_N_Op_Xor --
6624    ---------------------
6625
6626    procedure Expand_N_Op_Xor (N : Node_Id) is
6627       Typ : constant Entity_Id := Etype (N);
6628
6629    begin
6630       Binary_Op_Validity_Checks (N);
6631
6632       if Is_Array_Type (Etype (N)) then
6633          Expand_Boolean_Operator (N);
6634
6635       elsif Is_Boolean_Type (Etype (N)) then
6636          Adjust_Condition (Left_Opnd (N));
6637          Adjust_Condition (Right_Opnd (N));
6638          Set_Etype (N, Standard_Boolean);
6639          Adjust_Result_Type (N, Typ);
6640       end if;
6641    end Expand_N_Op_Xor;
6642
6643    ----------------------
6644    -- Expand_N_Or_Else --
6645    ----------------------
6646
6647    --  Expand into conditional expression if Actions present, and also
6648    --  deal with optimizing case of arguments being True or False.
6649
6650    procedure Expand_N_Or_Else (N : Node_Id) is
6651       Loc     : constant Source_Ptr := Sloc (N);
6652       Typ     : constant Entity_Id  := Etype (N);
6653       Left    : constant Node_Id    := Left_Opnd (N);
6654       Right   : constant Node_Id    := Right_Opnd (N);
6655       Actlist : List_Id;
6656
6657    begin
6658       --  Deal with non-standard booleans
6659
6660       if Is_Boolean_Type (Typ) then
6661          Adjust_Condition (Left);
6662          Adjust_Condition (Right);
6663          Set_Etype (N, Standard_Boolean);
6664       end if;
6665
6666       --  Check for cases of left argument is True or False
6667
6668       if Nkind (Left) = N_Identifier then
6669
6670          --  If left argument is False, change (False or else Right) to Right.
6671          --  Any actions associated with Right will be executed unconditionally
6672          --  and can thus be inserted into the tree unconditionally.
6673
6674          if Entity (Left) = Standard_False then
6675             if Present (Actions (N)) then
6676                Insert_Actions (N, Actions (N));
6677             end if;
6678
6679             Rewrite (N, Right);
6680             Adjust_Result_Type (N, Typ);
6681             return;
6682
6683          --  If left argument is True, change (True and then Right) to True. In
6684          --  this case we can forget the actions associated with Right, since
6685          --  they will never be executed.
6686
6687          elsif Entity (Left) = Standard_True then
6688             Kill_Dead_Code (Right);
6689             Kill_Dead_Code (Actions (N));
6690             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6691             Adjust_Result_Type (N, Typ);
6692             return;
6693          end if;
6694       end if;
6695
6696       --  If Actions are present, we expand
6697
6698       --     left or else right
6699
6700       --  into
6701
6702       --     if left then True else right end
6703
6704       --  with the actions becoming the Else_Actions of the conditional
6705       --  expression. This conditional expression is then further expanded
6706       --  (and will eventually disappear)
6707
6708       if Present (Actions (N)) then
6709          Actlist := Actions (N);
6710          Rewrite (N,
6711             Make_Conditional_Expression (Loc,
6712               Expressions => New_List (
6713                 Left,
6714                 New_Occurrence_Of (Standard_True, Loc),
6715                 Right)));
6716
6717          Set_Else_Actions (N, Actlist);
6718          Analyze_And_Resolve (N, Standard_Boolean);
6719          Adjust_Result_Type (N, Typ);
6720          return;
6721       end if;
6722
6723       --  No actions present, check for cases of right argument True/False
6724
6725       if Nkind (Right) = N_Identifier then
6726
6727          --  Change (Left or else False) to Left. Note that we know there are
6728          --  no actions associated with the True operand, since we just checked
6729          --  for this case above.
6730
6731          if Entity (Right) = Standard_False then
6732             Rewrite (N, Left);
6733
6734          --  Change (Left or else True) to True, making sure to preserve any
6735          --  side effects associated with the Left operand.
6736
6737          elsif Entity (Right) = Standard_True then
6738             Remove_Side_Effects (Left);
6739             Rewrite
6740               (N, New_Occurrence_Of (Standard_True, Loc));
6741          end if;
6742       end if;
6743
6744       Adjust_Result_Type (N, Typ);
6745    end Expand_N_Or_Else;
6746
6747    -----------------------------------
6748    -- Expand_N_Qualified_Expression --
6749    -----------------------------------
6750
6751    procedure Expand_N_Qualified_Expression (N : Node_Id) is
6752       Operand     : constant Node_Id   := Expression (N);
6753       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
6754
6755    begin
6756       --  Do validity check if validity checking operands
6757
6758       if Validity_Checks_On
6759         and then Validity_Check_Operands
6760       then
6761          Ensure_Valid (Operand);
6762       end if;
6763
6764       --  Apply possible constraint check
6765
6766       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
6767    end Expand_N_Qualified_Expression;
6768
6769    ---------------------------------
6770    -- Expand_N_Selected_Component --
6771    ---------------------------------
6772
6773    --  If the selector is a discriminant of a concurrent object, rewrite the
6774    --  prefix to denote the corresponding record type.
6775
6776    procedure Expand_N_Selected_Component (N : Node_Id) is
6777       Loc   : constant Source_Ptr := Sloc (N);
6778       Par   : constant Node_Id    := Parent (N);
6779       P     : constant Node_Id    := Prefix (N);
6780       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
6781       Disc  : Entity_Id;
6782       New_N : Node_Id;
6783       Dcon  : Elmt_Id;
6784
6785       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
6786       --  Gigi needs a temporary for prefixes that depend on a discriminant,
6787       --  unless the context of an assignment can provide size information.
6788       --  Don't we have a general routine that does this???
6789
6790       -----------------------
6791       -- In_Left_Hand_Side --
6792       -----------------------
6793
6794       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
6795       begin
6796          return (Nkind (Parent (Comp)) = N_Assignment_Statement
6797                    and then Comp = Name (Parent (Comp)))
6798            or else (Present (Parent (Comp))
6799                       and then Nkind (Parent (Comp)) in N_Subexpr
6800                       and then In_Left_Hand_Side (Parent (Comp)));
6801       end In_Left_Hand_Side;
6802
6803    --  Start of processing for Expand_N_Selected_Component
6804
6805    begin
6806       --  Insert explicit dereference if required
6807
6808       if Is_Access_Type (Ptyp) then
6809          Insert_Explicit_Dereference (P);
6810          Analyze_And_Resolve (P, Designated_Type (Ptyp));
6811
6812          if Ekind (Etype (P)) = E_Private_Subtype
6813            and then Is_For_Access_Subtype (Etype (P))
6814          then
6815             Set_Etype (P, Base_Type (Etype (P)));
6816          end if;
6817
6818          Ptyp := Etype (P);
6819       end if;
6820
6821       --  Deal with discriminant check required
6822
6823       if Do_Discriminant_Check (N) then
6824
6825          --  Present the discriminant checking function to the backend, so that
6826          --  it can inline the call to the function.
6827
6828          Add_Inlined_Body
6829            (Discriminant_Checking_Func
6830              (Original_Record_Component (Entity (Selector_Name (N)))));
6831
6832          --  Now reset the flag and generate the call
6833
6834          Set_Do_Discriminant_Check (N, False);
6835          Generate_Discriminant_Check (N);
6836       end if;
6837
6838       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6839       --  function, then additional actuals must be passed.
6840
6841       if Ada_Version >= Ada_05
6842         and then Is_Build_In_Place_Function_Call (P)
6843       then
6844          Make_Build_In_Place_Call_In_Anonymous_Context (P);
6845       end if;
6846
6847       --  Gigi cannot handle unchecked conversions that are the prefix of a
6848       --  selected component with discriminants. This must be checked during
6849       --  expansion, because during analysis the type of the selector is not
6850       --  known at the point the prefix is analyzed. If the conversion is the
6851       --  target of an assignment, then we cannot force the evaluation.
6852
6853       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
6854         and then Has_Discriminants (Etype (N))
6855         and then not In_Left_Hand_Side (N)
6856       then
6857          Force_Evaluation (Prefix (N));
6858       end if;
6859
6860       --  Remaining processing applies only if selector is a discriminant
6861
6862       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
6863
6864          --  If the selector is a discriminant of a constrained record type,
6865          --  we may be able to rewrite the expression with the actual value
6866          --  of the discriminant, a useful optimization in some cases.
6867
6868          if Is_Record_Type (Ptyp)
6869            and then Has_Discriminants (Ptyp)
6870            and then Is_Constrained (Ptyp)
6871          then
6872             --  Do this optimization for discrete types only, and not for
6873             --  access types (access discriminants get us into trouble!)
6874
6875             if not Is_Discrete_Type (Etype (N)) then
6876                null;
6877
6878             --  Don't do this on the left hand of an assignment statement.
6879             --  Normally one would think that references like this would
6880             --  not occur, but they do in generated code, and mean that
6881             --  we really do want to assign the discriminant!
6882
6883             elsif Nkind (Par) = N_Assignment_Statement
6884               and then Name (Par) = N
6885             then
6886                null;
6887
6888             --  Don't do this optimization for the prefix of an attribute or
6889             --  the operand of an object renaming declaration since these are
6890             --  contexts where we do not want the value anyway.
6891
6892             elsif (Nkind (Par) = N_Attribute_Reference
6893                      and then Prefix (Par) = N)
6894               or else Is_Renamed_Object (N)
6895             then
6896                null;
6897
6898             --  Don't do this optimization if we are within the code for a
6899             --  discriminant check, since the whole point of such a check may
6900             --  be to verify the condition on which the code below depends!
6901
6902             elsif Is_In_Discriminant_Check (N) then
6903                null;
6904
6905             --  Green light to see if we can do the optimization. There is
6906             --  still one condition that inhibits the optimization below but
6907             --  now is the time to check the particular discriminant.
6908
6909             else
6910                --  Loop through discriminants to find the matching discriminant
6911                --  constraint to see if we can copy it.
6912
6913                Disc := First_Discriminant (Ptyp);
6914                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
6915                Discr_Loop : while Present (Dcon) loop
6916
6917                   --  Check if this is the matching discriminant
6918
6919                   if Disc = Entity (Selector_Name (N)) then
6920
6921                      --  Here we have the matching discriminant. Check for
6922                      --  the case of a discriminant of a component that is
6923                      --  constrained by an outer discriminant, which cannot
6924                      --  be optimized away.
6925
6926                      if
6927                        Denotes_Discriminant
6928                         (Node (Dcon), Check_Concurrent => True)
6929                      then
6930                         exit Discr_Loop;
6931
6932                      --  In the context of a case statement, the expression may
6933                      --  have the base type of the discriminant, and we need to
6934                      --  preserve the constraint to avoid spurious errors on
6935                      --  missing cases.
6936
6937                      elsif Nkind (Parent (N)) = N_Case_Statement
6938                        and then Etype (Node (Dcon)) /= Etype (Disc)
6939                      then
6940                         Rewrite (N,
6941                           Make_Qualified_Expression (Loc,
6942                             Subtype_Mark =>
6943                               New_Occurrence_Of (Etype (Disc), Loc),
6944                             Expression   =>
6945                               New_Copy_Tree (Node (Dcon))));
6946                         Analyze_And_Resolve (N, Etype (Disc));
6947
6948                         --  In case that comes out as a static expression,
6949                         --  reset it (a selected component is never static).
6950
6951                         Set_Is_Static_Expression (N, False);
6952                         return;
6953
6954                      --  Otherwise we can just copy the constraint, but the
6955                      --  result is certainly not static! In some cases the
6956                      --  discriminant constraint has been analyzed in the
6957                      --  context of the original subtype indication, but for
6958                      --  itypes the constraint might not have been analyzed
6959                      --  yet, and this must be done now.
6960
6961                      else
6962                         Rewrite (N, New_Copy_Tree (Node (Dcon)));
6963                         Analyze_And_Resolve (N);
6964                         Set_Is_Static_Expression (N, False);
6965                         return;
6966                      end if;
6967                   end if;
6968
6969                   Next_Elmt (Dcon);
6970                   Next_Discriminant (Disc);
6971                end loop Discr_Loop;
6972
6973                --  Note: the above loop should always find a matching
6974                --  discriminant, but if it does not, we just missed an
6975                --  optimization due to some glitch (perhaps a previous error),
6976                --  so ignore.
6977
6978             end if;
6979          end if;
6980
6981          --  The only remaining processing is in the case of a discriminant of
6982          --  a concurrent object, where we rewrite the prefix to denote the
6983          --  corresponding record type. If the type is derived and has renamed
6984          --  discriminants, use corresponding discriminant, which is the one
6985          --  that appears in the corresponding record.
6986
6987          if not Is_Concurrent_Type (Ptyp) then
6988             return;
6989          end if;
6990
6991          Disc := Entity (Selector_Name (N));
6992
6993          if Is_Derived_Type (Ptyp)
6994            and then Present (Corresponding_Discriminant (Disc))
6995          then
6996             Disc := Corresponding_Discriminant (Disc);
6997          end if;
6998
6999          New_N :=
7000            Make_Selected_Component (Loc,
7001              Prefix =>
7002                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
7003                  New_Copy_Tree (P)),
7004              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
7005
7006          Rewrite (N, New_N);
7007          Analyze (N);
7008       end if;
7009    end Expand_N_Selected_Component;
7010
7011    --------------------
7012    -- Expand_N_Slice --
7013    --------------------
7014
7015    procedure Expand_N_Slice (N : Node_Id) is
7016       Loc  : constant Source_Ptr := Sloc (N);
7017       Typ  : constant Entity_Id  := Etype (N);
7018       Pfx  : constant Node_Id    := Prefix (N);
7019       Ptp  : Entity_Id           := Etype (Pfx);
7020
7021       function Is_Procedure_Actual (N : Node_Id) return Boolean;
7022       --  Check whether the argument is an actual for a procedure call, in
7023       --  which case the expansion of a bit-packed slice is deferred until the
7024       --  call itself is expanded. The reason this is required is that we might
7025       --  have an IN OUT or OUT parameter, and the copy out is essential, and
7026       --  that copy out would be missed if we created a temporary here in
7027       --  Expand_N_Slice. Note that we don't bother to test specifically for an
7028       --  IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7029       --  is harmless to defer expansion in the IN case, since the call
7030       --  processing will still generate the appropriate copy in operation,
7031       --  which will take care of the slice.
7032
7033       procedure Make_Temporary;
7034       --  Create a named variable for the value of the slice, in cases where
7035       --  the back-end cannot handle it properly, e.g. when packed types or
7036       --  unaligned slices are involved.
7037
7038       -------------------------
7039       -- Is_Procedure_Actual --
7040       -------------------------
7041
7042       function Is_Procedure_Actual (N : Node_Id) return Boolean is
7043          Par : Node_Id := Parent (N);
7044
7045       begin
7046          loop
7047             --  If our parent is a procedure call we can return
7048
7049             if Nkind (Par) = N_Procedure_Call_Statement then
7050                return True;
7051
7052             --  If our parent is a type conversion, keep climbing the tree,
7053             --  since a type conversion can be a procedure actual. Also keep
7054             --  climbing if parameter association or a qualified expression,
7055             --  since these are additional cases that do can appear on
7056             --  procedure actuals.
7057
7058             elsif Nkind_In (Par, N_Type_Conversion,
7059                                  N_Parameter_Association,
7060                                  N_Qualified_Expression)
7061             then
7062                Par := Parent (Par);
7063
7064                --  Any other case is not what we are looking for
7065
7066             else
7067                return False;
7068             end if;
7069          end loop;
7070       end Is_Procedure_Actual;
7071
7072       --------------------
7073       -- Make_Temporary --
7074       --------------------
7075
7076       procedure Make_Temporary is
7077          Decl : Node_Id;
7078          Ent  : constant Entity_Id :=
7079                   Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
7080       begin
7081          Decl :=
7082            Make_Object_Declaration (Loc,
7083              Defining_Identifier => Ent,
7084              Object_Definition   => New_Occurrence_Of (Typ, Loc));
7085
7086          Set_No_Initialization (Decl);
7087
7088          Insert_Actions (N, New_List (
7089            Decl,
7090            Make_Assignment_Statement (Loc,
7091              Name => New_Occurrence_Of (Ent, Loc),
7092              Expression => Relocate_Node (N))));
7093
7094          Rewrite (N, New_Occurrence_Of (Ent, Loc));
7095          Analyze_And_Resolve (N, Typ);
7096       end Make_Temporary;
7097
7098    --  Start of processing for Expand_N_Slice
7099
7100    begin
7101       --  Special handling for access types
7102
7103       if Is_Access_Type (Ptp) then
7104
7105          Ptp := Designated_Type (Ptp);
7106
7107          Rewrite (Pfx,
7108            Make_Explicit_Dereference (Sloc (N),
7109             Prefix => Relocate_Node (Pfx)));
7110
7111          Analyze_And_Resolve (Pfx, Ptp);
7112       end if;
7113
7114       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7115       --  function, then additional actuals must be passed.
7116
7117       if Ada_Version >= Ada_05
7118         and then Is_Build_In_Place_Function_Call (Pfx)
7119       then
7120          Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
7121       end if;
7122
7123       --  Range checks are potentially also needed for cases involving a slice
7124       --  indexed by a subtype indication, but Do_Range_Check can currently
7125       --  only be set for expressions ???
7126
7127       if not Index_Checks_Suppressed (Ptp)
7128         and then (not Is_Entity_Name (Pfx)
7129                    or else not Index_Checks_Suppressed (Entity (Pfx)))
7130         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
7131
7132          --  Do not enable range check to nodes associated with the frontend
7133          --  expansion of the dispatch table. We first check if Ada.Tags is
7134          --  already loaded to avoid the addition of an undesired dependence
7135          --  on such run-time unit.
7136
7137         and then
7138           (VM_Target /= No_VM
7139             or else not
7140              (RTU_Loaded (Ada_Tags)
7141                and then Nkind (Prefix (N)) = N_Selected_Component
7142                and then Present (Entity (Selector_Name (Prefix (N))))
7143                and then Entity (Selector_Name (Prefix (N))) =
7144                                   RTE_Record_Component (RE_Prims_Ptr)))
7145       then
7146          Enable_Range_Check (Discrete_Range (N));
7147       end if;
7148
7149       --  The remaining case to be handled is packed slices. We can leave
7150       --  packed slices as they are in the following situations:
7151
7152       --    1. Right or left side of an assignment (we can handle this
7153       --       situation correctly in the assignment statement expansion).
7154
7155       --    2. Prefix of indexed component (the slide is optimized away in this
7156       --       case, see the start of Expand_N_Slice.)
7157
7158       --    3. Object renaming declaration, since we want the name of the
7159       --       slice, not the value.
7160
7161       --    4. Argument to procedure call, since copy-in/copy-out handling may
7162       --       be required, and this is handled in the expansion of call
7163       --       itself.
7164
7165       --    5. Prefix of an address attribute (this is an error which is caught
7166       --       elsewhere, and the expansion would interfere with generating the
7167       --       error message).
7168
7169       if not Is_Packed (Typ) then
7170
7171          --  Apply transformation for actuals of a function call, where
7172          --  Expand_Actuals is not used.
7173
7174          if Nkind (Parent (N)) = N_Function_Call
7175            and then Is_Possibly_Unaligned_Slice (N)
7176          then
7177             Make_Temporary;
7178          end if;
7179
7180       elsif Nkind (Parent (N)) = N_Assignment_Statement
7181         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
7182                    and then Parent (N) = Name (Parent (Parent (N))))
7183       then
7184          return;
7185
7186       elsif Nkind (Parent (N)) = N_Indexed_Component
7187         or else Is_Renamed_Object (N)
7188         or else Is_Procedure_Actual (N)
7189       then
7190          return;
7191
7192       elsif Nkind (Parent (N)) = N_Attribute_Reference
7193         and then Attribute_Name (Parent (N)) = Name_Address
7194       then
7195          return;
7196
7197       else
7198          Make_Temporary;
7199       end if;
7200    end Expand_N_Slice;
7201
7202    ------------------------------
7203    -- Expand_N_Type_Conversion --
7204    ------------------------------
7205
7206    procedure Expand_N_Type_Conversion (N : Node_Id) is
7207       Loc          : constant Source_Ptr := Sloc (N);
7208       Operand      : constant Node_Id    := Expression (N);
7209       Target_Type  : constant Entity_Id  := Etype (N);
7210       Operand_Type : Entity_Id           := Etype (Operand);
7211
7212       procedure Handle_Changed_Representation;
7213       --  This is called in the case of record and array type conversions to
7214       --  see if there is a change of representation to be handled. Change of
7215       --  representation is actually handled at the assignment statement level,
7216       --  and what this procedure does is rewrite node N conversion as an
7217       --  assignment to temporary. If there is no change of representation,
7218       --  then the conversion node is unchanged.
7219
7220       procedure Real_Range_Check;
7221       --  Handles generation of range check for real target value
7222
7223       -----------------------------------
7224       -- Handle_Changed_Representation --
7225       -----------------------------------
7226
7227       procedure Handle_Changed_Representation is
7228          Temp : Entity_Id;
7229          Decl : Node_Id;
7230          Odef : Node_Id;
7231          Disc : Node_Id;
7232          N_Ix : Node_Id;
7233          Cons : List_Id;
7234
7235       begin
7236          --  Nothing else to do if no change of representation
7237
7238          if Same_Representation (Operand_Type, Target_Type) then
7239             return;
7240
7241          --  The real change of representation work is done by the assignment
7242          --  statement processing. So if this type conversion is appearing as
7243          --  the expression of an assignment statement, nothing needs to be
7244          --  done to the conversion.
7245
7246          elsif Nkind (Parent (N)) = N_Assignment_Statement then
7247             return;
7248
7249          --  Otherwise we need to generate a temporary variable, and do the
7250          --  change of representation assignment into that temporary variable.
7251          --  The conversion is then replaced by a reference to this variable.
7252
7253          else
7254             Cons := No_List;
7255
7256             --  If type is unconstrained we have to add a constraint, copied
7257             --  from the actual value of the left hand side.
7258
7259             if not Is_Constrained (Target_Type) then
7260                if Has_Discriminants (Operand_Type) then
7261                   Disc := First_Discriminant (Operand_Type);
7262
7263                   if Disc /= First_Stored_Discriminant (Operand_Type) then
7264                      Disc := First_Stored_Discriminant (Operand_Type);
7265                   end if;
7266
7267                   Cons := New_List;
7268                   while Present (Disc) loop
7269                      Append_To (Cons,
7270                        Make_Selected_Component (Loc,
7271                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
7272                          Selector_Name =>
7273                            Make_Identifier (Loc, Chars (Disc))));
7274                      Next_Discriminant (Disc);
7275                   end loop;
7276
7277                elsif Is_Array_Type (Operand_Type) then
7278                   N_Ix := First_Index (Target_Type);
7279                   Cons := New_List;
7280
7281                   for J in 1 .. Number_Dimensions (Operand_Type) loop
7282
7283                      --  We convert the bounds explicitly. We use an unchecked
7284                      --  conversion because bounds checks are done elsewhere.
7285
7286                      Append_To (Cons,
7287                        Make_Range (Loc,
7288                          Low_Bound =>
7289                            Unchecked_Convert_To (Etype (N_Ix),
7290                              Make_Attribute_Reference (Loc,
7291                                Prefix =>
7292                                  Duplicate_Subexpr_No_Checks
7293                                    (Operand, Name_Req => True),
7294                                Attribute_Name => Name_First,
7295                                Expressions    => New_List (
7296                                  Make_Integer_Literal (Loc, J)))),
7297
7298                          High_Bound =>
7299                            Unchecked_Convert_To (Etype (N_Ix),
7300                              Make_Attribute_Reference (Loc,
7301                                Prefix =>
7302                                  Duplicate_Subexpr_No_Checks
7303                                    (Operand, Name_Req => True),
7304                                Attribute_Name => Name_Last,
7305                                Expressions    => New_List (
7306                                  Make_Integer_Literal (Loc, J))))));
7307
7308                      Next_Index (N_Ix);
7309                   end loop;
7310                end if;
7311             end if;
7312
7313             Odef := New_Occurrence_Of (Target_Type, Loc);
7314
7315             if Present (Cons) then
7316                Odef :=
7317                  Make_Subtype_Indication (Loc,
7318                    Subtype_Mark => Odef,
7319                    Constraint =>
7320                      Make_Index_Or_Discriminant_Constraint (Loc,
7321                        Constraints => Cons));
7322             end if;
7323
7324             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
7325             Decl :=
7326               Make_Object_Declaration (Loc,
7327                 Defining_Identifier => Temp,
7328                 Object_Definition   => Odef);
7329
7330             Set_No_Initialization (Decl, True);
7331
7332             --  Insert required actions. It is essential to suppress checks
7333             --  since we have suppressed default initialization, which means
7334             --  that the variable we create may have no discriminants.
7335
7336             Insert_Actions (N,
7337               New_List (
7338                 Decl,
7339                 Make_Assignment_Statement (Loc,
7340                   Name => New_Occurrence_Of (Temp, Loc),
7341                   Expression => Relocate_Node (N))),
7342                 Suppress => All_Checks);
7343
7344             Rewrite (N, New_Occurrence_Of (Temp, Loc));
7345             return;
7346          end if;
7347       end Handle_Changed_Representation;
7348
7349       ----------------------
7350       -- Real_Range_Check --
7351       ----------------------
7352
7353       --  Case of conversions to floating-point or fixed-point. If range checks
7354       --  are enabled and the target type has a range constraint, we convert:
7355
7356       --     typ (x)
7357
7358       --       to
7359
7360       --     Tnn : typ'Base := typ'Base (x);
7361       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7362       --     Tnn
7363
7364       --  This is necessary when there is a conversion of integer to float or
7365       --  to fixed-point to ensure that the correct checks are made. It is not
7366       --  necessary for float to float where it is enough to simply set the
7367       --  Do_Range_Check flag.
7368
7369       procedure Real_Range_Check is
7370          Btyp : constant Entity_Id := Base_Type (Target_Type);
7371          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
7372          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
7373          Xtyp : constant Entity_Id := Etype (Operand);
7374          Conv : Node_Id;
7375          Tnn  : Entity_Id;
7376
7377       begin
7378          --  Nothing to do if conversion was rewritten
7379
7380          if Nkind (N) /= N_Type_Conversion then
7381             return;
7382          end if;
7383
7384          --  Nothing to do if range checks suppressed, or target has the same
7385          --  range as the base type (or is the base type).
7386
7387          if Range_Checks_Suppressed (Target_Type)
7388            or else (Lo = Type_Low_Bound (Btyp)
7389                       and then
7390                     Hi = Type_High_Bound (Btyp))
7391          then
7392             return;
7393          end if;
7394
7395          --  Nothing to do if expression is an entity on which checks have been
7396          --  suppressed.
7397
7398          if Is_Entity_Name (Operand)
7399            and then Range_Checks_Suppressed (Entity (Operand))
7400          then
7401             return;
7402          end if;
7403
7404          --  Nothing to do if bounds are all static and we can tell that the
7405          --  expression is within the bounds of the target. Note that if the
7406          --  operand is of an unconstrained floating-point type, then we do
7407          --  not trust it to be in range (might be infinite)
7408
7409          declare
7410             S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
7411             S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
7412
7413          begin
7414             if (not Is_Floating_Point_Type (Xtyp)
7415                  or else Is_Constrained (Xtyp))
7416               and then Compile_Time_Known_Value (S_Lo)
7417               and then Compile_Time_Known_Value (S_Hi)
7418               and then Compile_Time_Known_Value (Hi)
7419               and then Compile_Time_Known_Value (Lo)
7420             then
7421                declare
7422                   D_Lov : constant Ureal := Expr_Value_R (Lo);
7423                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
7424                   S_Lov : Ureal;
7425                   S_Hiv : Ureal;
7426
7427                begin
7428                   if Is_Real_Type (Xtyp) then
7429                      S_Lov := Expr_Value_R (S_Lo);
7430                      S_Hiv := Expr_Value_R (S_Hi);
7431                   else
7432                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
7433                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
7434                   end if;
7435
7436                   if D_Hiv > D_Lov
7437                     and then S_Lov >= D_Lov
7438                     and then S_Hiv <= D_Hiv
7439                   then
7440                      Set_Do_Range_Check (Operand, False);
7441                      return;
7442                   end if;
7443                end;
7444             end if;
7445          end;
7446
7447          --  For float to float conversions, we are done
7448
7449          if Is_Floating_Point_Type (Xtyp)
7450               and then
7451             Is_Floating_Point_Type (Btyp)
7452          then
7453             return;
7454          end if;
7455
7456          --  Otherwise rewrite the conversion as described above
7457
7458          Conv := Relocate_Node (N);
7459          Rewrite
7460            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
7461          Set_Etype (Conv, Btyp);
7462
7463          --  Enable overflow except for case of integer to float conversions,
7464          --  where it is never required, since we can never have overflow in
7465          --  this case.
7466
7467          if not Is_Integer_Type (Etype (Operand)) then
7468             Enable_Overflow_Check (Conv);
7469          end if;
7470
7471          Tnn :=
7472            Make_Defining_Identifier (Loc,
7473              Chars => New_Internal_Name ('T'));
7474
7475          Insert_Actions (N, New_List (
7476            Make_Object_Declaration (Loc,
7477              Defining_Identifier => Tnn,
7478              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
7479              Expression => Conv),
7480
7481            Make_Raise_Constraint_Error (Loc,
7482              Condition =>
7483               Make_Or_Else (Loc,
7484                 Left_Opnd =>
7485                   Make_Op_Lt (Loc,
7486                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
7487                     Right_Opnd =>
7488                       Make_Attribute_Reference (Loc,
7489                         Attribute_Name => Name_First,
7490                         Prefix =>
7491                           New_Occurrence_Of (Target_Type, Loc))),
7492
7493                 Right_Opnd =>
7494                   Make_Op_Gt (Loc,
7495                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
7496                     Right_Opnd =>
7497                       Make_Attribute_Reference (Loc,
7498                         Attribute_Name => Name_Last,
7499                         Prefix =>
7500                           New_Occurrence_Of (Target_Type, Loc)))),
7501              Reason => CE_Range_Check_Failed)));
7502
7503          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
7504          Analyze_And_Resolve (N, Btyp);
7505       end Real_Range_Check;
7506
7507    --  Start of processing for Expand_N_Type_Conversion
7508
7509    begin
7510       --  Nothing at all to do if conversion is to the identical type so remove
7511       --  the conversion completely, it is useless.
7512
7513       if Operand_Type = Target_Type then
7514          Rewrite (N, Relocate_Node (Operand));
7515          return;
7516       end if;
7517
7518       --  Nothing to do if this is the second argument of read. This is a
7519       --  "backwards" conversion that will be handled by the specialized code
7520       --  in attribute processing.
7521
7522       if Nkind (Parent (N)) = N_Attribute_Reference
7523         and then Attribute_Name (Parent (N)) = Name_Read
7524         and then Next (First (Expressions (Parent (N)))) = N
7525       then
7526          return;
7527       end if;
7528
7529       --  Here if we may need to expand conversion
7530
7531       --  Do validity check if validity checking operands
7532
7533       if Validity_Checks_On
7534         and then Validity_Check_Operands
7535       then
7536          Ensure_Valid (Operand);
7537       end if;
7538
7539       --  Special case of converting from non-standard boolean type
7540
7541       if Is_Boolean_Type (Operand_Type)
7542         and then (Nonzero_Is_True (Operand_Type))
7543       then
7544          Adjust_Condition (Operand);
7545          Set_Etype (Operand, Standard_Boolean);
7546          Operand_Type := Standard_Boolean;
7547       end if;
7548
7549       --  Case of converting to an access type
7550
7551       if Is_Access_Type (Target_Type) then
7552
7553          --  Apply an accessibility check when the conversion operand is an
7554          --  access parameter (or a renaming thereof), unless conversion was
7555          --  expanded from an unchecked or unrestricted access attribute. Note
7556          --  that other checks may still need to be applied below (such as
7557          --  tagged type checks).
7558
7559          if Is_Entity_Name (Operand)
7560            and then
7561              (Is_Formal (Entity (Operand))
7562                or else
7563                  (Present (Renamed_Object (Entity (Operand)))
7564                    and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
7565                    and then Is_Formal
7566                               (Entity (Renamed_Object (Entity (Operand))))))
7567            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
7568            and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
7569                       or else Attribute_Name (Original_Node (N)) = Name_Access)
7570          then
7571             Apply_Accessibility_Check (Operand, Target_Type);
7572
7573          --  If the level of the operand type is statically deeper then the
7574          --  level of the target type, then force Program_Error. Note that this
7575          --  can only occur for cases where the attribute is within the body of
7576          --  an instantiation (otherwise the conversion will already have been
7577          --  rejected as illegal). Note: warnings are issued by the analyzer
7578          --  for the instance cases.
7579
7580          elsif In_Instance_Body
7581            and then Type_Access_Level (Operand_Type) >
7582                     Type_Access_Level (Target_Type)
7583          then
7584             Rewrite (N,
7585               Make_Raise_Program_Error (Sloc (N),
7586                 Reason => PE_Accessibility_Check_Failed));
7587             Set_Etype (N, Target_Type);
7588
7589          --  When the operand is a selected access discriminant the check needs
7590          --  to be made against the level of the object denoted by the prefix
7591          --  of the selected name. Force Program_Error for this case as well
7592          --  (this accessibility violation can only happen if within the body
7593          --  of an instantiation).
7594
7595          elsif In_Instance_Body
7596            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
7597            and then Nkind (Operand) = N_Selected_Component
7598            and then Object_Access_Level (Operand) >
7599                       Type_Access_Level (Target_Type)
7600          then
7601             Rewrite (N,
7602               Make_Raise_Program_Error (Sloc (N),
7603                 Reason => PE_Accessibility_Check_Failed));
7604             Set_Etype (N, Target_Type);
7605          end if;
7606       end if;
7607
7608       --  Case of conversions of tagged types and access to tagged types
7609
7610       --  When needed, that is to say when the expression is class-wide, Add
7611       --  runtime a tag check for (strict) downward conversion by using the
7612       --  membership test, generating:
7613
7614       --      [constraint_error when Operand not in Target_Type'Class]
7615
7616       --  or in the access type case
7617
7618       --      [constraint_error
7619       --        when Operand /= null
7620       --          and then Operand.all not in
7621       --            Designated_Type (Target_Type)'Class]
7622
7623       if (Is_Access_Type (Target_Type)
7624            and then Is_Tagged_Type (Designated_Type (Target_Type)))
7625         or else Is_Tagged_Type (Target_Type)
7626       then
7627          --  Do not do any expansion in the access type case if the parent is a
7628          --  renaming, since this is an error situation which will be caught by
7629          --  Sem_Ch8, and the expansion can interfere with this error check.
7630
7631          if Is_Access_Type (Target_Type)
7632            and then Is_Renamed_Object (N)
7633          then
7634             return;
7635          end if;
7636
7637          --  Otherwise, proceed with processing tagged conversion
7638
7639          declare
7640             Actual_Op_Typ   : Entity_Id;
7641             Actual_Targ_Typ : Entity_Id;
7642             Make_Conversion : Boolean := False;
7643             Root_Op_Typ     : Entity_Id;
7644
7645             procedure Make_Tag_Check (Targ_Typ : Entity_Id);
7646             --  Create a membership check to test whether Operand is a member
7647             --  of Targ_Typ. If the original Target_Type is an access, include
7648             --  a test for null value. The check is inserted at N.
7649
7650             --------------------
7651             -- Make_Tag_Check --
7652             --------------------
7653
7654             procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
7655                Cond : Node_Id;
7656
7657             begin
7658                --  Generate:
7659                --    [Constraint_Error
7660                --       when Operand /= null
7661                --         and then Operand.all not in Targ_Typ]
7662
7663                if Is_Access_Type (Target_Type) then
7664                   Cond :=
7665                     Make_And_Then (Loc,
7666                       Left_Opnd =>
7667                         Make_Op_Ne (Loc,
7668                           Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
7669                           Right_Opnd => Make_Null (Loc)),
7670
7671                       Right_Opnd =>
7672                         Make_Not_In (Loc,
7673                           Left_Opnd  =>
7674                             Make_Explicit_Dereference (Loc,
7675                               Prefix => Duplicate_Subexpr_No_Checks (Operand)),
7676                           Right_Opnd => New_Reference_To (Targ_Typ, Loc)));
7677
7678                --  Generate:
7679                --    [Constraint_Error when Operand not in Targ_Typ]
7680
7681                else
7682                   Cond :=
7683                     Make_Not_In (Loc,
7684                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
7685                       Right_Opnd => New_Reference_To (Targ_Typ, Loc));
7686                end if;
7687
7688                Insert_Action (N,
7689                  Make_Raise_Constraint_Error (Loc,
7690                    Condition => Cond,
7691                    Reason    => CE_Tag_Check_Failed));
7692             end Make_Tag_Check;
7693
7694          --  Start of processing
7695
7696          begin
7697             if Is_Access_Type (Target_Type) then
7698                Actual_Op_Typ   := Designated_Type (Operand_Type);
7699                Actual_Targ_Typ := Designated_Type (Target_Type);
7700
7701             else
7702                Actual_Op_Typ   := Operand_Type;
7703                Actual_Targ_Typ := Target_Type;
7704             end if;
7705
7706             Root_Op_Typ := Root_Type (Actual_Op_Typ);
7707
7708             --  Ada 2005 (AI-251): Handle interface type conversion
7709
7710             if Is_Interface (Actual_Op_Typ) then
7711                Expand_Interface_Conversion (N, Is_Static => False);
7712                return;
7713             end if;
7714
7715             if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
7716
7717                --  Create a runtime tag check for a downward class-wide type
7718                --  conversion.
7719
7720                if Is_Class_Wide_Type (Actual_Op_Typ)
7721                  and then Root_Op_Typ /= Actual_Targ_Typ
7722                  and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
7723                then
7724                   Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
7725                   Make_Conversion := True;
7726                end if;
7727
7728                --  AI05-0073: If the result subtype of the function is defined
7729                --  by an access_definition designating a specific tagged type
7730                --  T, a check is made that the result value is null or the tag
7731                --  of the object designated by the result value identifies T.
7732                --  Constraint_Error is raised if this check fails.
7733
7734                if Nkind (Parent (N)) = Sinfo.N_Return_Statement then
7735                   declare
7736                      Func     : Entity_Id;
7737                      Func_Typ : Entity_Id;
7738
7739                   begin
7740                      --  Climb scope stack looking for the enclosing function
7741
7742                      Func := Current_Scope;
7743                      while Present (Func)
7744                        and then Ekind (Func) /= E_Function
7745                      loop
7746                         Func := Scope (Func);
7747                      end loop;
7748
7749                      --  The function's return subtype must be defined using
7750                      --  an access definition.
7751
7752                      if Nkind (Result_Definition (Parent (Func))) =
7753                           N_Access_Definition
7754                      then
7755                         Func_Typ := Directly_Designated_Type (Etype (Func));
7756
7757                         --  The return subtype denotes a specific tagged type,
7758                         --  in other words, a non class-wide type.
7759
7760                         if Is_Tagged_Type (Func_Typ)
7761                           and then not Is_Class_Wide_Type (Func_Typ)
7762                         then
7763                            Make_Tag_Check (Actual_Targ_Typ);
7764                            Make_Conversion := True;
7765                         end if;
7766                      end if;
7767                   end;
7768                end if;
7769
7770                --  We have generated a tag check for either a class-wide type
7771                --  conversion or for AI05-0073.
7772
7773                if Make_Conversion then
7774                   declare
7775                      Conv : Node_Id;
7776                   begin
7777                      Conv :=
7778                        Make_Unchecked_Type_Conversion (Loc,
7779                          Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
7780                          Expression   => Relocate_Node (Expression (N)));
7781                      Rewrite (N, Conv);
7782                      Analyze_And_Resolve (N, Target_Type);
7783                   end;
7784                end if;
7785             end if;
7786          end;
7787
7788       --  Case of other access type conversions
7789
7790       elsif Is_Access_Type (Target_Type) then
7791          Apply_Constraint_Check (Operand, Target_Type);
7792
7793       --  Case of conversions from a fixed-point type
7794
7795       --  These conversions require special expansion and processing, found in
7796       --  the Exp_Fixd package. We ignore cases where Conversion_OK is set,
7797       --  since from a semantic point of view, these are simple integer
7798       --  conversions, which do not need further processing.
7799
7800       elsif Is_Fixed_Point_Type (Operand_Type)
7801         and then not Conversion_OK (N)
7802       then
7803          --  We should never see universal fixed at this case, since the
7804          --  expansion of the constituent divide or multiply should have
7805          --  eliminated the explicit mention of universal fixed.
7806
7807          pragma Assert (Operand_Type /= Universal_Fixed);
7808
7809          --  Check for special case of the conversion to universal real that
7810          --  occurs as a result of the use of a round attribute. In this case,
7811          --  the real type for the conversion is taken from the target type of
7812          --  the Round attribute and the result must be marked as rounded.
7813
7814          if Target_Type = Universal_Real
7815            and then Nkind (Parent (N)) = N_Attribute_Reference
7816            and then Attribute_Name (Parent (N)) = Name_Round
7817          then
7818             Set_Rounded_Result (N);
7819             Set_Etype (N, Etype (Parent (N)));
7820          end if;
7821
7822          --  Otherwise do correct fixed-conversion, but skip these if the
7823          --  Conversion_OK flag is set, because from a semantic point of
7824          --  view these are simple integer conversions needing no further
7825          --  processing (the backend will simply treat them as integers)
7826
7827          if not Conversion_OK (N) then
7828             if Is_Fixed_Point_Type (Etype (N)) then
7829                Expand_Convert_Fixed_To_Fixed (N);
7830                Real_Range_Check;
7831
7832             elsif Is_Integer_Type (Etype (N)) then
7833                Expand_Convert_Fixed_To_Integer (N);
7834
7835             else
7836                pragma Assert (Is_Floating_Point_Type (Etype (N)));
7837                Expand_Convert_Fixed_To_Float (N);
7838                Real_Range_Check;
7839             end if;
7840          end if;
7841
7842       --  Case of conversions to a fixed-point type
7843
7844       --  These conversions require special expansion and processing, found in
7845       --  the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
7846       --  since from a semantic point of view, these are simple integer
7847       --  conversions, which do not need further processing.
7848
7849       elsif Is_Fixed_Point_Type (Target_Type)
7850         and then not Conversion_OK (N)
7851       then
7852          if Is_Integer_Type (Operand_Type) then
7853             Expand_Convert_Integer_To_Fixed (N);
7854             Real_Range_Check;
7855          else
7856             pragma Assert (Is_Floating_Point_Type (Operand_Type));
7857             Expand_Convert_Float_To_Fixed (N);
7858             Real_Range_Check;
7859          end if;
7860
7861       --  Case of float-to-integer conversions
7862
7863       --  We also handle float-to-fixed conversions with Conversion_OK set
7864       --  since semantically the fixed-point target is treated as though it
7865       --  were an integer in such cases.
7866
7867       elsif Is_Floating_Point_Type (Operand_Type)
7868         and then
7869           (Is_Integer_Type (Target_Type)
7870             or else
7871           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
7872       then
7873          --  One more check here, gcc is still not able to do conversions of
7874          --  this type with proper overflow checking, and so gigi is doing an
7875          --  approximation of what is required by doing floating-point compares
7876          --  with the end-point. But that can lose precision in some cases, and
7877          --  give a wrong result. Converting the operand to Universal_Real is
7878          --  helpful, but still does not catch all cases with 64-bit integers
7879          --  on targets with only 64-bit floats
7880
7881          --  The above comment seems obsoleted by Apply_Float_Conversion_Check
7882          --  Can this code be removed ???
7883
7884          if Do_Range_Check (Operand) then
7885             Rewrite (Operand,
7886               Make_Type_Conversion (Loc,
7887                 Subtype_Mark =>
7888                   New_Occurrence_Of (Universal_Real, Loc),
7889                 Expression =>
7890                   Relocate_Node (Operand)));
7891
7892             Set_Etype (Operand, Universal_Real);
7893             Enable_Range_Check (Operand);
7894             Set_Do_Range_Check (Expression (Operand), False);
7895          end if;
7896
7897       --  Case of array conversions
7898
7899       --  Expansion of array conversions, add required length/range checks but
7900       --  only do this if there is no change of representation. For handling of
7901       --  this case, see Handle_Changed_Representation.
7902
7903       elsif Is_Array_Type (Target_Type) then
7904
7905          if Is_Constrained (Target_Type) then
7906             Apply_Length_Check (Operand, Target_Type);
7907          else
7908             Apply_Range_Check (Operand, Target_Type);
7909          end if;
7910
7911          Handle_Changed_Representation;
7912
7913       --  Case of conversions of discriminated types
7914
7915       --  Add required discriminant checks if target is constrained. Again this
7916       --  change is skipped if we have a change of representation.
7917
7918       elsif Has_Discriminants (Target_Type)
7919         and then Is_Constrained (Target_Type)
7920       then
7921          Apply_Discriminant_Check (Operand, Target_Type);
7922          Handle_Changed_Representation;
7923
7924       --  Case of all other record conversions. The only processing required
7925       --  is to check for a change of representation requiring the special
7926       --  assignment processing.
7927
7928       elsif Is_Record_Type (Target_Type) then
7929
7930          --  Ada 2005 (AI-216): Program_Error is raised when converting from
7931          --  a derived Unchecked_Union type to an unconstrained type that is
7932          --  not Unchecked_Union if the operand lacks inferable discriminants.
7933
7934          if Is_Derived_Type (Operand_Type)
7935            and then Is_Unchecked_Union (Base_Type (Operand_Type))
7936            and then not Is_Constrained (Target_Type)
7937            and then not Is_Unchecked_Union (Base_Type (Target_Type))
7938            and then not Has_Inferable_Discriminants (Operand)
7939          then
7940             --  To prevent Gigi from generating illegal code, we generate a
7941             --  Program_Error node, but we give it the target type of the
7942             --  conversion.
7943
7944             declare
7945                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
7946                       Reason => PE_Unchecked_Union_Restriction);
7947
7948             begin
7949                Set_Etype (PE, Target_Type);
7950                Rewrite (N, PE);
7951
7952             end;
7953          else
7954             Handle_Changed_Representation;
7955          end if;
7956
7957       --  Case of conversions of enumeration types
7958
7959       elsif Is_Enumeration_Type (Target_Type) then
7960
7961          --  Special processing is required if there is a change of
7962          --  representation (from enumeration representation clauses)
7963
7964          if not Same_Representation (Target_Type, Operand_Type) then
7965
7966             --  Convert: x(y) to x'val (ytyp'val (y))
7967
7968             Rewrite (N,
7969                Make_Attribute_Reference (Loc,
7970                  Prefix => New_Occurrence_Of (Target_Type, Loc),
7971                  Attribute_Name => Name_Val,
7972                  Expressions => New_List (
7973                    Make_Attribute_Reference (Loc,
7974                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
7975                      Attribute_Name => Name_Pos,
7976                      Expressions => New_List (Operand)))));
7977
7978             Analyze_And_Resolve (N, Target_Type);
7979          end if;
7980
7981       --  Case of conversions to floating-point
7982
7983       elsif Is_Floating_Point_Type (Target_Type) then
7984          Real_Range_Check;
7985       end if;
7986
7987       --  At this stage, either the conversion node has been transformed into
7988       --  some other equivalent expression, or left as a conversion that can
7989       --  be handled by Gigi. The conversions that Gigi can handle are the
7990       --  following:
7991
7992       --    Conversions with no change of representation or type
7993
7994       --    Numeric conversions involving integer, floating- and fixed-point
7995       --    values. Fixed-point values are allowed only if Conversion_OK is
7996       --    set, i.e. if the fixed-point values are to be treated as integers.
7997
7998       --  No other conversions should be passed to Gigi
7999
8000       --  Check: are these rules stated in sinfo??? if so, why restate here???
8001
8002       --  The only remaining step is to generate a range check if we still have
8003       --  a type conversion at this stage and Do_Range_Check is set. For now we
8004       --  do this only for conversions of discrete types.
8005
8006       if Nkind (N) = N_Type_Conversion
8007         and then Is_Discrete_Type (Etype (N))
8008       then
8009          declare
8010             Expr : constant Node_Id := Expression (N);
8011             Ftyp : Entity_Id;
8012             Ityp : Entity_Id;
8013
8014          begin
8015             if Do_Range_Check (Expr)
8016               and then Is_Discrete_Type (Etype (Expr))
8017             then
8018                Set_Do_Range_Check (Expr, False);
8019
8020                --  Before we do a range check, we have to deal with treating a
8021                --  fixed-point operand as an integer. The way we do this is
8022                --  simply to do an unchecked conversion to an appropriate
8023                --  integer type large enough to hold the result.
8024
8025                --  This code is not active yet, because we are only dealing
8026                --  with discrete types so far ???
8027
8028                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
8029                  and then Treat_Fixed_As_Integer (Expr)
8030                then
8031                   Ftyp := Base_Type (Etype (Expr));
8032
8033                   if Esize (Ftyp) >= Esize (Standard_Integer) then
8034                      Ityp := Standard_Long_Long_Integer;
8035                   else
8036                      Ityp := Standard_Integer;
8037                   end if;
8038
8039                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
8040                end if;
8041
8042                --  Reset overflow flag, since the range check will include
8043                --  dealing with possible overflow, and generate the check If
8044                --  Address is either a source type or target type, suppress
8045                --  range check to avoid typing anomalies when it is a visible
8046                --  integer type.
8047
8048                Set_Do_Overflow_Check (N, False);
8049                if not Is_Descendent_Of_Address (Etype (Expr))
8050                  and then not Is_Descendent_Of_Address (Target_Type)
8051                then
8052                   Generate_Range_Check
8053                     (Expr, Target_Type, CE_Range_Check_Failed);
8054                end if;
8055             end if;
8056          end;
8057       end if;
8058
8059       --  Final step, if the result is a type conversion involving Vax_Float
8060       --  types, then it is subject for further special processing.
8061
8062       if Nkind (N) = N_Type_Conversion
8063         and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
8064       then
8065          Expand_Vax_Conversion (N);
8066          return;
8067       end if;
8068    end Expand_N_Type_Conversion;
8069
8070    -----------------------------------
8071    -- Expand_N_Unchecked_Expression --
8072    -----------------------------------
8073
8074    --  Remove the unchecked expression node from the tree. It's job was simply
8075    --  to make sure that its constituent expression was handled with checks
8076    --  off, and now that that is done, we can remove it from the tree, and
8077    --  indeed must, since gigi does not expect to see these nodes.
8078
8079    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
8080       Exp : constant Node_Id := Expression (N);
8081
8082    begin
8083       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
8084       Rewrite (N, Exp);
8085    end Expand_N_Unchecked_Expression;
8086
8087    ----------------------------------------
8088    -- Expand_N_Unchecked_Type_Conversion --
8089    ----------------------------------------
8090
8091    --  If this cannot be handled by Gigi and we haven't already made a
8092    --  temporary for it, do it now.
8093
8094    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
8095       Target_Type  : constant Entity_Id := Etype (N);
8096       Operand      : constant Node_Id   := Expression (N);
8097       Operand_Type : constant Entity_Id := Etype (Operand);
8098
8099    begin
8100       --  If we have a conversion of a compile time known value to a target
8101       --  type and the value is in range of the target type, then we can simply
8102       --  replace the construct by an integer literal of the correct type. We
8103       --  only apply this to integer types being converted. Possibly it may
8104       --  apply in other cases, but it is too much trouble to worry about.
8105
8106       --  Note that we do not do this transformation if the Kill_Range_Check
8107       --  flag is set, since then the value may be outside the expected range.
8108       --  This happens in the Normalize_Scalars case.
8109
8110       --  We also skip this if either the target or operand type is biased
8111       --  because in this case, the unchecked conversion is supposed to
8112       --  preserve the bit pattern, not the integer value.
8113
8114       if Is_Integer_Type (Target_Type)
8115         and then not Has_Biased_Representation (Target_Type)
8116         and then Is_Integer_Type (Operand_Type)
8117         and then not Has_Biased_Representation (Operand_Type)
8118         and then Compile_Time_Known_Value (Operand)
8119         and then not Kill_Range_Check (N)
8120       then
8121          declare
8122             Val : constant Uint := Expr_Value (Operand);
8123
8124          begin
8125             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
8126                  and then
8127                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
8128                  and then
8129                Val >= Expr_Value (Type_Low_Bound (Target_Type))
8130                  and then
8131                Val <= Expr_Value (Type_High_Bound (Target_Type))
8132             then
8133                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
8134
8135                --  If Address is the target type, just set the type to avoid a
8136                --  spurious type error on the literal when Address is a visible
8137                --  integer type.
8138
8139                if Is_Descendent_Of_Address (Target_Type) then
8140                   Set_Etype (N, Target_Type);
8141                else
8142                   Analyze_And_Resolve (N, Target_Type);
8143                end if;
8144
8145                return;
8146             end if;
8147          end;
8148       end if;
8149
8150       --  Nothing to do if conversion is safe
8151
8152       if Safe_Unchecked_Type_Conversion (N) then
8153          return;
8154       end if;
8155
8156       --  Otherwise force evaluation unless Assignment_OK flag is set (this
8157       --  flag indicates ??? -- more comments needed here)
8158
8159       if Assignment_OK (N) then
8160          null;
8161       else
8162          Force_Evaluation (N);
8163       end if;
8164    end Expand_N_Unchecked_Type_Conversion;
8165
8166    ----------------------------
8167    -- Expand_Record_Equality --
8168    ----------------------------
8169
8170    --  For non-variant records, Equality is expanded when needed into:
8171
8172    --      and then Lhs.Discr1 = Rhs.Discr1
8173    --      and then ...
8174    --      and then Lhs.Discrn = Rhs.Discrn
8175    --      and then Lhs.Cmp1 = Rhs.Cmp1
8176    --      and then ...
8177    --      and then Lhs.Cmpn = Rhs.Cmpn
8178
8179    --  The expression is folded by the back-end for adjacent fields. This
8180    --  function is called for tagged record in only one occasion: for imple-
8181    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
8182    --  otherwise the primitive "=" is used directly.
8183
8184    function Expand_Record_Equality
8185      (Nod    : Node_Id;
8186       Typ    : Entity_Id;
8187       Lhs    : Node_Id;
8188       Rhs    : Node_Id;
8189       Bodies : List_Id) return Node_Id
8190    is
8191       Loc : constant Source_Ptr := Sloc (Nod);
8192
8193       Result : Node_Id;
8194       C      : Entity_Id;
8195
8196       First_Time : Boolean := True;
8197
8198       function Suitable_Element (C : Entity_Id) return Entity_Id;
8199       --  Return the first field to compare beginning with C, skipping the
8200       --  inherited components.
8201
8202       ----------------------
8203       -- Suitable_Element --
8204       ----------------------
8205
8206       function Suitable_Element (C : Entity_Id) return Entity_Id is
8207       begin
8208          if No (C) then
8209             return Empty;
8210
8211          elsif Ekind (C) /= E_Discriminant
8212            and then Ekind (C) /= E_Component
8213          then
8214             return Suitable_Element (Next_Entity (C));
8215
8216          elsif Is_Tagged_Type (Typ)
8217            and then C /= Original_Record_Component (C)
8218          then
8219             return Suitable_Element (Next_Entity (C));
8220
8221          elsif Chars (C) = Name_uController
8222            or else Chars (C) = Name_uTag
8223          then
8224             return Suitable_Element (Next_Entity (C));
8225
8226          elsif Is_Interface (Etype (C)) then
8227             return Suitable_Element (Next_Entity (C));
8228
8229          else
8230             return C;
8231          end if;
8232       end Suitable_Element;
8233
8234    --  Start of processing for Expand_Record_Equality
8235
8236    begin
8237       --  Generates the following code: (assuming that Typ has one Discr and
8238       --  component C2 is also a record)
8239
8240       --   True
8241       --     and then Lhs.Discr1 = Rhs.Discr1
8242       --     and then Lhs.C1 = Rhs.C1
8243       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8244       --     and then ...
8245       --     and then Lhs.Cmpn = Rhs.Cmpn
8246
8247       Result := New_Reference_To (Standard_True, Loc);
8248       C := Suitable_Element (First_Entity (Typ));
8249
8250       while Present (C) loop
8251          declare
8252             New_Lhs : Node_Id;
8253             New_Rhs : Node_Id;
8254             Check   : Node_Id;
8255
8256          begin
8257             if First_Time then
8258                First_Time := False;
8259                New_Lhs := Lhs;
8260                New_Rhs := Rhs;
8261             else
8262                New_Lhs := New_Copy_Tree (Lhs);
8263                New_Rhs := New_Copy_Tree (Rhs);
8264             end if;
8265
8266             Check :=
8267               Expand_Composite_Equality (Nod, Etype (C),
8268                Lhs =>
8269                  Make_Selected_Component (Loc,
8270                    Prefix => New_Lhs,
8271                    Selector_Name => New_Reference_To (C, Loc)),
8272                Rhs =>
8273                  Make_Selected_Component (Loc,
8274                    Prefix => New_Rhs,
8275                    Selector_Name => New_Reference_To (C, Loc)),
8276                Bodies => Bodies);
8277
8278             --  If some (sub)component is an unchecked_union, the whole
8279             --  operation will raise program error.
8280
8281             if Nkind (Check) = N_Raise_Program_Error then
8282                Result := Check;
8283                Set_Etype (Result, Standard_Boolean);
8284                exit;
8285             else
8286                Result :=
8287                  Make_And_Then (Loc,
8288                    Left_Opnd  => Result,
8289                    Right_Opnd => Check);
8290             end if;
8291          end;
8292
8293          C := Suitable_Element (Next_Entity (C));
8294       end loop;
8295
8296       return Result;
8297    end Expand_Record_Equality;
8298
8299    -------------------------------------
8300    -- Fixup_Universal_Fixed_Operation --
8301    -------------------------------------
8302
8303    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
8304       Conv : constant Node_Id := Parent (N);
8305
8306    begin
8307       --  We must have a type conversion immediately above us
8308
8309       pragma Assert (Nkind (Conv) = N_Type_Conversion);
8310
8311       --  Normally the type conversion gives our target type. The exception
8312       --  occurs in the case of the Round attribute, where the conversion
8313       --  will be to universal real, and our real type comes from the Round
8314       --  attribute (as well as an indication that we must round the result)
8315
8316       if Nkind (Parent (Conv)) = N_Attribute_Reference
8317         and then Attribute_Name (Parent (Conv)) = Name_Round
8318       then
8319          Set_Etype (N, Etype (Parent (Conv)));
8320          Set_Rounded_Result (N);
8321
8322       --  Normal case where type comes from conversion above us
8323
8324       else
8325          Set_Etype (N, Etype (Conv));
8326       end if;
8327    end Fixup_Universal_Fixed_Operation;
8328
8329    ------------------------------
8330    -- Get_Allocator_Final_List --
8331    ------------------------------
8332
8333    function Get_Allocator_Final_List
8334      (N    : Node_Id;
8335       T    : Entity_Id;
8336       PtrT : Entity_Id) return Entity_Id
8337    is
8338       Loc : constant Source_Ptr := Sloc (N);
8339
8340       Owner : Entity_Id := PtrT;
8341       --  The entity whose finalization list must be used to attach the
8342       --  allocated object.
8343
8344    begin
8345       if Ekind (PtrT) = E_Anonymous_Access_Type then
8346
8347          --  If the context is an access parameter, we need to create a
8348          --  non-anonymous access type in order to have a usable final list,
8349          --  because there is otherwise no pool to which the allocated object
8350          --  can belong. We create both the type and the finalization chain
8351          --  here, because freezing an internal type does not create such a
8352          --  chain. The Final_Chain that is thus created is shared by the
8353          --  access parameter. The access type is tested against the result
8354          --  type of the function to exclude allocators whose type is an
8355          --  anonymous access result type.
8356
8357          if Nkind (Associated_Node_For_Itype (PtrT))
8358               in N_Subprogram_Specification
8359            and then
8360              PtrT /=
8361                Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT)))
8362          then
8363             Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
8364             Insert_Action (N,
8365               Make_Full_Type_Declaration (Loc,
8366                 Defining_Identifier => Owner,
8367                 Type_Definition =>
8368                    Make_Access_To_Object_Definition (Loc,
8369                      Subtype_Indication =>
8370                        New_Occurrence_Of (T, Loc))));
8371
8372             Build_Final_List (N, Owner);
8373             Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
8374
8375          --  Ada 2005 (AI-318-02): If the context is a return object
8376          --  declaration, then the anonymous return subtype is defined to have
8377          --  the same accessibility level as that of the function's result
8378          --  subtype, which means that we want the scope where the function is
8379          --  declared.
8380
8381          elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration
8382            and then Ekind (Scope (PtrT)) = E_Return_Statement
8383          then
8384             Owner := Scope (Return_Applies_To (Scope (PtrT)));
8385
8386          --  Case of an access discriminant, or (Ada 2005), of an anonymous
8387          --  access component or anonymous access function result: find the
8388          --  final list associated with the scope of the type. (In the
8389          --  anonymous access component kind, a list controller will have
8390          --  been allocated when freezing the record type, and PtrT has an
8391          --  Associated_Final_Chain attribute designating it.)
8392
8393          elsif No (Associated_Final_Chain (PtrT)) then
8394             Owner := Scope (PtrT);
8395          end if;
8396       end if;
8397
8398       return Find_Final_List (Owner);
8399    end Get_Allocator_Final_List;
8400
8401    ---------------------------------
8402    -- Has_Inferable_Discriminants --
8403    ---------------------------------
8404
8405    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
8406
8407       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
8408       --  Determines whether the left-most prefix of a selected component is a
8409       --  formal parameter in a subprogram. Assumes N is a selected component.
8410
8411       --------------------------------
8412       -- Prefix_Is_Formal_Parameter --
8413       --------------------------------
8414
8415       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
8416          Sel_Comp : Node_Id := N;
8417
8418       begin
8419          --  Move to the left-most prefix by climbing up the tree
8420
8421          while Present (Parent (Sel_Comp))
8422            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
8423          loop
8424             Sel_Comp := Parent (Sel_Comp);
8425          end loop;
8426
8427          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
8428       end Prefix_Is_Formal_Parameter;
8429
8430    --  Start of processing for Has_Inferable_Discriminants
8431
8432    begin
8433       --  For identifiers and indexed components, it is sufficient to have a
8434       --  constrained Unchecked_Union nominal subtype.
8435
8436       if Nkind_In (N, N_Identifier, N_Indexed_Component) then
8437          return Is_Unchecked_Union (Base_Type (Etype (N)))
8438                   and then
8439                 Is_Constrained (Etype (N));
8440
8441       --  For selected components, the subtype of the selector must be a
8442       --  constrained Unchecked_Union. If the component is subject to a
8443       --  per-object constraint, then the enclosing object must have inferable
8444       --  discriminants.
8445
8446       elsif Nkind (N) = N_Selected_Component then
8447          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
8448
8449             --  A small hack. If we have a per-object constrained selected
8450             --  component of a formal parameter, return True since we do not
8451             --  know the actual parameter association yet.
8452
8453             if Prefix_Is_Formal_Parameter (N) then
8454                return True;
8455             end if;
8456
8457             --  Otherwise, check the enclosing object and the selector
8458
8459             return Has_Inferable_Discriminants (Prefix (N))
8460                      and then
8461                    Has_Inferable_Discriminants (Selector_Name (N));
8462          end if;
8463
8464          --  The call to Has_Inferable_Discriminants will determine whether
8465          --  the selector has a constrained Unchecked_Union nominal type.
8466
8467          return Has_Inferable_Discriminants (Selector_Name (N));
8468
8469       --  A qualified expression has inferable discriminants if its subtype
8470       --  mark is a constrained Unchecked_Union subtype.
8471
8472       elsif Nkind (N) = N_Qualified_Expression then
8473          return Is_Unchecked_Union (Subtype_Mark (N))
8474                   and then
8475                 Is_Constrained (Subtype_Mark (N));
8476
8477       end if;
8478
8479       return False;
8480    end Has_Inferable_Discriminants;
8481
8482    -------------------------------
8483    -- Insert_Dereference_Action --
8484    -------------------------------
8485
8486    procedure Insert_Dereference_Action (N : Node_Id) is
8487       Loc  : constant Source_Ptr := Sloc (N);
8488       Typ  : constant Entity_Id  := Etype (N);
8489       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
8490       Pnod : constant Node_Id    := Parent (N);
8491
8492       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
8493       --  Return true if type of P is derived from Checked_Pool;
8494
8495       -----------------------------
8496       -- Is_Checked_Storage_Pool --
8497       -----------------------------
8498
8499       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
8500          T : Entity_Id;
8501
8502       begin
8503          if No (P) then
8504             return False;
8505          end if;
8506
8507          T := Etype (P);
8508          while T /= Etype (T) loop
8509             if Is_RTE (T, RE_Checked_Pool) then
8510                return True;
8511             else
8512                T := Etype (T);
8513             end if;
8514          end loop;
8515
8516          return False;
8517       end Is_Checked_Storage_Pool;
8518
8519    --  Start of processing for Insert_Dereference_Action
8520
8521    begin
8522       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
8523
8524       if not (Is_Checked_Storage_Pool (Pool)
8525               and then Comes_From_Source (Original_Node (Pnod)))
8526       then
8527          return;
8528       end if;
8529
8530       Insert_Action (N,
8531         Make_Procedure_Call_Statement (Loc,
8532           Name => New_Reference_To (
8533             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
8534
8535           Parameter_Associations => New_List (
8536
8537             --  Pool
8538
8539              New_Reference_To (Pool, Loc),
8540
8541             --  Storage_Address. We use the attribute Pool_Address, which uses
8542             --  the pointer itself to find the address of the object, and which
8543             --  handles unconstrained arrays properly by computing the address
8544             --  of the template. i.e. the correct address of the corresponding
8545             --  allocation.
8546
8547              Make_Attribute_Reference (Loc,
8548                Prefix         => Duplicate_Subexpr_Move_Checks (N),
8549                Attribute_Name => Name_Pool_Address),
8550
8551             --  Size_In_Storage_Elements
8552
8553              Make_Op_Divide (Loc,
8554                Left_Opnd  =>
8555                 Make_Attribute_Reference (Loc,
8556                   Prefix         =>
8557                     Make_Explicit_Dereference (Loc,
8558                       Duplicate_Subexpr_Move_Checks (N)),
8559                   Attribute_Name => Name_Size),
8560                Right_Opnd =>
8561                  Make_Integer_Literal (Loc, System_Storage_Unit)),
8562
8563             --  Alignment
8564
8565              Make_Attribute_Reference (Loc,
8566                Prefix         =>
8567                  Make_Explicit_Dereference (Loc,
8568                    Duplicate_Subexpr_Move_Checks (N)),
8569                Attribute_Name => Name_Alignment))));
8570
8571    exception
8572       when RE_Not_Available =>
8573          return;
8574    end Insert_Dereference_Action;
8575
8576    ------------------------------
8577    -- Make_Array_Comparison_Op --
8578    ------------------------------
8579
8580    --  This is a hand-coded expansion of the following generic function:
8581
8582    --  generic
8583    --    type elem is  (<>);
8584    --    type index is (<>);
8585    --    type a is array (index range <>) of elem;
8586
8587    --  function Gnnn (X : a; Y: a) return boolean is
8588    --    J : index := Y'first;
8589
8590    --  begin
8591    --    if X'length = 0 then
8592    --       return false;
8593
8594    --    elsif Y'length = 0 then
8595    --       return true;
8596
8597    --    else
8598    --      for I in X'range loop
8599    --        if X (I) = Y (J) then
8600    --          if J = Y'last then
8601    --            exit;
8602    --          else
8603    --            J := index'succ (J);
8604    --          end if;
8605
8606    --        else
8607    --           return X (I) > Y (J);
8608    --        end if;
8609    --      end loop;
8610
8611    --      return X'length > Y'length;
8612    --    end if;
8613    --  end Gnnn;
8614
8615    --  Note that since we are essentially doing this expansion by hand, we
8616    --  do not need to generate an actual or formal generic part, just the
8617    --  instantiated function itself.
8618
8619    function Make_Array_Comparison_Op
8620      (Typ : Entity_Id;
8621       Nod : Node_Id) return Node_Id
8622    is
8623       Loc : constant Source_Ptr := Sloc (Nod);
8624
8625       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
8626       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
8627       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
8628       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8629
8630       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
8631
8632       Loop_Statement : Node_Id;
8633       Loop_Body      : Node_Id;
8634       If_Stat        : Node_Id;
8635       Inner_If       : Node_Id;
8636       Final_Expr     : Node_Id;
8637       Func_Body      : Node_Id;
8638       Func_Name      : Entity_Id;
8639       Formals        : List_Id;
8640       Length1        : Node_Id;
8641       Length2        : Node_Id;
8642
8643    begin
8644       --  if J = Y'last then
8645       --     exit;
8646       --  else
8647       --     J := index'succ (J);
8648       --  end if;
8649
8650       Inner_If :=
8651         Make_Implicit_If_Statement (Nod,
8652           Condition =>
8653             Make_Op_Eq (Loc,
8654               Left_Opnd => New_Reference_To (J, Loc),
8655               Right_Opnd =>
8656                 Make_Attribute_Reference (Loc,
8657                   Prefix => New_Reference_To (Y, Loc),
8658                   Attribute_Name => Name_Last)),
8659
8660           Then_Statements => New_List (
8661                 Make_Exit_Statement (Loc)),
8662
8663           Else_Statements =>
8664             New_List (
8665               Make_Assignment_Statement (Loc,
8666                 Name => New_Reference_To (J, Loc),
8667                 Expression =>
8668                   Make_Attribute_Reference (Loc,
8669                     Prefix => New_Reference_To (Index, Loc),
8670                     Attribute_Name => Name_Succ,
8671                     Expressions => New_List (New_Reference_To (J, Loc))))));
8672
8673       --  if X (I) = Y (J) then
8674       --     if ... end if;
8675       --  else
8676       --     return X (I) > Y (J);
8677       --  end if;
8678
8679       Loop_Body :=
8680         Make_Implicit_If_Statement (Nod,
8681           Condition =>
8682             Make_Op_Eq (Loc,
8683               Left_Opnd =>
8684                 Make_Indexed_Component (Loc,
8685                   Prefix      => New_Reference_To (X, Loc),
8686                   Expressions => New_List (New_Reference_To (I, Loc))),
8687
8688               Right_Opnd =>
8689                 Make_Indexed_Component (Loc,
8690                   Prefix      => New_Reference_To (Y, Loc),
8691                   Expressions => New_List (New_Reference_To (J, Loc)))),
8692
8693           Then_Statements => New_List (Inner_If),
8694
8695           Else_Statements => New_List (
8696             Make_Simple_Return_Statement (Loc,
8697               Expression =>
8698                 Make_Op_Gt (Loc,
8699                   Left_Opnd =>
8700                     Make_Indexed_Component (Loc,
8701                       Prefix      => New_Reference_To (X, Loc),
8702                       Expressions => New_List (New_Reference_To (I, Loc))),
8703
8704                   Right_Opnd =>
8705                     Make_Indexed_Component (Loc,
8706                       Prefix      => New_Reference_To (Y, Loc),
8707                       Expressions => New_List (
8708                         New_Reference_To (J, Loc)))))));
8709
8710       --  for I in X'range loop
8711       --     if ... end if;
8712       --  end loop;
8713
8714       Loop_Statement :=
8715         Make_Implicit_Loop_Statement (Nod,
8716           Identifier => Empty,
8717
8718           Iteration_Scheme =>
8719             Make_Iteration_Scheme (Loc,
8720               Loop_Parameter_Specification =>
8721                 Make_Loop_Parameter_Specification (Loc,
8722                   Defining_Identifier => I,
8723                   Discrete_Subtype_Definition =>
8724                     Make_Attribute_Reference (Loc,
8725                       Prefix => New_Reference_To (X, Loc),
8726                       Attribute_Name => Name_Range))),
8727
8728           Statements => New_List (Loop_Body));
8729
8730       --    if X'length = 0 then
8731       --       return false;
8732       --    elsif Y'length = 0 then
8733       --       return true;
8734       --    else
8735       --      for ... loop ... end loop;
8736       --      return X'length > Y'length;
8737       --    end if;
8738
8739       Length1 :=
8740         Make_Attribute_Reference (Loc,
8741           Prefix => New_Reference_To (X, Loc),
8742           Attribute_Name => Name_Length);
8743
8744       Length2 :=
8745         Make_Attribute_Reference (Loc,
8746           Prefix => New_Reference_To (Y, Loc),
8747           Attribute_Name => Name_Length);
8748
8749       Final_Expr :=
8750         Make_Op_Gt (Loc,
8751           Left_Opnd  => Length1,
8752           Right_Opnd => Length2);
8753
8754       If_Stat :=
8755         Make_Implicit_If_Statement (Nod,
8756           Condition =>
8757             Make_Op_Eq (Loc,
8758               Left_Opnd =>
8759                 Make_Attribute_Reference (Loc,
8760                   Prefix => New_Reference_To (X, Loc),
8761                   Attribute_Name => Name_Length),
8762               Right_Opnd =>
8763                 Make_Integer_Literal (Loc, 0)),
8764
8765           Then_Statements =>
8766             New_List (
8767               Make_Simple_Return_Statement (Loc,
8768                 Expression => New_Reference_To (Standard_False, Loc))),
8769
8770           Elsif_Parts => New_List (
8771             Make_Elsif_Part (Loc,
8772               Condition =>
8773                 Make_Op_Eq (Loc,
8774                   Left_Opnd =>
8775                     Make_Attribute_Reference (Loc,
8776                       Prefix => New_Reference_To (Y, Loc),
8777                       Attribute_Name => Name_Length),
8778                   Right_Opnd =>
8779                     Make_Integer_Literal (Loc, 0)),
8780
8781               Then_Statements =>
8782                 New_List (
8783                   Make_Simple_Return_Statement (Loc,
8784                      Expression => New_Reference_To (Standard_True, Loc))))),
8785
8786           Else_Statements => New_List (
8787             Loop_Statement,
8788             Make_Simple_Return_Statement (Loc,
8789               Expression => Final_Expr)));
8790
8791       --  (X : a; Y: a)
8792
8793       Formals := New_List (
8794         Make_Parameter_Specification (Loc,
8795           Defining_Identifier => X,
8796           Parameter_Type      => New_Reference_To (Typ, Loc)),
8797
8798         Make_Parameter_Specification (Loc,
8799           Defining_Identifier => Y,
8800           Parameter_Type      => New_Reference_To (Typ, Loc)));
8801
8802       --  function Gnnn (...) return boolean is
8803       --    J : index := Y'first;
8804       --  begin
8805       --    if ... end if;
8806       --  end Gnnn;
8807
8808       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
8809
8810       Func_Body :=
8811         Make_Subprogram_Body (Loc,
8812           Specification =>
8813             Make_Function_Specification (Loc,
8814               Defining_Unit_Name       => Func_Name,
8815               Parameter_Specifications => Formals,
8816               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
8817
8818           Declarations => New_List (
8819             Make_Object_Declaration (Loc,
8820               Defining_Identifier => J,
8821               Object_Definition   => New_Reference_To (Index, Loc),
8822               Expression =>
8823                 Make_Attribute_Reference (Loc,
8824                   Prefix => New_Reference_To (Y, Loc),
8825                   Attribute_Name => Name_First))),
8826
8827           Handled_Statement_Sequence =>
8828             Make_Handled_Sequence_Of_Statements (Loc,
8829               Statements => New_List (If_Stat)));
8830
8831       return Func_Body;
8832    end Make_Array_Comparison_Op;
8833
8834    ---------------------------
8835    -- Make_Boolean_Array_Op --
8836    ---------------------------
8837
8838    --  For logical operations on boolean arrays, expand in line the following,
8839    --  replacing 'and' with 'or' or 'xor' where needed:
8840
8841    --    function Annn (A : typ; B: typ) return typ is
8842    --       C : typ;
8843    --    begin
8844    --       for J in A'range loop
8845    --          C (J) := A (J) op B (J);
8846    --       end loop;
8847    --       return C;
8848    --    end Annn;
8849
8850    --  Here typ is the boolean array type
8851
8852    function Make_Boolean_Array_Op
8853      (Typ : Entity_Id;
8854       N   : Node_Id) return Node_Id
8855    is
8856       Loc : constant Source_Ptr := Sloc (N);
8857
8858       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
8859       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
8860       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
8861       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8862
8863       A_J : Node_Id;
8864       B_J : Node_Id;
8865       C_J : Node_Id;
8866       Op  : Node_Id;
8867
8868       Formals        : List_Id;
8869       Func_Name      : Entity_Id;
8870       Func_Body      : Node_Id;
8871       Loop_Statement : Node_Id;
8872
8873    begin
8874       A_J :=
8875         Make_Indexed_Component (Loc,
8876           Prefix      => New_Reference_To (A, Loc),
8877           Expressions => New_List (New_Reference_To (J, Loc)));
8878
8879       B_J :=
8880         Make_Indexed_Component (Loc,
8881           Prefix      => New_Reference_To (B, Loc),
8882           Expressions => New_List (New_Reference_To (J, Loc)));
8883
8884       C_J :=
8885         Make_Indexed_Component (Loc,
8886           Prefix      => New_Reference_To (C, Loc),
8887           Expressions => New_List (New_Reference_To (J, Loc)));
8888
8889       if Nkind (N) = N_Op_And then
8890          Op :=
8891            Make_Op_And (Loc,
8892              Left_Opnd  => A_J,
8893              Right_Opnd => B_J);
8894
8895       elsif Nkind (N) = N_Op_Or then
8896          Op :=
8897            Make_Op_Or (Loc,
8898              Left_Opnd  => A_J,
8899              Right_Opnd => B_J);
8900
8901       else
8902          Op :=
8903            Make_Op_Xor (Loc,
8904              Left_Opnd  => A_J,
8905              Right_Opnd => B_J);
8906       end if;
8907
8908       Loop_Statement :=
8909         Make_Implicit_Loop_Statement (N,
8910           Identifier => Empty,
8911
8912           Iteration_Scheme =>
8913             Make_Iteration_Scheme (Loc,
8914               Loop_Parameter_Specification =>
8915                 Make_Loop_Parameter_Specification (Loc,
8916                   Defining_Identifier => J,
8917                   Discrete_Subtype_Definition =>
8918                     Make_Attribute_Reference (Loc,
8919                       Prefix => New_Reference_To (A, Loc),
8920                       Attribute_Name => Name_Range))),
8921
8922           Statements => New_List (
8923             Make_Assignment_Statement (Loc,
8924               Name       => C_J,
8925               Expression => Op)));
8926
8927       Formals := New_List (
8928         Make_Parameter_Specification (Loc,
8929           Defining_Identifier => A,
8930           Parameter_Type      => New_Reference_To (Typ, Loc)),
8931
8932         Make_Parameter_Specification (Loc,
8933           Defining_Identifier => B,
8934           Parameter_Type      => New_Reference_To (Typ, Loc)));
8935
8936       Func_Name :=
8937         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8938       Set_Is_Inlined (Func_Name);
8939
8940       Func_Body :=
8941         Make_Subprogram_Body (Loc,
8942           Specification =>
8943             Make_Function_Specification (Loc,
8944               Defining_Unit_Name       => Func_Name,
8945               Parameter_Specifications => Formals,
8946               Result_Definition        => New_Reference_To (Typ, Loc)),
8947
8948           Declarations => New_List (
8949             Make_Object_Declaration (Loc,
8950               Defining_Identifier => C,
8951               Object_Definition   => New_Reference_To (Typ, Loc))),
8952
8953           Handled_Statement_Sequence =>
8954             Make_Handled_Sequence_Of_Statements (Loc,
8955               Statements => New_List (
8956                 Loop_Statement,
8957                 Make_Simple_Return_Statement (Loc,
8958                   Expression => New_Reference_To (C, Loc)))));
8959
8960       return Func_Body;
8961    end Make_Boolean_Array_Op;
8962
8963    ------------------------
8964    -- Rewrite_Comparison --
8965    ------------------------
8966
8967    procedure Rewrite_Comparison (N : Node_Id) is
8968    begin
8969       if Nkind (N) = N_Type_Conversion then
8970          Rewrite_Comparison (Expression (N));
8971          return;
8972
8973       elsif Nkind (N) not in N_Op_Compare then
8974          return;
8975       end if;
8976
8977       declare
8978          Typ : constant Entity_Id := Etype (N);
8979          Op1 : constant Node_Id   := Left_Opnd (N);
8980          Op2 : constant Node_Id   := Right_Opnd (N);
8981
8982          Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
8983          --  Res indicates if compare outcome can be compile time determined
8984
8985          True_Result  : Boolean;
8986          False_Result : Boolean;
8987
8988       begin
8989          case N_Op_Compare (Nkind (N)) is
8990             when N_Op_Eq =>
8991                True_Result  := Res = EQ;
8992                False_Result := Res = LT or else Res = GT or else Res = NE;
8993
8994             when N_Op_Ge =>
8995                True_Result  := Res in Compare_GE;
8996                False_Result := Res = LT;
8997
8998                if Res = LE
8999                  and then Constant_Condition_Warnings
9000                  and then Comes_From_Source (Original_Node (N))
9001                  and then Nkind (Original_Node (N)) = N_Op_Ge
9002                  and then not In_Instance
9003                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
9004                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
9005                then
9006                   Error_Msg_N
9007                     ("can never be greater than, could replace by ""'=""?", N);
9008                end if;
9009
9010             when N_Op_Gt =>
9011                True_Result  := Res = GT;
9012                False_Result := Res in Compare_LE;
9013
9014             when N_Op_Lt =>
9015                True_Result  := Res = LT;
9016                False_Result := Res in Compare_GE;
9017
9018             when N_Op_Le =>
9019                True_Result  := Res in Compare_LE;
9020                False_Result := Res = GT;
9021
9022                if Res = GE
9023                  and then Constant_Condition_Warnings
9024                  and then Comes_From_Source (Original_Node (N))
9025                  and then Nkind (Original_Node (N)) = N_Op_Le
9026                  and then not In_Instance
9027                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
9028                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
9029                then
9030                   Error_Msg_N
9031                     ("can never be less than, could replace by ""'=""?", N);
9032                end if;
9033
9034             when N_Op_Ne =>
9035                True_Result  := Res = NE or else Res = GT or else Res = LT;
9036                False_Result := Res = EQ;
9037          end case;
9038
9039          if True_Result then
9040             Rewrite (N,
9041               Convert_To (Typ,
9042                 New_Occurrence_Of (Standard_True, Sloc (N))));
9043             Analyze_And_Resolve (N, Typ);
9044             Warn_On_Known_Condition (N);
9045
9046          elsif False_Result then
9047             Rewrite (N,
9048               Convert_To (Typ,
9049                 New_Occurrence_Of (Standard_False, Sloc (N))));
9050             Analyze_And_Resolve (N, Typ);
9051             Warn_On_Known_Condition (N);
9052          end if;
9053       end;
9054    end Rewrite_Comparison;
9055
9056    ----------------------------
9057    -- Safe_In_Place_Array_Op --
9058    ----------------------------
9059
9060    function Safe_In_Place_Array_Op
9061      (Lhs : Node_Id;
9062       Op1 : Node_Id;
9063       Op2 : Node_Id) return Boolean
9064    is
9065       Target : Entity_Id;
9066
9067       function Is_Safe_Operand (Op : Node_Id) return Boolean;
9068       --  Operand is safe if it cannot overlap part of the target of the
9069       --  operation. If the operand and the target are identical, the operand
9070       --  is safe. The operand can be empty in the case of negation.
9071
9072       function Is_Unaliased (N : Node_Id) return Boolean;
9073       --  Check that N is a stand-alone entity
9074
9075       ------------------
9076       -- Is_Unaliased --
9077       ------------------
9078
9079       function Is_Unaliased (N : Node_Id) return Boolean is
9080       begin
9081          return
9082            Is_Entity_Name (N)
9083              and then No (Address_Clause (Entity (N)))
9084              and then No (Renamed_Object (Entity (N)));
9085       end Is_Unaliased;
9086
9087       ---------------------
9088       -- Is_Safe_Operand --
9089       ---------------------
9090
9091       function Is_Safe_Operand (Op : Node_Id) return Boolean is
9092       begin
9093          if No (Op) then
9094             return True;
9095
9096          elsif Is_Entity_Name (Op) then
9097             return Is_Unaliased (Op);
9098
9099          elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
9100             return Is_Unaliased (Prefix (Op));
9101
9102          elsif Nkind (Op) = N_Slice then
9103             return
9104               Is_Unaliased (Prefix (Op))
9105                 and then Entity (Prefix (Op)) /= Target;
9106
9107          elsif Nkind (Op) = N_Op_Not then
9108             return Is_Safe_Operand (Right_Opnd (Op));
9109
9110          else
9111             return False;
9112          end if;
9113       end Is_Safe_Operand;
9114
9115       --  Start of processing for Is_Safe_In_Place_Array_Op
9116
9117    begin
9118       --  Skip this processing if the component size is different from system
9119       --  storage unit (since at least for NOT this would cause problems).
9120
9121       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
9122          return False;
9123
9124       --  Cannot do in place stuff on VM_Target since cannot pass addresses
9125
9126       elsif VM_Target /= No_VM then
9127          return False;
9128
9129       --  Cannot do in place stuff if non-standard Boolean representation
9130
9131       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
9132          return False;
9133
9134       elsif not Is_Unaliased (Lhs) then
9135          return False;
9136       else
9137          Target := Entity (Lhs);
9138
9139          return
9140            Is_Safe_Operand (Op1)
9141              and then Is_Safe_Operand (Op2);
9142       end if;
9143    end Safe_In_Place_Array_Op;
9144
9145    -----------------------
9146    -- Tagged_Membership --
9147    -----------------------
9148
9149    --  There are two different cases to consider depending on whether the right
9150    --  operand is a class-wide type or not. If not we just compare the actual
9151    --  tag of the left expr to the target type tag:
9152    --
9153    --     Left_Expr.Tag = Right_Type'Tag;
9154    --
9155    --  If it is a class-wide type we use the RT function CW_Membership which is
9156    --  usually implemented by looking in the ancestor tables contained in the
9157    --  dispatch table pointed by Left_Expr.Tag for Typ'Tag
9158
9159    --  Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9160    --  function IW_Membership which is usually implemented by looking in the
9161    --  table of abstract interface types plus the ancestor table contained in
9162    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9163
9164    function Tagged_Membership (N : Node_Id) return Node_Id is
9165       Left  : constant Node_Id    := Left_Opnd  (N);
9166       Right : constant Node_Id    := Right_Opnd (N);
9167       Loc   : constant Source_Ptr := Sloc (N);
9168
9169       Left_Type  : Entity_Id;
9170       Right_Type : Entity_Id;
9171       Obj_Tag    : Node_Id;
9172
9173    begin
9174       Left_Type  := Etype (Left);
9175       Right_Type := Etype (Right);
9176
9177       if Is_Class_Wide_Type (Left_Type) then
9178          Left_Type := Root_Type (Left_Type);
9179       end if;
9180
9181       Obj_Tag :=
9182         Make_Selected_Component (Loc,
9183           Prefix        => Relocate_Node (Left),
9184           Selector_Name =>
9185             New_Reference_To (First_Tag_Component (Left_Type), Loc));
9186
9187       if Is_Class_Wide_Type (Right_Type) then
9188
9189          --  No need to issue a run-time check if we statically know that the
9190          --  result of this membership test is always true. For example,
9191          --  considering the following declarations:
9192
9193          --    type Iface is interface;
9194          --    type T     is tagged null record;
9195          --    type DT    is new T and Iface with null record;
9196
9197          --    Obj1 : T;
9198          --    Obj2 : DT;
9199
9200          --  These membership tests are always true:
9201
9202          --    Obj1 in T'Class
9203          --    Obj2 in T'Class;
9204          --    Obj2 in Iface'Class;
9205
9206          --  We do not need to handle cases where the membership is illegal.
9207          --  For example:
9208
9209          --    Obj1 in DT'Class;     --  Compile time error
9210          --    Obj1 in Iface'Class;  --  Compile time error
9211
9212          if not Is_Class_Wide_Type (Left_Type)
9213            and then (Is_Ancestor (Etype (Right_Type), Left_Type)
9214                        or else (Is_Interface (Etype (Right_Type))
9215                                  and then Interface_Present_In_Ancestor
9216                                            (Typ   => Left_Type,
9217                                             Iface => Etype (Right_Type))))
9218          then
9219             return New_Reference_To (Standard_True, Loc);
9220          end if;
9221
9222          --  Ada 2005 (AI-251): Class-wide applied to interfaces
9223
9224          if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
9225
9226             --   Support to: "Iface_CW_Typ in Typ'Class"
9227
9228            or else Is_Interface (Left_Type)
9229          then
9230             --  Issue error if IW_Membership operation not available in a
9231             --  configurable run time setting.
9232
9233             if not RTE_Available (RE_IW_Membership) then
9234                Error_Msg_CRT
9235                  ("dynamic membership test on interface types", N);
9236                return Empty;
9237             end if;
9238
9239             return
9240               Make_Function_Call (Loc,
9241                  Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
9242                  Parameter_Associations => New_List (
9243                    Make_Attribute_Reference (Loc,
9244                      Prefix => Obj_Tag,
9245                      Attribute_Name => Name_Address),
9246                    New_Reference_To (
9247                      Node (First_Elmt
9248                             (Access_Disp_Table (Root_Type (Right_Type)))),
9249                      Loc)));
9250
9251          --  Ada 95: Normal case
9252
9253          else
9254             return
9255               Build_CW_Membership (Loc,
9256                 Obj_Tag_Node => Obj_Tag,
9257                 Typ_Tag_Node =>
9258                    New_Reference_To (
9259                      Node (First_Elmt
9260                             (Access_Disp_Table (Root_Type (Right_Type)))),
9261                      Loc));
9262          end if;
9263
9264       --  Right_Type is not a class-wide type
9265
9266       else
9267          --  No need to check the tag of the object if Right_Typ is abstract
9268
9269          if Is_Abstract_Type (Right_Type) then
9270             return New_Reference_To (Standard_False, Loc);
9271
9272          else
9273             return
9274               Make_Op_Eq (Loc,
9275                 Left_Opnd  => Obj_Tag,
9276                 Right_Opnd =>
9277                   New_Reference_To
9278                     (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
9279          end if;
9280       end if;
9281    end Tagged_Membership;
9282
9283    ------------------------------
9284    -- Unary_Op_Validity_Checks --
9285    ------------------------------
9286
9287    procedure Unary_Op_Validity_Checks (N : Node_Id) is
9288    begin
9289       if Validity_Checks_On and Validity_Check_Operands then
9290          Ensure_Valid (Right_Opnd (N));
9291       end if;
9292    end Unary_Op_Validity_Checks;
9293
9294 end Exp_Ch4;