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