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