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-2013, 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 Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Aggr; use Exp_Aggr;
  33 with Exp_Atag; use Exp_Atag;
  34 with Exp_Ch2;  use Exp_Ch2;
  35 with Exp_Ch3;  use Exp_Ch3;
  36 with Exp_Ch6;  use Exp_Ch6;
  37 with Exp_Ch7;  use Exp_Ch7;
  38 with Exp_Ch9;  use Exp_Ch9;
  39 with Exp_Disp; use Exp_Disp;
  40 with Exp_Fixd; use Exp_Fixd;
  41 with Exp_Intr; use Exp_Intr;
  42 with Exp_Pakd; use Exp_Pakd;
  43 with Exp_Tss;  use Exp_Tss;
  44 with Exp_Util; use Exp_Util;
  45 with Exp_VFpt; use Exp_VFpt;
  46 with Freeze;   use Freeze;
  47 with Inline;   use Inline;
  48 with Lib;      use Lib;
  49 with Namet;    use Namet;
  50 with Nlists;   use Nlists;
  51 with Nmake;    use Nmake;
  52 with Opt;      use Opt;
  53 with Par_SCO;  use Par_SCO;
  54 with Restrict; use Restrict;
  55 with Rident;   use Rident;
  56 with Rtsfind;  use Rtsfind;
  57 with Sem;      use Sem;
  58 with Sem_Aux;  use Sem_Aux;
  59 with Sem_Cat;  use Sem_Cat;
  60 with Sem_Ch3;  use Sem_Ch3;
  61 with Sem_Ch8;  use Sem_Ch8;
  62 with Sem_Ch13; use Sem_Ch13;
  63 with Sem_Eval; use Sem_Eval;
  64 with Sem_Res;  use Sem_Res;
  65 with Sem_Type; use Sem_Type;
  66 with Sem_Util; use Sem_Util;
  67 with Sem_Warn; use Sem_Warn;
  68 with Sinfo;    use Sinfo;
  69 with Snames;   use Snames;
  70 with Stand;    use Stand;
  71 with SCIL_LL;  use SCIL_LL;
  72 with Targparm; use Targparm;
  73 with Tbuild;   use Tbuild;
  74 with Ttypes;   use Ttypes;
  75 with Uintp;    use Uintp;
  76 with Urealp;   use Urealp;
  77 with Validsw;  use Validsw;
  78
  79 package body Exp_Ch4 is
  80
  81    -----------------------
  82    -- Local Subprograms --
  83    -----------------------
  84
  85    procedure Binary_Op_Validity_Checks (N : Node_Id);
  86    pragma Inline (Binary_Op_Validity_Checks);
  87    --  Performs validity checks for a binary operator
  88
  89    procedure Build_Boolean_Array_Proc_Call
  90      (N   : Node_Id;
  91       Op1 : Node_Id;
  92       Op2 : Node_Id);
  93    --  If a boolean array assignment can be done in place, build call to
  94    --  corresponding library procedure.
  95
  96    function Current_Anonymous_Master return Entity_Id;
  97    --  Return the entity of the heterogeneous finalization master belonging to
  98    --  the current unit (either function, package or procedure). This master
  99    --  services all anonymous access-to-controlled types. If the current unit
 100    --  does not have such master, create one.
 101
 102    procedure Displace_Allocator_Pointer (N : Node_Id);
 103    --  Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
 104    --  Expand_Allocator_Expression. Allocating class-wide interface objects
 105    --  this routine displaces the pointer to the allocated object to reference
 106    --  the component referencing the corresponding secondary dispatch table.
 107
 108    procedure Expand_Allocator_Expression (N : Node_Id);
 109    --  Subsidiary to Expand_N_Allocator, for the case when the expression
 110    --  is a qualified expression or an aggregate.
 111
 112    procedure Expand_Array_Comparison (N : Node_Id);
 113    --  This routine handles expansion of the comparison operators (N_Op_Lt,
 114    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
 115    --  code for these operators is similar, differing only in the details of
 116    --  the actual comparison call that is made. Special processing (call a
 117    --  run-time routine)
 118
 119    function Expand_Array_Equality
 120      (Nod    : Node_Id;
 121       Lhs    : Node_Id;
 122       Rhs    : Node_Id;
 123       Bodies : List_Id;
 124       Typ    : Entity_Id) return Node_Id;
 125    --  Expand an array equality into a call to a function implementing this
 126    --  equality, and a call to it. Loc is the location for the generated nodes.
 127    --  Lhs and Rhs are the array expressions to be compared. Bodies is a list
 128    --  on which to attach bodies of local functions that are created in the
 129    --  process. It is the responsibility of the caller to insert those bodies
 130    --  at the right place. Nod provides the Sloc value for the generated code.
 131    --  Normally the types used for the generated equality routine are taken
 132    --  from Lhs and Rhs. However, in some situations of generated code, the
 133    --  Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
 134    --  the type to be used for the formal parameters.
 135
 136    procedure Expand_Boolean_Operator (N : Node_Id);
 137    --  Common expansion processing for Boolean operators (And, Or, Xor) for the
 138    --  case of array type arguments.
 139
 140    procedure Expand_Short_Circuit_Operator (N : Node_Id);
 141    --  Common expansion processing for short-circuit boolean operators
 142
 143    procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
 144    --  Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
 145    --  where we allow comparison of "out of range" values.
 146
 147    function Expand_Composite_Equality
 148      (Nod    : Node_Id;
 149       Typ    : Entity_Id;
 150       Lhs    : Node_Id;
 151       Rhs    : Node_Id;
 152       Bodies : List_Id) return Node_Id;
 153    --  Local recursive function used to expand equality for nested composite
 154    --  types. Used by Expand_Record/Array_Equality, Bodies is a list on which
 155    --  to attach bodies of local functions that are created in the process.
 156    --  It is the responsibility of the caller to insert those bodies at the
 157    --  right place. Nod provides the Sloc value for generated code. Lhs and Rhs
 158    --  are the left and right sides for the comparison, and Typ is the type of
 159    --  the objects to compare.
 160
 161    procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
 162    --  Routine to expand concatenation of a sequence of two or more operands
 163    --  (in the list Operands) and replace node Cnode with the result of the
 164    --  concatenation. The operands can be of any appropriate type, and can
 165    --  include both arrays and singleton elements.
 166
 167    procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
 168    --  N is an N_In membership test mode, with the overflow check mode set to
 169    --  MINIMIZED or ELIMINATED, and the type of the left operand is a signed
 170    --  integer type. This is a case where top level processing is required to
 171    --  handle overflow checks in subtrees.
 172
 173    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
 174    --  N is a N_Op_Divide or N_Op_Multiply node whose result is universal
 175    --  fixed. We do not have such a type at runtime, so the purpose of this
 176    --  routine is to find the real type by looking up the tree. We also
 177    --  determine if the operation must be rounded.
 178
 179    function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
 180    --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
 181    --  discriminants if it has a constrained nominal type, unless the object
 182    --  is a component of an enclosing Unchecked_Union object that is subject
 183    --  to a per-object constraint and the enclosing object lacks inferable
 184    --  discriminants.
 185    --
 186    --  An expression of an Unchecked_Union type has inferable discriminants
 187    --  if it is either a name of an object with inferable discriminants or a
 188    --  qualified expression whose subtype mark denotes a constrained subtype.
 189
 190    procedure Insert_Dereference_Action (N : Node_Id);
 191    --  N is an expression whose type is an access. When the type of the
 192    --  associated storage pool is derived from Checked_Pool, generate a
 193    --  call to the 'Dereference' primitive operation.
 194
 195    function Make_Array_Comparison_Op
 196      (Typ : Entity_Id;
 197       Nod : Node_Id) return Node_Id;
 198    --  Comparisons between arrays are expanded in line. This function produces
 199    --  the body of the implementation of (a > b), where a and b are one-
 200    --  dimensional arrays of some discrete type. The original node is then
 201    --  expanded into the appropriate call to this function. Nod provides the
 202    --  Sloc value for the generated code.
 203
 204    function Make_Boolean_Array_Op
 205      (Typ : Entity_Id;
 206       N   : Node_Id) return Node_Id;
 207    --  Boolean operations on boolean arrays are expanded in line. This function
 208    --  produce the body for the node N, which is (a and b), (a or b), or (a xor
 209    --  b). It is used only the normal case and not the packed case. The type
 210    --  involved, Typ, is the Boolean array type, and the logical operations in
 211    --  the body are simple boolean operations. Note that Typ is always a
 212    --  constrained type (the caller has ensured this by using
 213    --  Convert_To_Actual_Subtype if necessary).
 214
 215    function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
 216    --  For signed arithmetic operations when the current overflow mode is
 217    --  MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
 218    --  as the first thing we do. We then return. We count on the recursive
 219    --  apparatus for overflow checks to call us back with an equivalent
 220    --  operation that is in CHECKED mode, avoiding a recursive entry into this
 221    --  routine, and that is when we will proceed with the expansion of the
 222    --  operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
 223    --  these optimizations without first making this check, since there may be
 224    --  operands further down the tree that are relying on the recursive calls
 225    --  triggered by the top level nodes to properly process overflow checking
 226    --  and remaining expansion on these nodes. Note that this call back may be
 227    --  skipped if the operation is done in Bignum mode but that's fine, since
 228    --  the Bignum call takes care of everything.
 229
 230    procedure Optimize_Length_Comparison (N : Node_Id);
 231    --  Given an expression, if it is of the form X'Length op N (or the other
 232    --  way round), where N is known at compile time to be 0 or 1, and X is a
 233    --  simple entity, and op is a comparison operator, optimizes it into a
 234    --  comparison of First and Last.
 235
 236    procedure Rewrite_Comparison (N : Node_Id);
 237    --  If N is the node for a comparison whose outcome can be determined at
 238    --  compile time, then the node N can be rewritten with True or False. If
 239    --  the outcome cannot be determined at compile time, the call has no
 240    --  effect. If N is a type conversion, then this processing is applied to
 241    --  its expression. If N is neither comparison nor a type conversion, the
 242    --  call has no effect.
 243
 244    procedure Tagged_Membership
 245      (N         : Node_Id;
 246       SCIL_Node : out Node_Id;
 247       Result    : out Node_Id);
 248    --  Construct the expression corresponding to the tagged membership test.
 249    --  Deals with a second operand being (or not) a class-wide type.
 250
 251    function Safe_In_Place_Array_Op
 252      (Lhs : Node_Id;
 253       Op1 : Node_Id;
 254       Op2 : Node_Id) return Boolean;
 255    --  In the context of an assignment, where the right-hand side is a boolean
 256    --  operation on arrays, check whether operation can be performed in place.
 257
 258    procedure Unary_Op_Validity_Checks (N : Node_Id);
 259    pragma Inline (Unary_Op_Validity_Checks);
 260    --  Performs validity checks for a unary operator
 261
 262    -------------------------------
 263    -- Binary_Op_Validity_Checks --
 264    -------------------------------
 265
 266    procedure Binary_Op_Validity_Checks (N : Node_Id) is
 267    begin
 268       if Validity_Checks_On and Validity_Check_Operands then
 269          Ensure_Valid (Left_Opnd (N));
 270          Ensure_Valid (Right_Opnd (N));
 271       end if;
 272    end Binary_Op_Validity_Checks;
 273
 274    ------------------------------------
 275    -- Build_Boolean_Array_Proc_Call --
 276    ------------------------------------
 277
 278    procedure Build_Boolean_Array_Proc_Call
 279      (N   : Node_Id;
 280       Op1 : Node_Id;
 281       Op2 : Node_Id)
 282    is
 283       Loc       : constant Source_Ptr := Sloc (N);
 284       Kind      : constant Node_Kind := Nkind (Expression (N));
 285       Target    : constant Node_Id   :=
 286                     Make_Attribute_Reference (Loc,
 287                       Prefix         => Name (N),
 288                       Attribute_Name => Name_Address);
 289
 290       Arg1      : Node_Id := Op1;
 291       Arg2      : Node_Id := Op2;
 292       Call_Node : Node_Id;
 293       Proc_Name : Entity_Id;
 294
 295    begin
 296       if Kind = N_Op_Not then
 297          if Nkind (Op1) in N_Binary_Op then
 298
 299             --  Use negated version of the binary operators
 300
 301             if Nkind (Op1) = N_Op_And then
 302                Proc_Name := RTE (RE_Vector_Nand);
 303
 304             elsif Nkind (Op1) = N_Op_Or then
 305                Proc_Name := RTE (RE_Vector_Nor);
 306
 307             else pragma Assert (Nkind (Op1) = N_Op_Xor);
 308                Proc_Name := RTE (RE_Vector_Xor);
 309             end if;
 310
 311             Call_Node :=
 312               Make_Procedure_Call_Statement (Loc,
 313                 Name => New_Occurrence_Of (Proc_Name, Loc),
 314
 315                 Parameter_Associations => New_List (
 316                   Target,
 317                   Make_Attribute_Reference (Loc,
 318                     Prefix => Left_Opnd (Op1),
 319                     Attribute_Name => Name_Address),
 320
 321                   Make_Attribute_Reference (Loc,
 322                     Prefix => Right_Opnd (Op1),
 323                     Attribute_Name => Name_Address),
 324
 325                   Make_Attribute_Reference (Loc,
 326                     Prefix => Left_Opnd (Op1),
 327                     Attribute_Name => Name_Length)));
 328
 329          else
 330             Proc_Name := RTE (RE_Vector_Not);
 331
 332             Call_Node :=
 333               Make_Procedure_Call_Statement (Loc,
 334                 Name => New_Occurrence_Of (Proc_Name, Loc),
 335                 Parameter_Associations => New_List (
 336                   Target,
 337
 338                   Make_Attribute_Reference (Loc,
 339                     Prefix => Op1,
 340                     Attribute_Name => Name_Address),
 341
 342                   Make_Attribute_Reference (Loc,
 343                     Prefix => Op1,
 344                      Attribute_Name => Name_Length)));
 345          end if;
 346
 347       else
 348          --  We use the following equivalences:
 349
 350          --   (not X) or  (not Y)  =  not (X and Y)  =  Nand (X, Y)
 351          --   (not X) and (not Y)  =  not (X or Y)   =  Nor  (X, Y)
 352          --   (not X) xor (not Y)  =  X xor Y
 353          --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)
 354
 355          if Nkind (Op1) = N_Op_Not then
 356             Arg1 := Right_Opnd (Op1);
 357             Arg2 := Right_Opnd (Op2);
 358
 359             if Kind = N_Op_And then
 360                Proc_Name := RTE (RE_Vector_Nor);
 361             elsif Kind = N_Op_Or then
 362                Proc_Name := RTE (RE_Vector_Nand);
 363             else
 364                Proc_Name := RTE (RE_Vector_Xor);
 365             end if;
 366
 367          else
 368             if Kind = N_Op_And then
 369                Proc_Name := RTE (RE_Vector_And);
 370             elsif Kind = N_Op_Or then
 371                Proc_Name := RTE (RE_Vector_Or);
 372             elsif Nkind (Op2) = N_Op_Not then
 373                Proc_Name := RTE (RE_Vector_Nxor);
 374                Arg2 := Right_Opnd (Op2);
 375             else
 376                Proc_Name := RTE (RE_Vector_Xor);
 377             end if;
 378          end if;
 379
 380          Call_Node :=
 381            Make_Procedure_Call_Statement (Loc,
 382              Name => New_Occurrence_Of (Proc_Name, Loc),
 383              Parameter_Associations => New_List (
 384                Target,
 385                Make_Attribute_Reference (Loc,
 386                  Prefix         => Arg1,
 387                  Attribute_Name => Name_Address),
 388                Make_Attribute_Reference (Loc,
 389                  Prefix         => Arg2,
 390                  Attribute_Name => Name_Address),
 391                Make_Attribute_Reference (Loc,
 392                  Prefix         => Arg1,
 393                  Attribute_Name => Name_Length)));
 394       end if;
 395
 396       Rewrite (N, Call_Node);
 397       Analyze (N);
 398
 399    exception
 400       when RE_Not_Available =>
 401          return;
 402    end Build_Boolean_Array_Proc_Call;
 403
 404    ------------------------------
 405    -- Current_Anonymous_Master --
 406    ------------------------------
 407
 408    function Current_Anonymous_Master return Entity_Id is
 409       Decls     : List_Id;
 410       Loc       : Source_Ptr;
 411       Subp_Body : Node_Id;
 412       Unit_Decl : Node_Id;
 413       Unit_Id   : Entity_Id;
 414
 415    begin
 416       Unit_Id := Cunit_Entity (Current_Sem_Unit);
 417
 418       --  Find the entity of the current unit
 419
 420       if Ekind (Unit_Id) = E_Subprogram_Body then
 421
 422          --  When processing subprogram bodies, the proper scope is always that
 423          --  of the spec.
 424
 425          Subp_Body := Unit_Id;
 426          while Present (Subp_Body)
 427            and then Nkind (Subp_Body) /= N_Subprogram_Body
 428          loop
 429             Subp_Body := Parent (Subp_Body);
 430          end loop;
 431
 432          Unit_Id := Corresponding_Spec (Subp_Body);
 433       end if;
 434
 435       Loc := Sloc (Unit_Id);
 436       Unit_Decl := Unit (Cunit (Current_Sem_Unit));
 437
 438       --  Find the declarations list of the current unit
 439
 440       if Nkind (Unit_Decl) = N_Package_Declaration then
 441          Unit_Decl := Specification (Unit_Decl);
 442          Decls := Visible_Declarations (Unit_Decl);
 443
 444          if No (Decls) then
 445             Decls := New_List (Make_Null_Statement (Loc));
 446             Set_Visible_Declarations (Unit_Decl, Decls);
 447
 448          elsif Is_Empty_List (Decls) then
 449             Append_To (Decls, Make_Null_Statement (Loc));
 450          end if;
 451
 452       else
 453          Decls := Declarations (Unit_Decl);
 454
 455          if No (Decls) then
 456             Decls := New_List (Make_Null_Statement (Loc));
 457             Set_Declarations (Unit_Decl, Decls);
 458
 459          elsif Is_Empty_List (Decls) then
 460             Append_To (Decls, Make_Null_Statement (Loc));
 461          end if;
 462       end if;
 463
 464       --  The current unit has an existing anonymous master, traverse its
 465       --  declarations and locate the entity.
 466
 467       if Has_Anonymous_Master (Unit_Id) then
 468          declare
 469             Decl       : Node_Id;
 470             Fin_Mas_Id : Entity_Id;
 471
 472          begin
 473             Decl := First (Decls);
 474             while Present (Decl) loop
 475
 476                --  Look for the first variable in the declarations whole type
 477                --  is Finalization_Master.
 478
 479                if Nkind (Decl) = N_Object_Declaration then
 480                   Fin_Mas_Id := Defining_Identifier (Decl);
 481
 482                   if Ekind (Fin_Mas_Id) = E_Variable
 483                     and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
 484                   then
 485                      return Fin_Mas_Id;
 486                   end if;
 487                end if;
 488
 489                Next (Decl);
 490             end loop;
 491
 492             --  The master was not found even though the unit was labeled as
 493             --  having one.
 494
 495             raise Program_Error;
 496          end;
 497
 498       --  Create a new anonymous master
 499
 500       else
 501          declare
 502             First_Decl : constant Node_Id := First (Decls);
 503             Action     : Node_Id;
 504             Fin_Mas_Id : Entity_Id;
 505
 506          begin
 507             --  Since the master and its associated initialization is inserted
 508             --  at top level, use the scope of the unit when analyzing.
 509
 510             Push_Scope (Unit_Id);
 511
 512             --  Create the finalization master
 513
 514             Fin_Mas_Id :=
 515               Make_Defining_Identifier (Loc,
 516                 Chars => New_External_Name (Chars (Unit_Id), "AM"));
 517
 518             --  Generate:
 519             --    <Fin_Mas_Id> : Finalization_Master;
 520
 521             Action :=
 522               Make_Object_Declaration (Loc,
 523                 Defining_Identifier => Fin_Mas_Id,
 524                 Object_Definition =>
 525                   New_Reference_To (RTE (RE_Finalization_Master), Loc));
 526
 527             Insert_Before_And_Analyze (First_Decl, Action);
 528
 529             --  Mark the unit to prevent the generation of multiple masters
 530
 531             Set_Has_Anonymous_Master (Unit_Id);
 532
 533             --  Do not set the base pool and mode of operation on .NET/JVM
 534             --  since those targets do not support pools and all VM masters
 535             --  are heterogeneous by default.
 536
 537             if VM_Target = No_VM then
 538
 539                --  Generate:
 540                --    Set_Base_Pool
 541                --      (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
 542
 543                Action :=
 544                  Make_Procedure_Call_Statement (Loc,
 545                    Name =>
 546                      New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
 547
 548                    Parameter_Associations => New_List (
 549                      New_Reference_To (Fin_Mas_Id, Loc),
 550                      Make_Attribute_Reference (Loc,
 551                        Prefix =>
 552                          New_Reference_To (RTE (RE_Global_Pool_Object), Loc),
 553                        Attribute_Name => Name_Unrestricted_Access)));
 554
 555                Insert_Before_And_Analyze (First_Decl, Action);
 556
 557                --  Generate:
 558                --    Set_Is_Heterogeneous (<Fin_Mas_Id>);
 559
 560                Action :=
 561                  Make_Procedure_Call_Statement (Loc,
 562                    Name =>
 563                      New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc),
 564                    Parameter_Associations => New_List (
 565                      New_Reference_To (Fin_Mas_Id, Loc)));
 566
 567                Insert_Before_And_Analyze (First_Decl, Action);
 568             end if;
 569
 570             --  Restore the original state of the scope stack
 571
 572             Pop_Scope;
 573
 574             return Fin_Mas_Id;
 575          end;
 576       end if;
 577    end Current_Anonymous_Master;
 578
 579    --------------------------------
 580    -- Displace_Allocator_Pointer --
 581    --------------------------------
 582
 583    procedure Displace_Allocator_Pointer (N : Node_Id) is
 584       Loc       : constant Source_Ptr := Sloc (N);
 585       Orig_Node : constant Node_Id := Original_Node (N);
 586       Dtyp      : Entity_Id;
 587       Etyp      : Entity_Id;
 588       PtrT      : Entity_Id;
 589
 590    begin
 591       --  Do nothing in case of VM targets: the virtual machine will handle
 592       --  interfaces directly.
 593
 594       if not Tagged_Type_Expansion then
 595          return;
 596       end if;
 597
 598       pragma Assert (Nkind (N) = N_Identifier
 599         and then Nkind (Orig_Node) = N_Allocator);
 600
 601       PtrT := Etype (Orig_Node);
 602       Dtyp := Available_View (Designated_Type (PtrT));
 603       Etyp := Etype (Expression (Orig_Node));
 604
 605       if Is_Class_Wide_Type (Dtyp) and then Is_Interface (Dtyp) then
 606
 607          --  If the type of the allocator expression is not an interface type
 608          --  we can generate code to reference the record component containing
 609          --  the pointer to the secondary dispatch table.
 610
 611          if not Is_Interface (Etyp) then
 612             declare
 613                Saved_Typ : constant Entity_Id := Etype (Orig_Node);
 614
 615             begin
 616                --  1) Get access to the allocated object
 617
 618                Rewrite (N,
 619                  Make_Explicit_Dereference (Loc, Relocate_Node (N)));
 620                Set_Etype (N, Etyp);
 621                Set_Analyzed (N);
 622
 623                --  2) Add the conversion to displace the pointer to reference
 624                --     the secondary dispatch table.
 625
 626                Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
 627                Analyze_And_Resolve (N, Dtyp);
 628
 629                --  3) The 'access to the secondary dispatch table will be used
 630                --     as the value returned by the allocator.
 631
 632                Rewrite (N,
 633                  Make_Attribute_Reference (Loc,
 634                    Prefix         => Relocate_Node (N),
 635                    Attribute_Name => Name_Access));
 636                Set_Etype (N, Saved_Typ);
 637                Set_Analyzed (N);
 638             end;
 639
 640          --  If the type of the allocator expression is an interface type we
 641          --  generate a run-time call to displace "this" to reference the
 642          --  component containing the pointer to the secondary dispatch table
 643          --  or else raise Constraint_Error if the actual object does not
 644          --  implement the target interface. This case corresponds to the
 645          --  following example:
 646
 647          --   function Op (Obj : Iface_1'Class) return access Iface_2'Class is
 648          --   begin
 649          --      return new Iface_2'Class'(Obj);
 650          --   end Op;
 651
 652          else
 653             Rewrite (N,
 654               Unchecked_Convert_To (PtrT,
 655                 Make_Function_Call (Loc,
 656                   Name => New_Reference_To (RTE (RE_Displace), Loc),
 657                   Parameter_Associations => New_List (
 658                     Unchecked_Convert_To (RTE (RE_Address),
 659                       Relocate_Node (N)),
 660
 661                     New_Occurrence_Of
 662                       (Elists.Node
 663                         (First_Elmt
 664                           (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
 665                        Loc)))));
 666             Analyze_And_Resolve (N, PtrT);
 667          end if;
 668       end if;
 669    end Displace_Allocator_Pointer;
 670
 671    ---------------------------------
 672    -- Expand_Allocator_Expression --
 673    ---------------------------------
 674
 675    procedure Expand_Allocator_Expression (N : Node_Id) is
 676       Loc    : constant Source_Ptr := Sloc (N);
 677       Exp    : constant Node_Id    := Expression (Expression (N));
 678       PtrT   : constant Entity_Id  := Etype (N);
 679       DesigT : constant Entity_Id  := Designated_Type (PtrT);
 680
 681       procedure Apply_Accessibility_Check
 682         (Ref            : Node_Id;
 683          Built_In_Place : Boolean := False);
 684       --  Ada 2005 (AI-344): For an allocator with a class-wide designated
 685       --  type, generate an accessibility check to verify that the level of the
 686       --  type of the created object is not deeper than the level of the access
 687       --  type. If the type of the qualified expression is class-wide, then
 688       --  always generate the check (except in the case where it is known to be
 689       --  unnecessary, see comment below). Otherwise, only generate the check
 690       --  if the level of the qualified expression type is statically deeper
 691       --  than the access type.
 692       --
 693       --  Although the static accessibility will generally have been performed
 694       --  as a legality check, it won't have been done in cases where the
 695       --  allocator appears in generic body, so a run-time check is needed in
 696       --  general. One special case is when the access type is declared in the
 697       --  same scope as the class-wide allocator, in which case the check can
 698       --  never fail, so it need not be generated.
 699       --
 700       --  As an open issue, there seem to be cases where the static level
 701       --  associated with the class-wide object's underlying type is not
 702       --  sufficient to perform the proper accessibility check, such as for
 703       --  allocators in nested subprograms or accept statements initialized by
 704       --  class-wide formals when the actual originates outside at a deeper
 705       --  static level. The nested subprogram case might require passing
 706       --  accessibility levels along with class-wide parameters, and the task
 707       --  case seems to be an actual gap in the language rules that needs to
 708       --  be fixed by the ARG. ???
 709
 710       -------------------------------
 711       -- Apply_Accessibility_Check --
 712       -------------------------------
 713
 714       procedure Apply_Accessibility_Check
 715         (Ref            : Node_Id;
 716          Built_In_Place : Boolean := False)
 717       is
 718          Pool_Id   : constant Entity_Id := Associated_Storage_Pool (PtrT);
 719          Cond      : Node_Id;
 720          Free_Stmt : Node_Id;
 721          Obj_Ref   : Node_Id;
 722          Stmts     : List_Id;
 723
 724       begin
 725          if Ada_Version >= Ada_2005
 726            and then Is_Class_Wide_Type (DesigT)
 727            and then not Scope_Suppress.Suppress (Accessibility_Check)
 728            and then
 729              (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
 730                or else
 731                  (Is_Class_Wide_Type (Etype (Exp))
 732                    and then Scope (PtrT) /= Current_Scope))
 733            and then (Tagged_Type_Expansion or else VM_Target /= No_VM)
 734          then
 735             --  If the allocator was built in place, Ref is already a reference
 736             --  to the access object initialized to the result of the allocator
 737             --  (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
 738             --  Remove_Side_Effects for cases where the build-in-place call may
 739             --  still be the prefix of the reference (to avoid generating
 740             --  duplicate calls). Otherwise, it is the entity associated with
 741             --  the object containing the address of the allocated object.
 742
 743             if Built_In_Place then
 744                Remove_Side_Effects (Ref);
 745                Obj_Ref := New_Copy (Ref);
 746             else
 747                Obj_Ref := New_Reference_To (Ref, Loc);
 748             end if;
 749
 750             --  Step 1: Create the object clean up code
 751
 752             Stmts := New_List;
 753
 754             --  Create an explicit free statement to clean up the allocated
 755             --  object in case the accessibility check fails. Generate:
 756
 757             --    Free (Obj_Ref);
 758
 759             Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
 760             Set_Storage_Pool (Free_Stmt, Pool_Id);
 761
 762             Append_To (Stmts, Free_Stmt);
 763
 764             --  Finalize the object (if applicable), but wrap the call inside
 765             --  a block to ensure that the object would still be deallocated in
 766             --  case the finalization fails. Generate:
 767
 768             --    begin
 769             --       [Deep_]Finalize (Obj_Ref.all);
 770             --    exception
 771             --       when others =>
 772             --          Free (Obj_Ref);
 773             --          raise;
 774             --    end;
 775
 776             if Needs_Finalization (DesigT) then
 777                Prepend_To (Stmts,
 778                  Make_Block_Statement (Loc,
 779                    Handled_Statement_Sequence =>
 780                      Make_Handled_Sequence_Of_Statements (Loc,
 781                        Statements => New_List (
 782                          Make_Final_Call (
 783                            Obj_Ref =>
 784                              Make_Explicit_Dereference (Loc,
 785                                Prefix => New_Copy (Obj_Ref)),
 786                            Typ     => DesigT)),
 787
 788                      Exception_Handlers => New_List (
 789                        Make_Exception_Handler (Loc,
 790                          Exception_Choices => New_List (
 791                            Make_Others_Choice (Loc)),
 792                          Statements        => New_List (
 793                            New_Copy_Tree (Free_Stmt),
 794                            Make_Raise_Statement (Loc)))))));
 795             end if;
 796
 797             --  Signal the accessibility failure through a Program_Error
 798
 799             Append_To (Stmts,
 800               Make_Raise_Program_Error (Loc,
 801                 Condition => New_Reference_To (Standard_True, Loc),
 802                 Reason    => PE_Accessibility_Check_Failed));
 803
 804             --  Step 2: Create the accessibility comparison
 805
 806             --  Generate:
 807             --    Ref'Tag
 808
 809             Obj_Ref :=
 810               Make_Attribute_Reference (Loc,
 811                 Prefix         => Obj_Ref,
 812                 Attribute_Name => Name_Tag);
 813
 814             --  For tagged types, determine the accessibility level by looking
 815             --  at the type specific data of the dispatch table. Generate:
 816
 817             --    Type_Specific_Data (Address (Ref'Tag)).Access_Level
 818
 819             if Tagged_Type_Expansion then
 820                Cond := Build_Get_Access_Level (Loc, Obj_Ref);
 821
 822             --  Use a runtime call to determine the accessibility level when
 823             --  compiling on virtual machine targets. Generate:
 824
 825             --    Get_Access_Level (Ref'Tag)
 826
 827             else
 828                Cond :=
 829                  Make_Function_Call (Loc,
 830                    Name                   =>
 831                      New_Reference_To (RTE (RE_Get_Access_Level), Loc),
 832                    Parameter_Associations => New_List (Obj_Ref));
 833             end if;
 834
 835             Cond :=
 836               Make_Op_Gt (Loc,
 837                 Left_Opnd  => Cond,
 838                 Right_Opnd =>
 839                   Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
 840
 841             --  Due to the complexity and side effects of the check, utilize an
 842             --  if statement instead of the regular Program_Error circuitry.
 843
 844             Insert_Action (N,
 845               Make_Implicit_If_Statement (N,
 846                 Condition       => Cond,
 847                 Then_Statements => Stmts));
 848          end if;
 849       end Apply_Accessibility_Check;
 850
 851       --  Local variables
 852
 853       Aggr_In_Place : constant Boolean   := Is_Delayed_Aggregate (Exp);
 854       Indic         : constant Node_Id   := Subtype_Mark (Expression (N));
 855       T             : constant Entity_Id := Entity (Indic);
 856       Node          : Node_Id;
 857       Tag_Assign    : Node_Id;
 858       Temp          : Entity_Id;
 859       Temp_Decl     : Node_Id;
 860
 861       TagT : Entity_Id := Empty;
 862       --  Type used as source for tag assignment
 863
 864       TagR : Node_Id := Empty;
 865       --  Target reference for tag assignment
 866
 867    --  Start of processing for Expand_Allocator_Expression
 868
 869    begin
 870       --  Handle call to C++ constructor
 871
 872       if Is_CPP_Constructor_Call (Exp) then
 873          Make_CPP_Constructor_Call_In_Allocator
 874            (Allocator => N,
 875             Function_Call => Exp);
 876          return;
 877       end if;
 878
 879       --  In the case of an Ada 2012 allocator whose initial value comes from a
 880       --  function call, pass "the accessibility level determined by the point
 881       --  of call" (AI05-0234) to the function. Conceptually, this belongs in
 882       --  Expand_Call but it couldn't be done there (because the Etype of the
 883       --  allocator wasn't set then) so we generate the parameter here. See
 884       --  the Boolean variable Defer in (a block within) Expand_Call.
 885
 886       if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
 887          declare
 888             Subp : Entity_Id;
 889
 890          begin
 891             if Nkind (Name (Exp)) = N_Explicit_Dereference then
 892                Subp := Designated_Type (Etype (Prefix (Name (Exp))));
 893             else
 894                Subp := Entity (Name (Exp));
 895             end if;
 896
 897             Subp := Ultimate_Alias (Subp);
 898
 899             if Present (Extra_Accessibility_Of_Result (Subp)) then
 900                Add_Extra_Actual_To_Call
 901                  (Subprogram_Call => Exp,
 902                   Extra_Formal    => Extra_Accessibility_Of_Result (Subp),
 903                   Extra_Actual    => Dynamic_Accessibility_Level (PtrT));
 904             end if;
 905          end;
 906       end if;
 907
 908       --  Case of tagged type or type requiring finalization
 909
 910       if Is_Tagged_Type (T) or else Needs_Finalization (T) then
 911
 912          --  Ada 2005 (AI-318-02): If the initialization expression is a call
 913          --  to a build-in-place function, then access to the allocated object
 914          --  must be passed to the function. Currently we limit such functions
 915          --  to those with constrained limited result subtypes, but eventually
 916          --  we plan to expand the allowed forms of functions that are treated
 917          --  as build-in-place.
 918
 919          if Ada_Version >= Ada_2005
 920            and then Is_Build_In_Place_Function_Call (Exp)
 921          then
 922             Make_Build_In_Place_Call_In_Allocator (N, Exp);
 923             Apply_Accessibility_Check (N, Built_In_Place => True);
 924             return;
 925          end if;
 926
 927          --  Actions inserted before:
 928          --    Temp : constant ptr_T := new T'(Expression);
 929          --    Temp._tag = T'tag;  --  when not class-wide
 930          --    [Deep_]Adjust (Temp.all);
 931
 932          --  We analyze by hand the new internal allocator to avoid any
 933          --  recursion and inappropriate call to Initialize
 934
 935          --  We don't want to remove side effects when the expression must be
 936          --  built in place. In the case of a build-in-place function call,
 937          --  that could lead to a duplication of the call, which was already
 938          --  substituted for the allocator.
 939
 940          if not Aggr_In_Place then
 941             Remove_Side_Effects (Exp);
 942          end if;
 943
 944          Temp := Make_Temporary (Loc, 'P', N);
 945
 946          --  For a class wide allocation generate the following code:
 947
 948          --    type Equiv_Record is record ... end record;
 949          --    implicit subtype CW is <Class_Wide_Subytpe>;
 950          --    temp : PtrT := new CW'(CW!(expr));
 951
 952          if Is_Class_Wide_Type (T) then
 953             Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
 954
 955             --  Ada 2005 (AI-251): If the expression is a class-wide interface
 956             --  object we generate code to move up "this" to reference the
 957             --  base of the object before allocating the new object.
 958
 959             --  Note that Exp'Address is recursively expanded into a call
 960             --  to Base_Address (Exp.Tag)
 961
 962             if Is_Class_Wide_Type (Etype (Exp))
 963               and then Is_Interface (Etype (Exp))
 964               and then Tagged_Type_Expansion
 965             then
 966                Set_Expression
 967                  (Expression (N),
 968                   Unchecked_Convert_To (Entity (Indic),
 969                     Make_Explicit_Dereference (Loc,
 970                       Unchecked_Convert_To (RTE (RE_Tag_Ptr),
 971                         Make_Attribute_Reference (Loc,
 972                           Prefix         => Exp,
 973                           Attribute_Name => Name_Address)))));
 974             else
 975                Set_Expression
 976                  (Expression (N),
 977                   Unchecked_Convert_To (Entity (Indic), Exp));
 978             end if;
 979
 980             Analyze_And_Resolve (Expression (N), Entity (Indic));
 981          end if;
 982
 983          --  Processing for allocators returning non-interface types
 984
 985          if not Is_Interface (Directly_Designated_Type (PtrT)) then
 986             if Aggr_In_Place then
 987                Temp_Decl :=
 988                  Make_Object_Declaration (Loc,
 989                    Defining_Identifier => Temp,
 990                    Object_Definition   => New_Reference_To (PtrT, Loc),
 991                    Expression          =>
 992                      Make_Allocator (Loc,
 993                        Expression =>
 994                          New_Reference_To (Etype (Exp), Loc)));
 995
 996                --  Copy the Comes_From_Source flag for the allocator we just
 997                --  built, since logically this allocator is a replacement of
 998                --  the original allocator node. This is for proper handling of
 999                --  restriction No_Implicit_Heap_Allocations.
1000
1001                Set_Comes_From_Source
1002                  (Expression (Temp_Decl), Comes_From_Source (N));
1003
1004                Set_No_Initialization (Expression (Temp_Decl));
1005                Insert_Action (N, Temp_Decl);
1006
1007                Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1008                Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1009
1010                --  Attach the object to the associated finalization master.
1011                --  This is done manually on .NET/JVM since those compilers do
1012                --  no support pools and can't benefit from internally generated
1013                --  Allocate / Deallocate procedures.
1014
1015                if VM_Target /= No_VM
1016                  and then Is_Controlled (DesigT)
1017                  and then Present (Finalization_Master (PtrT))
1018                then
1019                   Insert_Action (N,
1020                     Make_Attach_Call (
1021                       Obj_Ref =>
1022                         New_Reference_To (Temp, Loc),
1023                       Ptr_Typ => PtrT));
1024                end if;
1025
1026             else
1027                Node := Relocate_Node (N);
1028                Set_Analyzed (Node);
1029
1030                Temp_Decl :=
1031                  Make_Object_Declaration (Loc,
1032                    Defining_Identifier => Temp,
1033                    Constant_Present    => True,
1034                    Object_Definition   => New_Reference_To (PtrT, Loc),
1035                    Expression          => Node);
1036
1037                Insert_Action (N, Temp_Decl);
1038                Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1039
1040                --  Attach the object to the associated finalization master.
1041                --  This is done manually on .NET/JVM since those compilers do
1042                --  no support pools and can't benefit from internally generated
1043                --  Allocate / Deallocate procedures.
1044
1045                if VM_Target /= No_VM
1046                  and then Is_Controlled (DesigT)
1047                  and then Present (Finalization_Master (PtrT))
1048                then
1049                   Insert_Action (N,
1050                     Make_Attach_Call (
1051                       Obj_Ref =>
1052                         New_Reference_To (Temp, Loc),
1053                       Ptr_Typ => PtrT));
1054                end if;
1055             end if;
1056
1057          --  Ada 2005 (AI-251): Handle allocators whose designated type is an
1058          --  interface type. In this case we use the type of the qualified
1059          --  expression to allocate the object.
1060
1061          else
1062             declare
1063                Def_Id   : constant Entity_Id := Make_Temporary (Loc, 'T');
1064                New_Decl : Node_Id;
1065
1066             begin
1067                New_Decl :=
1068                  Make_Full_Type_Declaration (Loc,
1069                    Defining_Identifier => Def_Id,
1070                    Type_Definition =>
1071                      Make_Access_To_Object_Definition (Loc,
1072                        All_Present            => True,
1073                        Null_Exclusion_Present => False,
1074                        Constant_Present       =>
1075                          Is_Access_Constant (Etype (N)),
1076                        Subtype_Indication     =>
1077                          New_Reference_To (Etype (Exp), Loc)));
1078
1079                Insert_Action (N, New_Decl);
1080
1081                --  Inherit the allocation-related attributes from the original
1082                --  access type.
1083
1084                Set_Finalization_Master (Def_Id, Finalization_Master (PtrT));
1085
1086                Set_Associated_Storage_Pool (Def_Id,
1087                  Associated_Storage_Pool (PtrT));
1088
1089                --  Declare the object using the previous type declaration
1090
1091                if Aggr_In_Place then
1092                   Temp_Decl :=
1093                     Make_Object_Declaration (Loc,
1094                       Defining_Identifier => Temp,
1095                       Object_Definition   => New_Reference_To (Def_Id, Loc),
1096                       Expression          =>
1097                         Make_Allocator (Loc,
1098                           New_Reference_To (Etype (Exp), Loc)));
1099
1100                   --  Copy the Comes_From_Source flag for the allocator we just
1101                   --  built, since logically this allocator is a replacement of
1102                   --  the original allocator node. This is for proper handling
1103                   --  of restriction No_Implicit_Heap_Allocations.
1104
1105                   Set_Comes_From_Source
1106                     (Expression (Temp_Decl), Comes_From_Source (N));
1107
1108                   Set_No_Initialization (Expression (Temp_Decl));
1109                   Insert_Action (N, Temp_Decl);
1110
1111                   Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1112                   Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1113
1114                else
1115                   Node := Relocate_Node (N);
1116                   Set_Analyzed (Node);
1117
1118                   Temp_Decl :=
1119                     Make_Object_Declaration (Loc,
1120                       Defining_Identifier => Temp,
1121                       Constant_Present    => True,
1122                       Object_Definition   => New_Reference_To (Def_Id, Loc),
1123                       Expression          => Node);
1124
1125                   Insert_Action (N, Temp_Decl);
1126                   Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1127                end if;
1128
1129                --  Generate an additional object containing the address of the
1130                --  returned object. The type of this second object declaration
1131                --  is the correct type required for the common processing that
1132                --  is still performed by this subprogram. The displacement of
1133                --  this pointer to reference the component associated with the
1134                --  interface type will be done at the end of common processing.
1135
1136                New_Decl :=
1137                  Make_Object_Declaration (Loc,
1138                    Defining_Identifier => Make_Temporary (Loc, 'P'),
1139                    Object_Definition   => New_Reference_To (PtrT, Loc),
1140                    Expression          =>
1141                      Unchecked_Convert_To (PtrT,
1142                        New_Reference_To (Temp, Loc)));
1143
1144                Insert_Action (N, New_Decl);
1145
1146                Temp_Decl := New_Decl;
1147                Temp      := Defining_Identifier (New_Decl);
1148             end;
1149          end if;
1150
1151          Apply_Accessibility_Check (Temp);
1152
1153          --  Generate the tag assignment
1154
1155          --  Suppress the tag assignment when VM_Target because VM tags are
1156          --  represented implicitly in objects.
1157
1158          if not Tagged_Type_Expansion then
1159             null;
1160
1161          --  Ada 2005 (AI-251): Suppress the tag assignment with class-wide
1162          --  interface objects because in this case the tag does not change.
1163
1164          elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
1165             pragma Assert (Is_Class_Wide_Type
1166                             (Directly_Designated_Type (Etype (N))));
1167             null;
1168
1169          elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
1170             TagT := T;
1171             TagR := New_Reference_To (Temp, Loc);
1172
1173          elsif Is_Private_Type (T)
1174            and then Is_Tagged_Type (Underlying_Type (T))
1175          then
1176             TagT := Underlying_Type (T);
1177             TagR :=
1178               Unchecked_Convert_To (Underlying_Type (T),
1179                 Make_Explicit_Dereference (Loc,
1180                   Prefix => New_Reference_To (Temp, Loc)));
1181          end if;
1182
1183          if Present (TagT) then
1184             declare
1185                Full_T : constant Entity_Id := Underlying_Type (TagT);
1186             begin
1187                Tag_Assign :=
1188                  Make_Assignment_Statement (Loc,
1189                    Name =>
1190                      Make_Selected_Component (Loc,
1191                        Prefix => TagR,
1192                        Selector_Name =>
1193                          New_Reference_To (First_Tag_Component (Full_T), Loc)),
1194                    Expression =>
1195                      Unchecked_Convert_To (RTE (RE_Tag),
1196                        New_Reference_To
1197                          (Elists.Node
1198                            (First_Elmt (Access_Disp_Table (Full_T))), Loc)));
1199             end;
1200
1201             --  The previous assignment has to be done in any case
1202
1203             Set_Assignment_OK (Name (Tag_Assign));
1204             Insert_Action (N, Tag_Assign);
1205          end if;
1206
1207          if Needs_Finalization (DesigT) and then Needs_Finalization (T) then
1208
1209             --  Generate an Adjust call if the object will be moved. In Ada
1210             --  2005, the object may be inherently limited, in which case
1211             --  there is no Adjust procedure, and the object is built in
1212             --  place. In Ada 95, the object can be limited but not
1213             --  inherently limited if this allocator came from a return
1214             --  statement (we're allocating the result on the secondary
1215             --  stack). In that case, the object will be moved, so we _do_
1216             --  want to Adjust.
1217
1218             if not Aggr_In_Place
1219               and then not Is_Immutably_Limited_Type (T)
1220             then
1221                Insert_Action (N,
1222
1223                  --  An unchecked conversion is needed in the classwide case
1224                  --  because the designated type can be an ancestor of the
1225                  --  subtype mark of the allocator.
1226
1227                  Make_Adjust_Call
1228                    (Obj_Ref =>
1229                       Unchecked_Convert_To (T,
1230                         Make_Explicit_Dereference (Loc,
1231                           Prefix => New_Reference_To (Temp, Loc))),
1232                     Typ     => T));
1233             end if;
1234
1235             --  Generate:
1236             --    Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
1237
1238             --  Do not generate this call in the following cases:
1239
1240             --    * .NET/JVM - these targets do not support address arithmetic
1241             --    and unchecked conversion, key elements of Finalize_Address.
1242
1243             --    * Alfa mode - the call is useless and results in unwanted
1244             --    expansion.
1245
1246             --    * CodePeer mode - TSS primitive Finalize_Address is not
1247             --    created in this mode.
1248
1249             if VM_Target = No_VM
1250               and then not Alfa_Mode
1251               and then not CodePeer_Mode
1252               and then Present (Finalization_Master (PtrT))
1253               and then Present (Temp_Decl)
1254               and then Nkind (Expression (Temp_Decl)) = N_Allocator
1255             then
1256                Insert_Action (N,
1257                  Make_Set_Finalize_Address_Call
1258                    (Loc     => Loc,
1259                     Typ     => T,
1260                     Ptr_Typ => PtrT));
1261             end if;
1262          end if;
1263
1264          Rewrite (N, New_Reference_To (Temp, Loc));
1265          Analyze_And_Resolve (N, PtrT);
1266
1267          --  Ada 2005 (AI-251): Displace the pointer to reference the record
1268          --  component containing the secondary dispatch table of the interface
1269          --  type.
1270
1271          if Is_Interface (Directly_Designated_Type (PtrT)) then
1272             Displace_Allocator_Pointer (N);
1273          end if;
1274
1275       elsif Aggr_In_Place then
1276          Temp := Make_Temporary (Loc, 'P', N);
1277          Temp_Decl :=
1278            Make_Object_Declaration (Loc,
1279              Defining_Identifier => Temp,
1280              Object_Definition   => New_Reference_To (PtrT, Loc),
1281              Expression          =>
1282                Make_Allocator (Loc,
1283                  Expression => New_Reference_To (Etype (Exp), Loc)));
1284
1285          --  Copy the Comes_From_Source flag for the allocator we just built,
1286          --  since logically this allocator is a replacement of the original
1287          --  allocator node. This is for proper handling of restriction
1288          --  No_Implicit_Heap_Allocations.
1289
1290          Set_Comes_From_Source
1291            (Expression (Temp_Decl), Comes_From_Source (N));
1292
1293          Set_No_Initialization (Expression (Temp_Decl));
1294          Insert_Action (N, Temp_Decl);
1295
1296          Build_Allocate_Deallocate_Proc (Temp_Decl, True);
1297          Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
1298
1299          --  Attach the object to the associated finalization master. Thisis
1300          --  done manually on .NET/JVM since those compilers do no support
1301          --  pools and cannot benefit from internally generated Allocate and
1302          --  Deallocate procedures.
1303
1304          if VM_Target /= No_VM
1305            and then Is_Controlled (DesigT)
1306            and then Present (Finalization_Master (PtrT))
1307          then
1308             Insert_Action (N,
1309               Make_Attach_Call
1310                 (Obj_Ref => New_Reference_To (Temp, Loc),
1311                  Ptr_Typ => PtrT));
1312          end if;
1313
1314          Rewrite (N, New_Reference_To (Temp, Loc));
1315          Analyze_And_Resolve (N, PtrT);
1316
1317       elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then
1318          Install_Null_Excluding_Check (Exp);
1319
1320       elsif Is_Access_Type (DesigT)
1321         and then Nkind (Exp) = N_Allocator
1322         and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1323       then
1324          --  Apply constraint to designated subtype indication
1325
1326          Apply_Constraint_Check (Expression (Exp),
1327            Designated_Type (DesigT),
1328            No_Sliding => True);
1329
1330          if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1331
1332             --  Propagate constraint_error to enclosing allocator
1333
1334             Rewrite (Exp, New_Copy (Expression (Exp)));
1335          end if;
1336
1337       else
1338          Build_Allocate_Deallocate_Proc (N, True);
1339
1340          --  If we have:
1341          --    type A is access T1;
1342          --    X : A := new T2'(...);
1343          --  T1 and T2 can be different subtypes, and we might need to check
1344          --  both constraints. First check against the type of the qualified
1345          --  expression.
1346
1347          Apply_Constraint_Check (Exp, T, No_Sliding => True);
1348
1349          if Do_Range_Check (Exp) then
1350             Set_Do_Range_Check (Exp, False);
1351             Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1352          end if;
1353
1354          --  A check is also needed in cases where the designated subtype is
1355          --  constrained and differs from the subtype given in the qualified
1356          --  expression. Note that the check on the qualified expression does
1357          --  not allow sliding, but this check does (a relaxation from Ada 83).
1358
1359          if Is_Constrained (DesigT)
1360            and then not Subtypes_Statically_Match (T, DesigT)
1361          then
1362             Apply_Constraint_Check
1363               (Exp, DesigT, No_Sliding => False);
1364
1365             if Do_Range_Check (Exp) then
1366                Set_Do_Range_Check (Exp, False);
1367                Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1368             end if;
1369          end if;
1370
1371          --  For an access to unconstrained packed array, GIGI needs to see an
1372          --  expression with a constrained subtype in order to compute the
1373          --  proper size for the allocator.
1374
1375          if Is_Array_Type (T)
1376            and then not Is_Constrained (T)
1377            and then Is_Packed (T)
1378          then
1379             declare
1380                ConstrT      : constant Entity_Id := Make_Temporary (Loc, 'A');
1381                Internal_Exp : constant Node_Id   := Relocate_Node (Exp);
1382             begin
1383                Insert_Action (Exp,
1384                  Make_Subtype_Declaration (Loc,
1385                    Defining_Identifier => ConstrT,
1386                    Subtype_Indication  =>
1387                      Make_Subtype_From_Expr (Internal_Exp, T)));
1388                Freeze_Itype (ConstrT, Exp);
1389                Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1390             end;
1391          end if;
1392
1393          --  Ada 2005 (AI-318-02): If the initialization expression is a call
1394          --  to a build-in-place function, then access to the allocated object
1395          --  must be passed to the function. Currently we limit such functions
1396          --  to those with constrained limited result subtypes, but eventually
1397          --  we plan to expand the allowed forms of functions that are treated
1398          --  as build-in-place.
1399
1400          if Ada_Version >= Ada_2005
1401            and then Is_Build_In_Place_Function_Call (Exp)
1402          then
1403             Make_Build_In_Place_Call_In_Allocator (N, Exp);
1404          end if;
1405       end if;
1406
1407    exception
1408       when RE_Not_Available =>
1409          return;
1410    end Expand_Allocator_Expression;
1411
1412    -----------------------------
1413    -- Expand_Array_Comparison --
1414    -----------------------------
1415
1416    --  Expansion is only required in the case of array types. For the unpacked
1417    --  case, an appropriate runtime routine is called. For packed cases, and
1418    --  also in some other cases where a runtime routine cannot be called, the
1419    --  form of the expansion is:
1420
1421    --     [body for greater_nn; boolean_expression]
1422
1423    --  The body is built by Make_Array_Comparison_Op, and the form of the
1424    --  Boolean expression depends on the operator involved.
1425
1426    procedure Expand_Array_Comparison (N : Node_Id) is
1427       Loc  : constant Source_Ptr := Sloc (N);
1428       Op1  : Node_Id             := Left_Opnd (N);
1429       Op2  : Node_Id             := Right_Opnd (N);
1430       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
1431       Ctyp : constant Entity_Id  := Component_Type (Typ1);
1432
1433       Expr      : Node_Id;
1434       Func_Body : Node_Id;
1435       Func_Name : Entity_Id;
1436
1437       Comp : RE_Id;
1438
1439       Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1440       --  True for byte addressable target
1441
1442       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1443       --  Returns True if the length of the given operand is known to be less
1444       --  than 4. Returns False if this length is known to be four or greater
1445       --  or is not known at compile time.
1446
1447       ------------------------
1448       -- Length_Less_Than_4 --
1449       ------------------------
1450
1451       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1452          Otyp : constant Entity_Id := Etype (Opnd);
1453
1454       begin
1455          if Ekind (Otyp) = E_String_Literal_Subtype then
1456             return String_Literal_Length (Otyp) < 4;
1457
1458          else
1459             declare
1460                Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1461                Lo   : constant Node_Id   := Type_Low_Bound (Ityp);
1462                Hi   : constant Node_Id   := Type_High_Bound (Ityp);
1463                Lov  : Uint;
1464                Hiv  : Uint;
1465
1466             begin
1467                if Compile_Time_Known_Value (Lo) then
1468                   Lov := Expr_Value (Lo);
1469                else
1470                   return False;
1471                end if;
1472
1473                if Compile_Time_Known_Value (Hi) then
1474                   Hiv := Expr_Value (Hi);
1475                else
1476                   return False;
1477                end if;
1478
1479                return Hiv < Lov + 3;
1480             end;
1481          end if;
1482       end Length_Less_Than_4;
1483
1484    --  Start of processing for Expand_Array_Comparison
1485
1486    begin
1487       --  Deal first with unpacked case, where we can call a runtime routine
1488       --  except that we avoid this for targets for which are not addressable
1489       --  by bytes, and for the JVM/CIL, since they do not support direct
1490       --  addressing of array components.
1491
1492       if not Is_Bit_Packed_Array (Typ1)
1493         and then Byte_Addressable
1494         and then VM_Target = No_VM
1495       then
1496          --  The call we generate is:
1497
1498          --  Compare_Array_xn[_Unaligned]
1499          --    (left'address, right'address, left'length, right'length) <op> 0
1500
1501          --  x = U for unsigned, S for signed
1502          --  n = 8,16,32,64 for component size
1503          --  Add _Unaligned if length < 4 and component size is 8.
1504          --  <op> is the standard comparison operator
1505
1506          if Component_Size (Typ1) = 8 then
1507             if Length_Less_Than_4 (Op1)
1508                  or else
1509                Length_Less_Than_4 (Op2)
1510             then
1511                if Is_Unsigned_Type (Ctyp) then
1512                   Comp := RE_Compare_Array_U8_Unaligned;
1513                else
1514                   Comp := RE_Compare_Array_S8_Unaligned;
1515                end if;
1516
1517             else
1518                if Is_Unsigned_Type (Ctyp) then
1519                   Comp := RE_Compare_Array_U8;
1520                else
1521                   Comp := RE_Compare_Array_S8;
1522                end if;
1523             end if;
1524
1525          elsif Component_Size (Typ1) = 16 then
1526             if Is_Unsigned_Type (Ctyp) then
1527                Comp := RE_Compare_Array_U16;
1528             else
1529                Comp := RE_Compare_Array_S16;
1530             end if;
1531
1532          elsif Component_Size (Typ1) = 32 then
1533             if Is_Unsigned_Type (Ctyp) then
1534                Comp := RE_Compare_Array_U32;
1535             else
1536                Comp := RE_Compare_Array_S32;
1537             end if;
1538
1539          else pragma Assert (Component_Size (Typ1) = 64);
1540             if Is_Unsigned_Type (Ctyp) then
1541                Comp := RE_Compare_Array_U64;
1542             else
1543                Comp := RE_Compare_Array_S64;
1544             end if;
1545          end if;
1546
1547          Remove_Side_Effects (Op1, Name_Req => True);
1548          Remove_Side_Effects (Op2, Name_Req => True);
1549
1550          Rewrite (Op1,
1551            Make_Function_Call (Sloc (Op1),
1552              Name => New_Occurrence_Of (RTE (Comp), Loc),
1553
1554              Parameter_Associations => New_List (
1555                Make_Attribute_Reference (Loc,
1556                  Prefix         => Relocate_Node (Op1),
1557                  Attribute_Name => Name_Address),
1558
1559                Make_Attribute_Reference (Loc,
1560                  Prefix         => Relocate_Node (Op2),
1561                  Attribute_Name => Name_Address),
1562
1563                Make_Attribute_Reference (Loc,
1564                  Prefix         => Relocate_Node (Op1),
1565                  Attribute_Name => Name_Length),
1566
1567                Make_Attribute_Reference (Loc,
1568                  Prefix         => Relocate_Node (Op2),
1569                  Attribute_Name => Name_Length))));
1570
1571          Rewrite (Op2,
1572            Make_Integer_Literal (Sloc (Op2),
1573              Intval => Uint_0));
1574
1575          Analyze_And_Resolve (Op1, Standard_Integer);
1576          Analyze_And_Resolve (Op2, Standard_Integer);
1577          return;
1578       end if;
1579
1580       --  Cases where we cannot make runtime call
1581
1582       --  For (a <= b) we convert to not (a > b)
1583
1584       if Chars (N) = Name_Op_Le then
1585          Rewrite (N,
1586            Make_Op_Not (Loc,
1587              Right_Opnd =>
1588                 Make_Op_Gt (Loc,
1589                  Left_Opnd  => Op1,
1590                  Right_Opnd => Op2)));
1591          Analyze_And_Resolve (N, Standard_Boolean);
1592          return;
1593
1594       --  For < the Boolean expression is
1595       --    greater__nn (op2, op1)
1596
1597       elsif Chars (N) = Name_Op_Lt then
1598          Func_Body := Make_Array_Comparison_Op (Typ1, N);
1599
1600          --  Switch operands
1601
1602          Op1 := Right_Opnd (N);
1603          Op2 := Left_Opnd  (N);
1604
1605       --  For (a >= b) we convert to not (a < b)
1606
1607       elsif Chars (N) = Name_Op_Ge then
1608          Rewrite (N,
1609            Make_Op_Not (Loc,
1610              Right_Opnd =>
1611                Make_Op_Lt (Loc,
1612                  Left_Opnd  => Op1,
1613                  Right_Opnd => Op2)));
1614          Analyze_And_Resolve (N, Standard_Boolean);
1615          return;
1616
1617       --  For > the Boolean expression is
1618       --    greater__nn (op1, op2)
1619
1620       else
1621          pragma Assert (Chars (N) = Name_Op_Gt);
1622          Func_Body := Make_Array_Comparison_Op (Typ1, N);
1623       end if;
1624
1625       Func_Name := Defining_Unit_Name (Specification (Func_Body));
1626       Expr :=
1627         Make_Function_Call (Loc,
1628           Name => New_Reference_To (Func_Name, Loc),
1629           Parameter_Associations => New_List (Op1, Op2));
1630
1631       Insert_Action (N, Func_Body);
1632       Rewrite (N, Expr);
1633       Analyze_And_Resolve (N, Standard_Boolean);
1634
1635    exception
1636       when RE_Not_Available =>
1637          return;
1638    end Expand_Array_Comparison;
1639
1640    ---------------------------
1641    -- Expand_Array_Equality --
1642    ---------------------------
1643
1644    --  Expand an equality function for multi-dimensional arrays. Here is an
1645    --  example of such a function for Nb_Dimension = 2
1646
1647    --  function Enn (A : atyp; B : btyp) return boolean is
1648    --  begin
1649    --     if (A'length (1) = 0 or else A'length (2) = 0)
1650    --          and then
1651    --        (B'length (1) = 0 or else B'length (2) = 0)
1652    --     then
1653    --        return True;    -- RM 4.5.2(22)
1654    --     end if;
1655
1656    --     if A'length (1) /= B'length (1)
1657    --               or else
1658    --           A'length (2) /= B'length (2)
1659    --     then
1660    --        return False;   -- RM 4.5.2(23)
1661    --     end if;
1662
1663    --     declare
1664    --        A1 : Index_T1 := A'first (1);
1665    --        B1 : Index_T1 := B'first (1);
1666    --     begin
1667    --        loop
1668    --           declare
1669    --              A2 : Index_T2 := A'first (2);
1670    --              B2 : Index_T2 := B'first (2);
1671    --           begin
1672    --              loop
1673    --                 if A (A1, A2) /= B (B1, B2) then
1674    --                    return False;
1675    --                 end if;
1676
1677    --                 exit when A2 = A'last (2);
1678    --                 A2 := Index_T2'succ (A2);
1679    --                 B2 := Index_T2'succ (B2);
1680    --              end loop;
1681    --           end;
1682
1683    --           exit when A1 = A'last (1);
1684    --           A1 := Index_T1'succ (A1);
1685    --           B1 := Index_T1'succ (B1);
1686    --        end loop;
1687    --     end;
1688
1689    --     return true;
1690    --  end Enn;
1691
1692    --  Note on the formal types used (atyp and btyp). If either of the arrays
1693    --  is of a private type, we use the underlying type, and do an unchecked
1694    --  conversion of the actual. If either of the arrays has a bound depending
1695    --  on a discriminant, then we use the base type since otherwise we have an
1696    --  escaped discriminant in the function.
1697
1698    --  If both arrays are constrained and have the same bounds, we can generate
1699    --  a loop with an explicit iteration scheme using a 'Range attribute over
1700    --  the first array.
1701
1702    function Expand_Array_Equality
1703      (Nod    : Node_Id;
1704       Lhs    : Node_Id;
1705       Rhs    : Node_Id;
1706       Bodies : List_Id;
1707       Typ    : Entity_Id) return Node_Id
1708    is
1709       Loc         : constant Source_Ptr := Sloc (Nod);
1710       Decls       : constant List_Id    := New_List;
1711       Index_List1 : constant List_Id    := New_List;
1712       Index_List2 : constant List_Id    := New_List;
1713
1714       Actuals   : List_Id;
1715       Formals   : List_Id;
1716       Func_Name : Entity_Id;
1717       Func_Body : Node_Id;
1718
1719       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1720       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1721
1722       Ltyp : Entity_Id;
1723       Rtyp : Entity_Id;
1724       --  The parameter types to be used for the formals
1725
1726       function Arr_Attr
1727         (Arr : Entity_Id;
1728          Nam : Name_Id;
1729          Num : Int) return Node_Id;
1730       --  This builds the attribute reference Arr'Nam (Expr)
1731
1732       function Component_Equality (Typ : Entity_Id) return Node_Id;
1733       --  Create one statement to compare corresponding components, designated
1734       --  by a full set of indexes.
1735
1736       function Get_Arg_Type (N : Node_Id) return Entity_Id;
1737       --  Given one of the arguments, computes the appropriate type to be used
1738       --  for that argument in the corresponding function formal
1739
1740       function Handle_One_Dimension
1741         (N     : Int;
1742          Index : Node_Id) return Node_Id;
1743       --  This procedure returns the following code
1744       --
1745       --    declare
1746       --       Bn : Index_T := B'First (N);
1747       --    begin
1748       --       loop
1749       --          xxx
1750       --          exit when An = A'Last (N);
1751       --          An := Index_T'Succ (An)
1752       --          Bn := Index_T'Succ (Bn)
1753       --       end loop;
1754       --    end;
1755       --
1756       --  If both indexes are constrained and identical, the procedure
1757       --  returns a simpler loop:
1758       --
1759       --      for An in A'Range (N) loop
1760       --         xxx
1761       --      end loop
1762       --
1763       --  N is the dimension for which we are generating a loop. Index is the
1764       --  N'th index node, whose Etype is Index_Type_n in the above code. The
1765       --  xxx statement is either the loop or declare for the next dimension
1766       --  or if this is the last dimension the comparison of corresponding
1767       --  components of the arrays.
1768       --
1769       --  The actual way the code works is to return the comparison of
1770       --  corresponding components for the N+1 call. That's neater!
1771
1772       function Test_Empty_Arrays return Node_Id;
1773       --  This function constructs the test for both arrays being empty
1774       --    (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1775       --      and then
1776       --    (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1777
1778       function Test_Lengths_Correspond return Node_Id;
1779       --  This function constructs the test for arrays having different lengths
1780       --  in at least one index position, in which case the resulting code is:
1781
1782       --     A'length (1) /= B'length (1)
1783       --       or else
1784       --     A'length (2) /= B'length (2)
1785       --       or else
1786       --       ...
1787
1788       --------------
1789       -- Arr_Attr --
1790       --------------
1791
1792       function Arr_Attr
1793         (Arr : Entity_Id;
1794          Nam : Name_Id;
1795          Num : Int) return Node_Id
1796       is
1797       begin
1798          return
1799            Make_Attribute_Reference (Loc,
1800             Attribute_Name => Nam,
1801             Prefix => New_Reference_To (Arr, Loc),
1802             Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1803       end Arr_Attr;
1804
1805       ------------------------
1806       -- Component_Equality --
1807       ------------------------
1808
1809       function Component_Equality (Typ : Entity_Id) return Node_Id is
1810          Test : Node_Id;
1811          L, R : Node_Id;
1812
1813       begin
1814          --  if a(i1...) /= b(j1...) then return false; end if;
1815
1816          L :=
1817            Make_Indexed_Component (Loc,
1818              Prefix      => Make_Identifier (Loc, Chars (A)),
1819              Expressions => Index_List1);
1820
1821          R :=
1822            Make_Indexed_Component (Loc,
1823              Prefix      => Make_Identifier (Loc, Chars (B)),
1824              Expressions => Index_List2);
1825
1826          Test := Expand_Composite_Equality
1827                    (Nod, Component_Type (Typ), L, R, Decls);
1828
1829          --  If some (sub)component is an unchecked_union, the whole operation
1830          --  will raise program error.
1831
1832          if Nkind (Test) = N_Raise_Program_Error then
1833
1834             --  This node is going to be inserted at a location where a
1835             --  statement is expected: clear its Etype so analysis will set
1836             --  it to the expected Standard_Void_Type.
1837
1838             Set_Etype (Test, Empty);
1839             return Test;
1840
1841          else
1842             return
1843               Make_Implicit_If_Statement (Nod,
1844                 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1845                 Then_Statements => New_List (
1846                   Make_Simple_Return_Statement (Loc,
1847                     Expression => New_Occurrence_Of (Standard_False, Loc))));
1848          end if;
1849       end Component_Equality;
1850
1851       ------------------
1852       -- Get_Arg_Type --
1853       ------------------
1854
1855       function Get_Arg_Type (N : Node_Id) return Entity_Id is
1856          T : Entity_Id;
1857          X : Node_Id;
1858
1859       begin
1860          T := Etype (N);
1861
1862          if No (T) then
1863             return Typ;
1864
1865          else
1866             T := Underlying_Type (T);
1867
1868             X := First_Index (T);
1869             while Present (X) loop
1870                if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1871                  or else
1872                    Denotes_Discriminant (Type_High_Bound (Etype (X)))
1873                then
1874                   T := Base_Type (T);
1875                   exit;
1876                end if;
1877
1878                Next_Index (X);
1879             end loop;
1880
1881             return T;
1882          end if;
1883       end Get_Arg_Type;
1884
1885       --------------------------
1886       -- Handle_One_Dimension --
1887       ---------------------------
1888
1889       function Handle_One_Dimension
1890         (N     : Int;
1891          Index : Node_Id) return Node_Id
1892       is
1893          Need_Separate_Indexes : constant Boolean :=
1894                                    Ltyp /= Rtyp
1895                                      or else not Is_Constrained (Ltyp);
1896          --  If the index types are identical, and we are working with
1897          --  constrained types, then we can use the same index for both
1898          --  of the arrays.
1899
1900          An : constant Entity_Id := Make_Temporary (Loc, 'A');
1901
1902          Bn       : Entity_Id;
1903          Index_T  : Entity_Id;
1904          Stm_List : List_Id;
1905          Loop_Stm : Node_Id;
1906
1907       begin
1908          if N > Number_Dimensions (Ltyp) then
1909             return Component_Equality (Ltyp);
1910          end if;
1911
1912          --  Case where we generate a loop
1913
1914          Index_T := Base_Type (Etype (Index));
1915
1916          if Need_Separate_Indexes then
1917             Bn := Make_Temporary (Loc, 'B');
1918          else
1919             Bn := An;
1920          end if;
1921
1922          Append (New_Reference_To (An, Loc), Index_List1);
1923          Append (New_Reference_To (Bn, Loc), Index_List2);
1924
1925          Stm_List := New_List (
1926            Handle_One_Dimension (N + 1, Next_Index (Index)));
1927
1928          if Need_Separate_Indexes then
1929
1930             --  Generate guard for loop, followed by increments of indexes
1931
1932             Append_To (Stm_List,
1933                Make_Exit_Statement (Loc,
1934                  Condition =>
1935                    Make_Op_Eq (Loc,
1936                       Left_Opnd => New_Reference_To (An, Loc),
1937                       Right_Opnd => Arr_Attr (A, Name_Last, N))));
1938
1939             Append_To (Stm_List,
1940               Make_Assignment_Statement (Loc,
1941                 Name       => New_Reference_To (An, Loc),
1942                 Expression =>
1943                   Make_Attribute_Reference (Loc,
1944                     Prefix         => New_Reference_To (Index_T, Loc),
1945                     Attribute_Name => Name_Succ,
1946                     Expressions    => New_List (New_Reference_To (An, Loc)))));
1947
1948             Append_To (Stm_List,
1949               Make_Assignment_Statement (Loc,
1950                 Name       => New_Reference_To (Bn, Loc),
1951                 Expression =>
1952                   Make_Attribute_Reference (Loc,
1953                     Prefix         => New_Reference_To (Index_T, Loc),
1954                     Attribute_Name => Name_Succ,
1955                     Expressions    => New_List (New_Reference_To (Bn, Loc)))));
1956          end if;
1957
1958          --  If separate indexes, we need a declare block for An and Bn, and a
1959          --  loop without an iteration scheme.
1960
1961          if Need_Separate_Indexes then
1962             Loop_Stm :=
1963               Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1964
1965             return
1966               Make_Block_Statement (Loc,
1967                 Declarations => New_List (
1968                   Make_Object_Declaration (Loc,
1969                     Defining_Identifier => An,
1970                     Object_Definition   => New_Reference_To (Index_T, Loc),
1971                     Expression          => Arr_Attr (A, Name_First, N)),
1972
1973                   Make_Object_Declaration (Loc,
1974                     Defining_Identifier => Bn,
1975                     Object_Definition   => New_Reference_To (Index_T, Loc),
1976                     Expression          => Arr_Attr (B, Name_First, N))),
1977
1978                 Handled_Statement_Sequence =>
1979                   Make_Handled_Sequence_Of_Statements (Loc,
1980                     Statements => New_List (Loop_Stm)));
1981
1982          --  If no separate indexes, return loop statement with explicit
1983          --  iteration scheme on its own
1984
1985          else
1986             Loop_Stm :=
1987               Make_Implicit_Loop_Statement (Nod,
1988                 Statements       => Stm_List,
1989                 Iteration_Scheme =>
1990                   Make_Iteration_Scheme (Loc,
1991                     Loop_Parameter_Specification =>
1992                       Make_Loop_Parameter_Specification (Loc,
1993                         Defining_Identifier         => An,
1994                         Discrete_Subtype_Definition =>
1995                           Arr_Attr (A, Name_Range, N))));
1996             return Loop_Stm;
1997          end if;
1998       end Handle_One_Dimension;
1999
2000       -----------------------
2001       -- Test_Empty_Arrays --
2002       -----------------------
2003
2004       function Test_Empty_Arrays return Node_Id is
2005          Alist : Node_Id;
2006          Blist : Node_Id;
2007
2008          Atest : Node_Id;
2009          Btest : Node_Id;
2010
2011       begin
2012          Alist := Empty;
2013          Blist := Empty;
2014          for J in 1 .. Number_Dimensions (Ltyp) loop
2015             Atest :=
2016               Make_Op_Eq (Loc,
2017                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
2018                 Right_Opnd => Make_Integer_Literal (Loc, 0));
2019
2020             Btest :=
2021               Make_Op_Eq (Loc,
2022                 Left_Opnd  => Arr_Attr (B, Name_Length, J),
2023                 Right_Opnd => Make_Integer_Literal (Loc, 0));
2024
2025             if No (Alist) then
2026                Alist := Atest;
2027                Blist := Btest;
2028
2029             else
2030                Alist :=
2031                  Make_Or_Else (Loc,
2032                    Left_Opnd  => Relocate_Node (Alist),
2033                    Right_Opnd => Atest);
2034
2035                Blist :=
2036                  Make_Or_Else (Loc,
2037                    Left_Opnd  => Relocate_Node (Blist),
2038                    Right_Opnd => Btest);
2039             end if;
2040          end loop;
2041
2042          return
2043            Make_And_Then (Loc,
2044              Left_Opnd  => Alist,
2045              Right_Opnd => Blist);
2046       end Test_Empty_Arrays;
2047
2048       -----------------------------
2049       -- Test_Lengths_Correspond --
2050       -----------------------------
2051
2052       function Test_Lengths_Correspond return Node_Id is
2053          Result : Node_Id;
2054          Rtest  : Node_Id;
2055
2056       begin
2057          Result := Empty;
2058          for J in 1 .. Number_Dimensions (Ltyp) loop
2059             Rtest :=
2060               Make_Op_Ne (Loc,
2061                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
2062                 Right_Opnd => Arr_Attr (B, Name_Length, J));
2063
2064             if No (Result) then
2065                Result := Rtest;
2066             else
2067                Result :=
2068                  Make_Or_Else (Loc,
2069                    Left_Opnd  => Relocate_Node (Result),
2070                    Right_Opnd => Rtest);
2071             end if;
2072          end loop;
2073
2074          return Result;
2075       end Test_Lengths_Correspond;
2076
2077    --  Start of processing for Expand_Array_Equality
2078
2079    begin
2080       Ltyp := Get_Arg_Type (Lhs);
2081       Rtyp := Get_Arg_Type (Rhs);
2082
2083       --  For now, if the argument types are not the same, go to the base type,
2084       --  since the code assumes that the formals have the same type. This is
2085       --  fixable in future ???
2086
2087       if Ltyp /= Rtyp then
2088          Ltyp := Base_Type (Ltyp);
2089          Rtyp := Base_Type (Rtyp);
2090          pragma Assert (Ltyp = Rtyp);
2091       end if;
2092
2093       --  Build list of formals for function
2094
2095       Formals := New_List (
2096         Make_Parameter_Specification (Loc,
2097           Defining_Identifier => A,
2098           Parameter_Type      => New_Reference_To (Ltyp, Loc)),
2099
2100         Make_Parameter_Specification (Loc,
2101           Defining_Identifier => B,
2102           Parameter_Type      => New_Reference_To (Rtyp, Loc)));
2103
2104       Func_Name := Make_Temporary (Loc, 'E');
2105
2106       --  Build statement sequence for function
2107
2108       Func_Body :=
2109         Make_Subprogram_Body (Loc,
2110           Specification =>
2111             Make_Function_Specification (Loc,
2112               Defining_Unit_Name       => Func_Name,
2113               Parameter_Specifications => Formals,
2114               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
2115
2116           Declarations =>  Decls,
2117
2118           Handled_Statement_Sequence =>
2119             Make_Handled_Sequence_Of_Statements (Loc,
2120               Statements => New_List (
2121
2122                 Make_Implicit_If_Statement (Nod,
2123                   Condition => Test_Empty_Arrays,
2124                   Then_Statements => New_List (
2125                     Make_Simple_Return_Statement (Loc,
2126                       Expression =>
2127                         New_Occurrence_Of (Standard_True, Loc)))),
2128
2129                 Make_Implicit_If_Statement (Nod,
2130                   Condition => Test_Lengths_Correspond,
2131                   Then_Statements => New_List (
2132                     Make_Simple_Return_Statement (Loc,
2133                       Expression =>
2134                         New_Occurrence_Of (Standard_False, Loc)))),
2135
2136                 Handle_One_Dimension (1, First_Index (Ltyp)),
2137
2138                 Make_Simple_Return_Statement (Loc,
2139                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
2140
2141          Set_Has_Completion (Func_Name, True);
2142          Set_Is_Inlined (Func_Name);
2143
2144          --  If the array type is distinct from the type of the arguments, it
2145          --  is the full view of a private type. Apply an unchecked conversion
2146          --  to insure that analysis of the call succeeds.
2147
2148          declare
2149             L, R : Node_Id;
2150
2151          begin
2152             L := Lhs;
2153             R := Rhs;
2154
2155             if No (Etype (Lhs))
2156               or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
2157             then
2158                L := OK_Convert_To (Ltyp, Lhs);
2159             end if;
2160
2161             if No (Etype (Rhs))
2162               or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
2163             then
2164                R := OK_Convert_To (Rtyp, Rhs);
2165             end if;
2166
2167             Actuals := New_List (L, R);
2168          end;
2169
2170          Append_To (Bodies, Func_Body);
2171
2172          return
2173            Make_Function_Call (Loc,
2174              Name                   => New_Reference_To (Func_Name, Loc),
2175              Parameter_Associations => Actuals);
2176    end Expand_Array_Equality;
2177
2178    -----------------------------
2179    -- Expand_Boolean_Operator --
2180    -----------------------------
2181
2182    --  Note that we first get the actual subtypes of the operands, since we
2183    --  always want to deal with types that have bounds.
2184
2185    procedure Expand_Boolean_Operator (N : Node_Id) is
2186       Typ : constant Entity_Id  := Etype (N);
2187
2188    begin
2189       --  Special case of bit packed array where both operands are known to be
2190       --  properly aligned. In this case we use an efficient run time routine
2191       --  to carry out the operation (see System.Bit_Ops).
2192
2193       if Is_Bit_Packed_Array (Typ)
2194         and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
2195         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
2196       then
2197          Expand_Packed_Boolean_Operator (N);
2198          return;
2199       end if;
2200
2201       --  For the normal non-packed case, the general expansion is to build
2202       --  function for carrying out the comparison (use Make_Boolean_Array_Op)
2203       --  and then inserting it into the tree. The original operator node is
2204       --  then rewritten as a call to this function. We also use this in the
2205       --  packed case if either operand is a possibly unaligned object.
2206
2207       declare
2208          Loc       : constant Source_Ptr := Sloc (N);
2209          L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
2210          R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
2211          Func_Body : Node_Id;
2212          Func_Name : Entity_Id;
2213
2214       begin
2215          Convert_To_Actual_Subtype (L);
2216          Convert_To_Actual_Subtype (R);
2217          Ensure_Defined (Etype (L), N);
2218          Ensure_Defined (Etype (R), N);
2219          Apply_Length_Check (R, Etype (L));
2220
2221          if Nkind (N) = N_Op_Xor then
2222             Silly_Boolean_Array_Xor_Test (N, Etype (L));
2223          end if;
2224
2225          if Nkind (Parent (N)) = N_Assignment_Statement
2226            and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
2227          then
2228             Build_Boolean_Array_Proc_Call (Parent (N), L, R);
2229
2230          elsif Nkind (Parent (N)) = N_Op_Not
2231            and then Nkind (N) = N_Op_And
2232            and then
2233              Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
2234          then
2235             return;
2236          else
2237
2238             Func_Body := Make_Boolean_Array_Op (Etype (L), N);
2239             Func_Name := Defining_Unit_Name (Specification (Func_Body));
2240             Insert_Action (N, Func_Body);
2241
2242             --  Now rewrite the expression with a call
2243
2244             Rewrite (N,
2245               Make_Function_Call (Loc,
2246                 Name                   => New_Reference_To (Func_Name, Loc),
2247                 Parameter_Associations =>
2248                   New_List (
2249                     L,
2250                     Make_Type_Conversion
2251                       (Loc, New_Reference_To (Etype (L), Loc), R))));
2252
2253             Analyze_And_Resolve (N, Typ);
2254          end if;
2255       end;
2256    end Expand_Boolean_Operator;
2257
2258    ------------------------------------------------
2259    -- Expand_Compare_Minimize_Eliminate_Overflow --
2260    ------------------------------------------------
2261
2262    procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
2263       Loc : constant Source_Ptr := Sloc (N);
2264
2265       Result_Type : constant Entity_Id := Etype (N);
2266       --  Capture result type (could be a derived boolean type)
2267
2268       Llo, Lhi : Uint;
2269       Rlo, Rhi : Uint;
2270
2271       LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
2272       --  Entity for Long_Long_Integer'Base
2273
2274       Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
2275       --  Current overflow checking mode
2276
2277       procedure Set_True;
2278       procedure Set_False;
2279       --  These procedures rewrite N with an occurrence of Standard_True or
2280       --  Standard_False, and then makes a call to Warn_On_Known_Condition.
2281
2282       ---------------
2283       -- Set_False --
2284       ---------------
2285
2286       procedure Set_False is
2287       begin
2288          Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2289          Warn_On_Known_Condition (N);
2290       end Set_False;
2291
2292       --------------
2293       -- Set_True --
2294       --------------
2295
2296       procedure Set_True is
2297       begin
2298          Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
2299          Warn_On_Known_Condition (N);
2300       end Set_True;
2301
2302    --  Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
2303
2304    begin
2305       --  Nothing to do unless we have a comparison operator with operands
2306       --  that are signed integer types, and we are operating in either
2307       --  MINIMIZED or ELIMINATED overflow checking mode.
2308
2309       if Nkind (N) not in N_Op_Compare
2310         or else Check not in Minimized_Or_Eliminated
2311         or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
2312       then
2313          return;
2314       end if;
2315
2316       --  OK, this is the case we are interested in. First step is to process
2317       --  our operands using the Minimize_Eliminate circuitry which applies
2318       --  this processing to the two operand subtrees.
2319
2320       Minimize_Eliminate_Overflows
2321         (Left_Opnd (N),  Llo, Lhi, Top_Level => False);
2322       Minimize_Eliminate_Overflows
2323         (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
2324
2325       --  See if the range information decides the result of the comparison.
2326       --  We can only do this if we in fact have full range information (which
2327       --  won't be the case if either operand is bignum at this stage).
2328
2329       if Llo /= No_Uint and then Rlo /= No_Uint then
2330          case N_Op_Compare (Nkind (N)) is
2331          when N_Op_Eq =>
2332             if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2333                Set_True;
2334             elsif Llo > Rhi or else Lhi < Rlo then
2335                Set_False;
2336             end if;
2337
2338          when N_Op_Ge =>
2339             if Llo >= Rhi then
2340                Set_True;
2341             elsif Lhi < Rlo then
2342                Set_False;
2343             end if;
2344
2345          when N_Op_Gt =>
2346             if Llo > Rhi then
2347                Set_True;
2348             elsif Lhi <= Rlo then
2349                Set_False;
2350             end if;
2351
2352          when N_Op_Le =>
2353             if Llo > Rhi then
2354                Set_False;
2355             elsif Lhi <= Rlo then
2356                Set_True;
2357             end if;
2358
2359          when N_Op_Lt =>
2360             if Llo >= Rhi then
2361                Set_False;
2362             elsif Lhi < Rlo then
2363                Set_True;
2364             end if;
2365
2366          when N_Op_Ne =>
2367             if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
2368                Set_False;
2369             elsif Llo > Rhi or else Lhi < Rlo then
2370                Set_True;
2371             end if;
2372          end case;
2373
2374          --  All done if we did the rewrite
2375
2376          if Nkind (N) not in N_Op_Compare then
2377             return;
2378          end if;
2379       end if;
2380
2381       --  Otherwise, time to do the comparison
2382
2383       declare
2384          Ltype : constant Entity_Id := Etype (Left_Opnd (N));
2385          Rtype : constant Entity_Id := Etype (Right_Opnd (N));
2386
2387       begin
2388          --  If the two operands have the same signed integer type we are
2389          --  all set, nothing more to do. This is the case where either
2390          --  both operands were unchanged, or we rewrote both of them to
2391          --  be Long_Long_Integer.
2392
2393          --  Note: Entity for the comparison may be wrong, but it's not worth
2394          --  the effort to change it, since the back end does not use it.
2395
2396          if Is_Signed_Integer_Type (Ltype)
2397            and then Base_Type (Ltype) = Base_Type (Rtype)
2398          then
2399             return;
2400
2401          --  Here if bignums are involved (can only happen in ELIMINATED mode)
2402
2403          elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
2404             declare
2405                Left  : Node_Id := Left_Opnd (N);
2406                Right : Node_Id := Right_Opnd (N);
2407                --  Bignum references for left and right operands
2408
2409             begin
2410                if not Is_RTE (Ltype, RE_Bignum) then
2411                   Left := Convert_To_Bignum (Left);
2412                elsif not Is_RTE (Rtype, RE_Bignum) then
2413                   Right := Convert_To_Bignum (Right);
2414                end if;
2415
2416                --  We rewrite our node with:
2417
2418                --    do
2419                --       Bnn : Result_Type;
2420                --       declare
2421                --          M : Mark_Id := SS_Mark;
2422                --       begin
2423                --          Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
2424                --          SS_Release (M);
2425                --       end;
2426                --    in
2427                --       Bnn
2428                --    end
2429
2430                declare
2431                   Blk : constant Node_Id   := Make_Bignum_Block (Loc);
2432                   Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
2433                   Ent : RE_Id;
2434
2435                begin
2436                   case N_Op_Compare (Nkind (N)) is
2437                      when N_Op_Eq => Ent := RE_Big_EQ;
2438                      when N_Op_Ge => Ent := RE_Big_GE;
2439                      when N_Op_Gt => Ent := RE_Big_GT;
2440                      when N_Op_Le => Ent := RE_Big_LE;
2441                      when N_Op_Lt => Ent := RE_Big_LT;
2442                      when N_Op_Ne => Ent := RE_Big_NE;
2443                   end case;
2444
2445                   --  Insert assignment to Bnn into the bignum block
2446
2447                   Insert_Before
2448                     (First (Statements (Handled_Statement_Sequence (Blk))),
2449                      Make_Assignment_Statement (Loc,
2450                        Name       => New_Occurrence_Of (Bnn, Loc),
2451                        Expression =>
2452                          Make_Function_Call (Loc,
2453                            Name                   =>
2454                              New_Occurrence_Of (RTE (Ent), Loc),
2455                            Parameter_Associations => New_List (Left, Right))));
2456
2457                   --  Now do the rewrite with expression actions
2458
2459                   Rewrite (N,
2460                     Make_Expression_With_Actions (Loc,
2461                       Actions    => New_List (
2462                         Make_Object_Declaration (Loc,
2463                           Defining_Identifier => Bnn,
2464                           Object_Definition   =>
2465                             New_Occurrence_Of (Result_Type, Loc)),
2466                         Blk),
2467                       Expression => New_Occurrence_Of (Bnn, Loc)));
2468                   Analyze_And_Resolve (N, Result_Type);
2469                end;
2470             end;
2471
2472          --  No bignums involved, but types are different, so we must have
2473          --  rewritten one of the operands as a Long_Long_Integer but not
2474          --  the other one.
2475
2476          --  If left operand is Long_Long_Integer, convert right operand
2477          --  and we are done (with a comparison of two Long_Long_Integers).
2478
2479          elsif Ltype = LLIB then
2480             Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
2481             Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
2482             return;
2483
2484          --  If right operand is Long_Long_Integer, convert left operand
2485          --  and we are done (with a comparison of two Long_Long_Integers).
2486
2487          --  This is the only remaining possibility
2488
2489          else pragma Assert (Rtype = LLIB);
2490             Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
2491             Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
2492             return;
2493          end if;
2494       end;
2495    end Expand_Compare_Minimize_Eliminate_Overflow;
2496
2497    -------------------------------
2498    -- Expand_Composite_Equality --
2499    -------------------------------
2500
2501    --  This function is only called for comparing internal fields of composite
2502    --  types when these fields are themselves composites. This is a special
2503    --  case because it is not possible to respect normal Ada visibility rules.
2504
2505    function Expand_Composite_Equality
2506      (Nod    : Node_Id;
2507       Typ    : Entity_Id;
2508       Lhs    : Node_Id;
2509       Rhs    : Node_Id;
2510       Bodies : List_Id) return Node_Id
2511    is
2512       Loc       : constant Source_Ptr := Sloc (Nod);
2513       Full_Type : Entity_Id;
2514       Prim      : Elmt_Id;
2515       Eq_Op     : Entity_Id;
2516
2517       function Find_Primitive_Eq return Node_Id;
2518       --  AI05-0123: Locate primitive equality for type if it exists, and
2519       --  build the corresponding call. If operation is abstract, replace
2520       --  call with an explicit raise. Return Empty if there is no primitive.
2521
2522       -----------------------
2523       -- Find_Primitive_Eq --
2524       -----------------------
2525
2526       function Find_Primitive_Eq return Node_Id is
2527          Prim_E : Elmt_Id;
2528          Prim   : Node_Id;
2529
2530       begin
2531          Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
2532          while Present (Prim_E) loop
2533             Prim := Node (Prim_E);
2534
2535             --  Locate primitive equality with the right signature
2536
2537             if Chars (Prim) = Name_Op_Eq
2538               and then Etype (First_Formal (Prim)) =
2539                        Etype (Next_Formal (First_Formal (Prim)))
2540               and then Etype (Prim) = Standard_Boolean
2541             then
2542                if Is_Abstract_Subprogram (Prim) then
2543                   return
2544                     Make_Raise_Program_Error (Loc,
2545                       Reason => PE_Explicit_Raise);
2546
2547                else
2548                   return
2549                     Make_Function_Call (Loc,
2550                       Name                   => New_Reference_To (Prim, Loc),
2551                       Parameter_Associations => New_List (Lhs, Rhs));
2552                end if;
2553             end if;
2554
2555             Next_Elmt (Prim_E);
2556          end loop;
2557
2558          --  If not found, predefined operation will be used
2559
2560          return Empty;
2561       end Find_Primitive_Eq;
2562
2563    --  Start of processing for Expand_Composite_Equality
2564
2565    begin
2566       if Is_Private_Type (Typ) then
2567          Full_Type := Underlying_Type (Typ);
2568       else
2569          Full_Type := Typ;
2570       end if;
2571
2572       --  Defense against malformed private types with no completion the error
2573       --  will be diagnosed later by check_completion
2574
2575       if No (Full_Type) then
2576          return New_Reference_To (Standard_False, Loc);
2577       end if;
2578
2579       Full_Type := Base_Type (Full_Type);
2580
2581       if Is_Array_Type (Full_Type) then
2582
2583          --  If the operand is an elementary type other than a floating-point
2584          --  type, then we can simply use the built-in block bitwise equality,
2585          --  since the predefined equality operators always apply and bitwise
2586          --  equality is fine for all these cases.
2587
2588          if Is_Elementary_Type (Component_Type (Full_Type))
2589            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
2590          then
2591             return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2592
2593          --  For composite component types, and floating-point types, use the
2594          --  expansion. This deals with tagged component types (where we use
2595          --  the applicable equality routine) and floating-point, (where we
2596          --  need to worry about negative zeroes), and also the case of any
2597          --  composite type recursively containing such fields.
2598
2599          else
2600             return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
2601          end if;
2602
2603       elsif Is_Tagged_Type (Full_Type) then
2604
2605          --  Call the primitive operation "=" of this type
2606
2607          if Is_Class_Wide_Type (Full_Type) then
2608             Full_Type := Root_Type (Full_Type);
2609          end if;
2610
2611          --  If this is derived from an untagged private type completed with a
2612          --  tagged type, it does not have a full view, so we use the primitive
2613          --  operations of the private type. This check should no longer be
2614          --  necessary when these types receive their full views ???
2615
2616          if Is_Private_Type (Typ)
2617            and then not Is_Tagged_Type (Typ)
2618            and then not Is_Controlled (Typ)
2619            and then Is_Derived_Type (Typ)
2620            and then No (Full_View (Typ))
2621          then
2622             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2623          else
2624             Prim := First_Elmt (Primitive_Operations (Full_Type));
2625          end if;
2626
2627          loop
2628             Eq_Op := Node (Prim);
2629             exit when Chars (Eq_Op) = Name_Op_Eq
2630               and then Etype (First_Formal (Eq_Op)) =
2631                        Etype (Next_Formal (First_Formal (Eq_Op)))
2632               and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
2633             Next_Elmt (Prim);
2634             pragma Assert (Present (Prim));
2635          end loop;
2636
2637          Eq_Op := Node (Prim);
2638
2639          return
2640            Make_Function_Call (Loc,
2641              Name => New_Reference_To (Eq_Op, Loc),
2642              Parameter_Associations =>
2643                New_List
2644                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2645                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2646
2647       elsif Is_Record_Type (Full_Type) then
2648          Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2649
2650          if Present (Eq_Op) then
2651             if Etype (First_Formal (Eq_Op)) /= Full_Type then
2652
2653                --  Inherited equality from parent type. Convert the actuals to
2654                --  match signature of operation.
2655
2656                declare
2657                   T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2658
2659                begin
2660                   return
2661                     Make_Function_Call (Loc,
2662                       Name                  => New_Reference_To (Eq_Op, Loc),
2663                       Parameter_Associations => New_List (
2664                         OK_Convert_To (T, Lhs),
2665                         OK_Convert_To (T, Rhs)));
2666                end;
2667
2668             else
2669                --  Comparison between Unchecked_Union components
2670
2671                if Is_Unchecked_Union (Full_Type) then
2672                   declare
2673                      Lhs_Type      : Node_Id := Full_Type;
2674                      Rhs_Type      : Node_Id := Full_Type;
2675                      Lhs_Discr_Val : Node_Id;
2676                      Rhs_Discr_Val : Node_Id;
2677
2678                   begin
2679                      --  Lhs subtype
2680
2681                      if Nkind (Lhs) = N_Selected_Component then
2682                         Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2683                      end if;
2684
2685                      --  Rhs subtype
2686
2687                      if Nkind (Rhs) = N_Selected_Component then
2688                         Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2689                      end if;
2690
2691                      --  Lhs of the composite equality
2692
2693                      if Is_Constrained (Lhs_Type) then
2694
2695                         --  Since the enclosing record type can never be an
2696                         --  Unchecked_Union (this code is executed for records
2697                         --  that do not have variants), we may reference its
2698                         --  discriminant(s).
2699
2700                         if Nkind (Lhs) = N_Selected_Component
2701                           and then Has_Per_Object_Constraint
2702                                      (Entity (Selector_Name (Lhs)))
2703                         then
2704                            Lhs_Discr_Val :=
2705                              Make_Selected_Component (Loc,
2706                                Prefix        => Prefix (Lhs),
2707                                Selector_Name =>
2708                                  New_Copy
2709                                    (Get_Discriminant_Value
2710                                       (First_Discriminant (Lhs_Type),
2711                                        Lhs_Type,
2712                                        Stored_Constraint (Lhs_Type))));
2713
2714                         else
2715                            Lhs_Discr_Val :=
2716                              New_Copy
2717                                (Get_Discriminant_Value
2718                                   (First_Discriminant (Lhs_Type),
2719                                    Lhs_Type,
2720                                    Stored_Constraint (Lhs_Type)));
2721
2722                         end if;
2723                      else
2724                         --  It is not possible to infer the discriminant since
2725                         --  the subtype is not constrained.
2726
2727                         return
2728                           Make_Raise_Program_Error (Loc,
2729                             Reason => PE_Unchecked_Union_Restriction);
2730                      end if;
2731
2732                      --  Rhs of the composite equality
2733
2734                      if Is_Constrained (Rhs_Type) then
2735                         if Nkind (Rhs) = N_Selected_Component
2736                           and then Has_Per_Object_Constraint
2737                                      (Entity (Selector_Name (Rhs)))
2738                         then
2739                            Rhs_Discr_Val :=
2740                              Make_Selected_Component (Loc,
2741                                Prefix        => Prefix (Rhs),
2742                                Selector_Name =>
2743                                  New_Copy
2744                                    (Get_Discriminant_Value
2745                                       (First_Discriminant (Rhs_Type),
2746                                        Rhs_Type,
2747                                        Stored_Constraint (Rhs_Type))));
2748
2749                         else
2750                            Rhs_Discr_Val :=
2751                              New_Copy
2752                                (Get_Discriminant_Value
2753                                   (First_Discriminant (Rhs_Type),
2754                                    Rhs_Type,
2755                                    Stored_Constraint (Rhs_Type)));
2756
2757                         end if;
2758                      else
2759                         return
2760                           Make_Raise_Program_Error (Loc,
2761                             Reason => PE_Unchecked_Union_Restriction);
2762                      end if;
2763
2764                      --  Call the TSS equality function with the inferred
2765                      --  discriminant values.
2766
2767                      return
2768                        Make_Function_Call (Loc,
2769                          Name => New_Reference_To (Eq_Op, Loc),
2770                          Parameter_Associations => New_List (
2771                            Lhs,
2772                            Rhs,
2773                            Lhs_Discr_Val,
2774                            Rhs_Discr_Val));
2775                   end;
2776
2777                else
2778                   return
2779                     Make_Function_Call (Loc,
2780                       Name                   => New_Reference_To (Eq_Op, Loc),
2781                       Parameter_Associations => New_List (Lhs, Rhs));
2782                end if;
2783             end if;
2784
2785          --  Equality composes in Ada 2012 for untagged record types. It also
2786          --  composes for bounded strings, because they are part of the
2787          --  predefined environment. We could make it compose for bounded
2788          --  strings by making them tagged, or by making sure all subcomponents
2789          --  are set to the same value, even when not used. Instead, we have
2790          --  this special case in the compiler, because it's more efficient.
2791
2792          elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
2793
2794             --  if no TSS has been created for the type, check whether there is
2795             --  a primitive equality declared for it.
2796
2797             declare
2798                Op : constant Node_Id := Find_Primitive_Eq;
2799
2800             begin
2801                --  Use user-defined primitive if it exists, otherwise use
2802                --  predefined equality.
2803
2804                if Present (Op) then
2805                   return Op;
2806                else
2807                   return Make_Op_Eq (Loc, Lhs, Rhs);
2808                end if;
2809             end;
2810
2811          else
2812             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2813          end if;
2814
2815       else
2816          --  If not array or record type, it is predefined equality.
2817
2818          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2819       end if;
2820    end Expand_Composite_Equality;
2821
2822    ------------------------
2823    -- Expand_Concatenate --
2824    ------------------------
2825
2826    procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2827       Loc : constant Source_Ptr := Sloc (Cnode);
2828
2829       Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2830       --  Result type of concatenation
2831
2832       Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2833       --  Component type. Elements of this component type can appear as one
2834       --  of the operands of concatenation as well as arrays.
2835
2836       Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2837       --  Index subtype
2838
2839       Ityp : constant Entity_Id := Base_Type (Istyp);
2840       --  Index type. This is the base type of the index subtype, and is used
2841       --  for all computed bounds (which may be out of range of Istyp in the
2842       --  case of null ranges).
2843
2844       Artyp : Entity_Id;
2845       --  This is the type we use to do arithmetic to compute the bounds and
2846       --  lengths of operands. The choice of this type is a little subtle and
2847       --  is discussed in a separate section at the start of the body code.
2848
2849       Concatenation_Error : exception;
2850       --  Raised if concatenation is sure to raise a CE
2851
2852       Result_May_Be_Null : Boolean := True;
2853       --  Reset to False if at least one operand is encountered which is known
2854       --  at compile time to be non-null. Used for handling the special case
2855       --  of setting the high bound to the last operand high bound for a null
2856       --  result, thus ensuring a proper high bound in the super-flat case.
2857
2858       N : constant Nat := List_Length (Opnds);
2859       --  Number of concatenation operands including possibly null operands
2860
2861       NN : Nat := 0;
2862       --  Number of operands excluding any known to be null, except that the
2863       --  last operand is always retained, in case it provides the bounds for
2864       --  a null result.
2865
2866       Opnd : Node_Id;
2867       --  Current operand being processed in the loop through operands. After
2868       --  this loop is complete, always contains the last operand (which is not
2869       --  the same as Operands (NN), since null operands are skipped).
2870
2871       --  Arrays describing the operands, only the first NN entries of each
2872       --  array are set (NN < N when we exclude known null operands).
2873
2874       Is_Fixed_Length : array (1 .. N) of Boolean;
2875       --  True if length of corresponding operand known at compile time
2876
2877       Operands : array (1 .. N) of Node_Id;
2878       --  Set to the corresponding entry in the Opnds list (but note that null
2879       --  operands are excluded, so not all entries in the list are stored).
2880
2881       Fixed_Length : array (1 .. N) of Uint;
2882       --  Set to length of operand. Entries in this array are set only if the
2883       --  corresponding entry in Is_Fixed_Length is True.
2884
2885       Opnd_Low_Bound : array (1 .. N) of Node_Id;
2886       --  Set to lower bound of operand. Either an integer literal in the case
2887       --  where the bound is known at compile time, else actual lower bound.
2888       --  The operand low bound is of type Ityp.
2889
2890       Var_Length : array (1 .. N) of Entity_Id;
2891       --  Set to an entity of type Natural that contains the length of an
2892       --  operand whose length is not known at compile time. Entries in this
2893       --  array are set only if the corresponding entry in Is_Fixed_Length
2894       --  is False. The entity is of type Artyp.
2895
2896       Aggr_Length : array (0 .. N) of Node_Id;
2897       --  The J'th entry in an expression node that represents the total length
2898       --  of operands 1 through J. It is either an integer literal node, or a
2899       --  reference to a constant entity with the right value, so it is fine
2900       --  to just do a Copy_Node to get an appropriate copy. The extra zero'th
2901       --  entry always is set to zero. The length is of type Artyp.
2902
2903       Low_Bound : Node_Id;
2904       --  A tree node representing the low bound of the result (of type Ityp).
2905       --  This is either an integer literal node, or an identifier reference to
2906       --  a constant entity initialized to the appropriate value.
2907
2908       Last_Opnd_Low_Bound : Node_Id;
2909       --  A tree node representing the low bound of the last operand. This
2910       --  need only be set if the result could be null. It is used for the
2911       --  special case of setting the right low bound for a null result.
2912       --  This is of type Ityp.
2913
2914       Last_Opnd_High_Bound : Node_Id;
2915       --  A tree node representing the high bound of the last operand. This
2916       --  need only be set if the result could be null. It is used for the
2917       --  special case of setting the right high bound for a null result.
2918       --  This is of type Ityp.
2919
2920       High_Bound : Node_Id;
2921       --  A tree node representing the high bound of the result (of type Ityp)
2922
2923       Result : Node_Id;
2924       --  Result of the concatenation (of type Ityp)
2925
2926       Actions : constant List_Id := New_List;
2927       --  Collect actions to be inserted
2928
2929       Known_Non_Null_Operand_Seen : Boolean;
2930       --  Set True during generation of the assignments of operands into
2931       --  result once an operand known to be non-null has been seen.
2932
2933       function Make_Artyp_Literal (Val : Nat) return Node_Id;
2934       --  This function makes an N_Integer_Literal node that is returned in
2935       --  analyzed form with the type set to Artyp. Importantly this literal
2936       --  is not flagged as static, so that if we do computations with it that
2937       --  result in statically detected out of range conditions, we will not
2938       --  generate error messages but instead warning messages.
2939
2940       function To_Artyp (X : Node_Id) return Node_Id;
2941       --  Given a node of type Ityp, returns the corresponding value of type
2942       --  Artyp. For non-enumeration types, this is a plain integer conversion.
2943       --  For enum types, the Pos of the value is returned.
2944
2945       function To_Ityp (X : Node_Id) return Node_Id;
2946       --  The inverse function (uses Val in the case of enumeration types)
2947
2948       ------------------------
2949       -- Make_Artyp_Literal --
2950       ------------------------
2951
2952       function Make_Artyp_Literal (Val : Nat) return Node_Id is
2953          Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2954       begin
2955          Set_Etype (Result, Artyp);
2956          Set_Analyzed (Result, True);
2957          Set_Is_Static_Expression (Result, False);
2958          return Result;
2959       end Make_Artyp_Literal;
2960
2961       --------------
2962       -- To_Artyp --
2963       --------------
2964
2965       function To_Artyp (X : Node_Id) return Node_Id is
2966       begin
2967          if Ityp = Base_Type (Artyp) then
2968             return X;
2969
2970          elsif Is_Enumeration_Type (Ityp) then
2971             return
2972               Make_Attribute_Reference (Loc,
2973                 Prefix         => New_Occurrence_Of (Ityp, Loc),
2974                 Attribute_Name => Name_Pos,
2975                 Expressions    => New_List (X));
2976
2977          else
2978             return Convert_To (Artyp, X);
2979          end if;
2980       end To_Artyp;
2981
2982       -------------
2983       -- To_Ityp --
2984       -------------
2985
2986       function To_Ityp (X : Node_Id) return Node_Id is
2987       begin
2988          if Is_Enumeration_Type (Ityp) then
2989             return
2990               Make_Attribute_Reference (Loc,
2991                 Prefix         => New_Occurrence_Of (Ityp, Loc),
2992                 Attribute_Name => Name_Val,
2993                 Expressions    => New_List (X));
2994
2995          --  Case where we will do a type conversion
2996
2997          else
2998             if Ityp = Base_Type (Artyp) then
2999                return X;
3000             else
3001                return Convert_To (Ityp, X);
3002             end if;
3003          end if;
3004       end To_Ityp;
3005
3006       --  Local Declarations
3007
3008       Opnd_Typ : Entity_Id;
3009       Ent      : Entity_Id;
3010       Len      : Uint;
3011       J        : Nat;
3012       Clen     : Node_Id;
3013       Set      : Boolean;
3014
3015    --  Start of processing for Expand_Concatenate
3016
3017    begin
3018       --  Choose an appropriate computational type
3019
3020       --  We will be doing calculations of lengths and bounds in this routine
3021       --  and computing one from the other in some cases, e.g. getting the high
3022       --  bound by adding the length-1 to the low bound.
3023
3024       --  We can't just use the index type, or even its base type for this
3025       --  purpose for two reasons. First it might be an enumeration type which
3026       --  is not suitable for computations of any kind, and second it may
3027       --  simply not have enough range. For example if the index type is
3028       --  -128..+127 then lengths can be up to 256, which is out of range of
3029       --  the type.
3030
3031       --  For enumeration types, we can simply use Standard_Integer, this is
3032       --  sufficient since the actual number of enumeration literals cannot
3033       --  possibly exceed the range of integer (remember we will be doing the
3034       --  arithmetic with POS values, not representation values).
3035
3036       if Is_Enumeration_Type (Ityp) then
3037          Artyp := Standard_Integer;
3038
3039       --  If index type is Positive, we use the standard unsigned type, to give
3040       --  more room on the top of the range, obviating the need for an overflow
3041       --  check when creating the upper bound. This is needed to avoid junk
3042       --  overflow checks in the common case of String types.
3043
3044       --  ??? Disabled for now
3045
3046       --  elsif Istyp = Standard_Positive then
3047       --     Artyp := Standard_Unsigned;
3048
3049       --  For modular types, we use a 32-bit modular type for types whose size
3050       --  is in the range 1-31 bits. For 32-bit unsigned types, we use the
3051       --  identity type, and for larger unsigned types we use 64-bits.
3052
3053       elsif Is_Modular_Integer_Type (Ityp) then
3054          if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
3055             Artyp := Standard_Unsigned;
3056          elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
3057             Artyp := Ityp;
3058          else
3059             Artyp := RTE (RE_Long_Long_Unsigned);
3060          end if;
3061
3062       --  Similar treatment for signed types
3063
3064       else
3065          if RM_Size (Ityp) < RM_Size (Standard_Integer) then
3066             Artyp := Standard_Integer;
3067          elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
3068             Artyp := Ityp;
3069          else
3070             Artyp := Standard_Long_Long_Integer;
3071          end if;
3072       end if;
3073
3074       --  Supply dummy entry at start of length array
3075
3076       Aggr_Length (0) := Make_Artyp_Literal (0);
3077
3078       --  Go through operands setting up the above arrays
3079
3080       J := 1;
3081       while J <= N loop
3082          Opnd := Remove_Head (Opnds);
3083          Opnd_Typ := Etype (Opnd);
3084
3085          --  The parent got messed up when we put the operands in a list,
3086          --  so now put back the proper parent for the saved operand, that
3087          --  is to say the concatenation node, to make sure that each operand
3088          --  is seen as a subexpression, e.g. if actions must be inserted.
3089
3090          Set_Parent (Opnd, Cnode);
3091
3092          --  Set will be True when we have setup one entry in the array
3093
3094          Set := False;
3095
3096          --  Singleton element (or character literal) case
3097
3098          if Base_Type (Opnd_Typ) = Ctyp then
3099             NN := NN + 1;
3100             Operands (NN) := Opnd;
3101             Is_Fixed_Length (NN) := True;
3102             Fixed_Length (NN) := Uint_1;
3103             Result_May_Be_Null := False;
3104
3105             --  Set low bound of operand (no need to set Last_Opnd_High_Bound
3106             --  since we know that the result cannot be null).
3107
3108             Opnd_Low_Bound (NN) :=
3109               Make_Attribute_Reference (Loc,
3110                 Prefix         => New_Reference_To (Istyp, Loc),
3111                 Attribute_Name => Name_First);
3112
3113             Set := True;
3114
3115          --  String literal case (can only occur for strings of course)
3116
3117          elsif Nkind (Opnd) = N_String_Literal then
3118             Len := String_Literal_Length (Opnd_Typ);
3119
3120             if Len /= 0 then
3121                Result_May_Be_Null := False;
3122             end if;
3123
3124             --  Capture last operand low and high bound if result could be null
3125
3126             if J = N and then Result_May_Be_Null then
3127                Last_Opnd_Low_Bound :=
3128                  New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3129
3130                Last_Opnd_High_Bound :=
3131                  Make_Op_Subtract (Loc,
3132                    Left_Opnd  =>
3133                      New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
3134                    Right_Opnd => Make_Integer_Literal (Loc, 1));
3135             end if;
3136
3137             --  Skip null string literal
3138
3139             if J < N and then Len = 0 then
3140                goto Continue;
3141             end if;
3142
3143             NN := NN + 1;
3144             Operands (NN) := Opnd;
3145             Is_Fixed_Length (NN) := True;
3146
3147             --  Set length and bounds
3148
3149             Fixed_Length (NN) := Len;
3150
3151             Opnd_Low_Bound (NN) :=
3152               New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
3153
3154             Set := True;
3155
3156          --  All other cases
3157
3158          else
3159             --  Check constrained case with known bounds
3160
3161             if Is_Constrained (Opnd_Typ) then
3162                declare
3163                   Index    : constant Node_Id   := First_Index (Opnd_Typ);
3164                   Indx_Typ : constant Entity_Id := Etype (Index);
3165                   Lo       : constant Node_Id   := Type_Low_Bound  (Indx_Typ);
3166                   Hi       : constant Node_Id   := Type_High_Bound (Indx_Typ);
3167
3168                begin
3169                   --  Fixed length constrained array type with known at compile
3170                   --  time bounds is last case of fixed length operand.
3171
3172                   if Compile_Time_Known_Value (Lo)
3173                        and then
3174                      Compile_Time_Known_Value (Hi)
3175                   then
3176                      declare
3177                         Loval : constant Uint := Expr_Value (Lo);
3178                         Hival : constant Uint := Expr_Value (Hi);
3179                         Len   : constant Uint :=
3180                                   UI_Max (Hival - Loval + 1, Uint_0);
3181
3182                      begin
3183                         if Len > 0 then
3184                            Result_May_Be_Null := False;
3185                         end if;
3186
3187                         --  Capture last operand bounds if result could be null
3188
3189                         if J = N and then Result_May_Be_Null then
3190                            Last_Opnd_Low_Bound :=
3191                              Convert_To (Ityp,
3192                                Make_Integer_Literal (Loc, Expr_Value (Lo)));
3193
3194                            Last_Opnd_High_Bound :=
3195                              Convert_To (Ityp,
3196                                Make_Integer_Literal (Loc, Expr_Value (Hi)));
3197                         end if;
3198
3199                         --  Exclude null length case unless last operand
3200
3201                         if J < N and then Len = 0 then
3202                            goto Continue;
3203                         end if;
3204
3205                         NN := NN + 1;
3206                         Operands (NN) := Opnd;
3207                         Is_Fixed_Length (NN) := True;
3208                         Fixed_Length (NN)    := Len;
3209
3210                         Opnd_Low_Bound (NN) :=
3211                           To_Ityp
3212                             (Make_Integer_Literal (Loc, Expr_Value (Lo)));
3213                         Set := True;
3214                      end;
3215                   end if;
3216                end;
3217             end if;
3218
3219             --  All cases where the length is not known at compile time, or the
3220             --  special case of an operand which is known to be null but has a
3221             --  lower bound other than 1 or is other than a string type.
3222
3223             if not Set then
3224                NN := NN + 1;
3225
3226                --  Capture operand bounds
3227
3228                Opnd_Low_Bound (NN) :=
3229                  Make_Attribute_Reference (Loc,
3230                    Prefix         =>
3231                      Duplicate_Subexpr (Opnd, Name_Req => True),
3232                    Attribute_Name => Name_First);
3233
3234                --  Capture last operand bounds if result could be null
3235
3236                if J = N and Result_May_Be_Null then
3237                   Last_Opnd_Low_Bound :=
3238                     Convert_To (Ityp,
3239                       Make_Attribute_Reference (Loc,
3240                         Prefix         =>
3241                           Duplicate_Subexpr (Opnd, Name_Req => True),
3242                         Attribute_Name => Name_First));
3243
3244                   Last_Opnd_High_Bound :=
3245                     Convert_To (Ityp,
3246                       Make_Attribute_Reference (Loc,
3247                         Prefix         =>
3248                           Duplicate_Subexpr (Opnd, Name_Req => True),
3249                         Attribute_Name => Name_Last));
3250                end if;
3251
3252                --  Capture length of operand in entity
3253
3254                Operands (NN) := Opnd;
3255                Is_Fixed_Length (NN) := False;
3256
3257                Var_Length (NN) := Make_Temporary (Loc, 'L');
3258
3259                Append_To (Actions,
3260                  Make_Object_Declaration (Loc,
3261                    Defining_Identifier => Var_Length (NN),
3262                    Constant_Present    => True,
3263                    Object_Definition   => New_Occurrence_Of (Artyp, Loc),
3264                    Expression          =>
3265                      Make_Attribute_Reference (Loc,
3266                        Prefix         =>
3267                          Duplicate_Subexpr (Opnd, Name_Req => True),
3268                        Attribute_Name => Name_Length)));
3269             end if;
3270          end if;
3271
3272          --  Set next entry in aggregate length array
3273
3274          --  For first entry, make either integer literal for fixed length
3275          --  or a reference to the saved length for variable length.
3276
3277          if NN = 1 then
3278             if Is_Fixed_Length (1) then
3279                Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
3280             else
3281                Aggr_Length (1) := New_Reference_To (Var_Length (1), Loc);
3282             end if;
3283
3284          --  If entry is fixed length and only fixed lengths so far, make
3285          --  appropriate new integer literal adding new length.
3286
3287          elsif Is_Fixed_Length (NN)
3288            and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
3289          then
3290             Aggr_Length (NN) :=
3291               Make_Integer_Literal (Loc,
3292                 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
3293
3294          --  All other cases, construct an addition node for the length and
3295          --  create an entity initialized to this length.
3296
3297          else
3298             Ent := Make_Temporary (Loc, 'L');
3299
3300             if Is_Fixed_Length (NN) then
3301                Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
3302             else
3303                Clen := New_Reference_To (Var_Length (NN), Loc);
3304             end if;
3305
3306             Append_To (Actions,
3307               Make_Object_Declaration (Loc,
3308                 Defining_Identifier => Ent,
3309                 Constant_Present    => True,
3310                 Object_Definition   => New_Occurrence_Of (Artyp, Loc),
3311                 Expression          =>
3312                   Make_Op_Add (Loc,
3313                     Left_Opnd  => New_Copy (Aggr_Length (NN - 1)),
3314                     Right_Opnd => Clen)));
3315
3316             Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
3317          end if;
3318
3319       <<Continue>>
3320          J := J + 1;
3321       end loop;
3322
3323       --  If we have only skipped null operands, return the last operand
3324
3325       if NN = 0 then
3326          Result := Opnd;
3327          goto Done;
3328       end if;
3329
3330       --  If we have only one non-null operand, return it and we are done.
3331       --  There is one case in which this cannot be done, and that is when
3332       --  the sole operand is of the element type, in which case it must be
3333       --  converted to an array, and the easiest way of doing that is to go
3334       --  through the normal general circuit.
3335
3336       if NN = 1 and then Base_Type (Etype (Operands (1))) /= Ctyp then
3337          Result := Operands (1);
3338          goto Done;
3339       end if;
3340
3341       --  Cases where we have a real concatenation
3342
3343       --  Next step is to find the low bound for the result array that we
3344       --  will allocate. The rules for this are in (RM 4.5.6(5-7)).
3345
3346       --  If the ultimate ancestor of the index subtype is a constrained array
3347       --  definition, then the lower bound is that of the index subtype as
3348       --  specified by (RM 4.5.3(6)).
3349
3350       --  The right test here is to go to the root type, and then the ultimate
3351       --  ancestor is the first subtype of this root type.
3352
3353       if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
3354          Low_Bound :=
3355            Make_Attribute_Reference (Loc,
3356              Prefix         =>
3357                New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
3358              Attribute_Name => Name_First);
3359
3360       --  If the first operand in the list has known length we know that
3361       --  the lower bound of the result is the lower bound of this operand.
3362
3363       elsif Is_Fixed_Length (1) then
3364          Low_Bound := Opnd_Low_Bound (1);
3365
3366       --  OK, we don't know the lower bound, we have to build a horrible
3367       --  if expression node of the form
3368
3369       --     if Cond1'Length /= 0 then
3370       --        Opnd1 low bound
3371       --     else
3372       --        if Opnd2'Length /= 0 then
3373       --          Opnd2 low bound
3374       --        else
3375       --           ...
3376
3377       --  The nesting ends either when we hit an operand whose length is known
3378       --  at compile time, or on reaching the last operand, whose low bound we
3379       --  take unconditionally whether or not it is null. It's easiest to do
3380       --  this with a recursive procedure:
3381
3382       else
3383          declare
3384             function Get_Known_Bound (J : Nat) return Node_Id;
3385             --  Returns the lower bound determined by operands J .. NN
3386
3387             ---------------------
3388             -- Get_Known_Bound --
3389             ---------------------
3390
3391             function Get_Known_Bound (J : Nat) return Node_Id is
3392             begin
3393                if Is_Fixed_Length (J) or else J = NN then
3394                   return New_Copy (Opnd_Low_Bound (J));
3395
3396                else
3397                   return
3398                     Make_If_Expression (Loc,
3399                       Expressions => New_List (
3400
3401                         Make_Op_Ne (Loc,
3402                           Left_Opnd  => New_Reference_To (Var_Length (J), Loc),
3403                           Right_Opnd => Make_Integer_Literal (Loc, 0)),
3404
3405                         New_Copy (Opnd_Low_Bound (J)),
3406                         Get_Known_Bound (J + 1)));
3407                end if;
3408             end Get_Known_Bound;
3409
3410          begin
3411             Ent := Make_Temporary (Loc, 'L');
3412
3413             Append_To (Actions,
3414               Make_Object_Declaration (Loc,
3415                 Defining_Identifier => Ent,
3416                 Constant_Present    => True,
3417                 Object_Definition   => New_Occurrence_Of (Ityp, Loc),
3418                 Expression          => Get_Known_Bound (1)));
3419
3420             Low_Bound := New_Reference_To (Ent, Loc);
3421          end;
3422       end if;
3423
3424       --  Now we can safely compute the upper bound, normally
3425       --  Low_Bound + Length - 1.
3426
3427       High_Bound :=
3428         To_Ityp (
3429           Make_Op_Add (Loc,
3430             Left_Opnd  => To_Artyp (New_Copy (Low_Bound)),
3431             Right_Opnd =>
3432               Make_Op_Subtract (Loc,
3433                 Left_Opnd  => New_Copy (Aggr_Length (NN)),
3434                 Right_Opnd => Make_Artyp_Literal (1))));
3435
3436       --  Note that calculation of the high bound may cause overflow in some
3437       --  very weird cases, so in the general case we need an overflow check on
3438       --  the high bound. We can avoid this for the common case of string types
3439       --  and other types whose index is Positive, since we chose a wider range
3440       --  for the arithmetic type.
3441
3442       if Istyp /= Standard_Positive then
3443          Activate_Overflow_Check (High_Bound);
3444       end if;
3445
3446       --  Handle the exceptional case where the result is null, in which case
3447       --  case the bounds come from the last operand (so that we get the proper
3448       --  bounds if the last operand is super-flat).
3449
3450       if Result_May_Be_Null then
3451          Low_Bound :=
3452            Make_If_Expression (Loc,
3453              Expressions => New_List (
3454                Make_Op_Eq (Loc,
3455                  Left_Opnd  => New_Copy (Aggr_Length (NN)),
3456                  Right_Opnd => Make_Artyp_Literal (0)),
3457                Last_Opnd_Low_Bound,
3458                Low_Bound));
3459
3460          High_Bound :=
3461            Make_If_Expression (Loc,
3462              Expressions => New_List (
3463                Make_Op_Eq (Loc,
3464                  Left_Opnd  => New_Copy (Aggr_Length (NN)),
3465                  Right_Opnd => Make_Artyp_Literal (0)),
3466                Last_Opnd_High_Bound,
3467                High_Bound));
3468       end if;
3469
3470       --  Here is where we insert the saved up actions
3471
3472       Insert_Actions (Cnode, Actions, Suppress => All_Checks);
3473
3474       --  Now we construct an array object with appropriate bounds. We mark
3475       --  the target as internal to prevent useless initialization when
3476       --  Initialize_Scalars is enabled. Also since this is the actual result
3477       --  entity, we make sure we have debug information for the result.
3478
3479       Ent := Make_Temporary (Loc, 'S');
3480       Set_Is_Internal (Ent);
3481       Set_Needs_Debug_Info (Ent);
3482
3483       --  If the bound is statically known to be out of range, we do not want
3484       --  to abort, we want a warning and a runtime constraint error. Note that
3485       --  we have arranged that the result will not be treated as a static
3486       --  constant, so we won't get an illegality during this insertion.
3487
3488       Insert_Action (Cnode,
3489         Make_Object_Declaration (Loc,
3490           Defining_Identifier => Ent,
3491           Object_Definition   =>
3492             Make_Subtype_Indication (Loc,
3493               Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
3494               Constraint   =>
3495                 Make_Index_Or_Discriminant_Constraint (Loc,
3496                   Constraints => New_List (
3497                     Make_Range (Loc,
3498                       Low_Bound  => Low_Bound,
3499                       High_Bound => High_Bound))))),
3500         Suppress => All_Checks);
3501
3502       --  If the result of the concatenation appears as the initializing
3503       --  expression of an object declaration, we can just rename the
3504       --  result, rather than copying it.
3505
3506       Set_OK_To_Rename (Ent);
3507
3508       --  Catch the static out of range case now
3509
3510       if Raises_Constraint_Error (High_Bound) then
3511          raise Concatenation_Error;
3512       end if;
3513
3514       --  Now we will generate the assignments to do the actual concatenation
3515
3516       --  There is one case in which we will not do this, namely when all the
3517       --  following conditions are met:
3518
3519       --    The result type is Standard.String
3520
3521       --    There are nine or fewer retained (non-null) operands
3522
3523       --    The optimization level is -O0
3524
3525       --    The corresponding System.Concat_n.Str_Concat_n routine is
3526       --    available in the run time.
3527
3528       --    The debug flag gnatd.c is not set
3529
3530       --  If all these conditions are met then we generate a call to the
3531       --  relevant concatenation routine. The purpose of this is to avoid
3532       --  undesirable code bloat at -O0.
3533
3534       if Atyp = Standard_String
3535         and then NN in 2 .. 9
3536         and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
3537         and then not Debug_Flag_Dot_C
3538       then
3539          declare
3540             RR : constant array (Nat range 2 .. 9) of RE_Id :=
3541                    (RE_Str_Concat_2,
3542                     RE_Str_Concat_3,
3543                     RE_Str_Concat_4,
3544                     RE_Str_Concat_5,
3545                     RE_Str_Concat_6,
3546                     RE_Str_Concat_7,
3547                     RE_Str_Concat_8,
3548                     RE_Str_Concat_9);
3549
3550          begin
3551             if RTE_Available (RR (NN)) then
3552                declare
3553                   Opnds : constant List_Id :=
3554                             New_List (New_Occurrence_Of (Ent, Loc));
3555
3556                begin
3557                   for J in 1 .. NN loop
3558                      if Is_List_Member (Operands (J)) then
3559                         Remove (Operands (J));
3560                      end if;
3561
3562                      if Base_Type (Etype (Operands (J))) = Ctyp then
3563                         Append_To (Opnds,
3564                           Make_Aggregate (Loc,
3565                             Component_Associations => New_List (
3566                               Make_Component_Association (Loc,
3567                                 Choices => New_List (
3568                                   Make_Integer_Literal (Loc, 1)),
3569                                 Expression => Operands (J)))));
3570
3571                      else
3572                         Append_To (Opnds, Operands (J));
3573                      end if;
3574                   end loop;
3575
3576                   Insert_Action (Cnode,
3577                     Make_Procedure_Call_Statement (Loc,
3578                       Name => New_Reference_To (RTE (RR (NN)), Loc),
3579                       Parameter_Associations => Opnds));
3580
3581                   Result := New_Reference_To (Ent, Loc);
3582                   goto Done;
3583                end;
3584             end if;
3585          end;
3586       end if;
3587
3588       --  Not special case so generate the assignments
3589
3590       Known_Non_Null_Operand_Seen := False;
3591
3592       for J in 1 .. NN loop
3593          declare
3594             Lo : constant Node_Id :=
3595                    Make_Op_Add (Loc,
3596                      Left_Opnd  => To_Artyp (New_Copy (Low_Bound)),
3597                      Right_Opnd => Aggr_Length (J - 1));
3598
3599             Hi : constant Node_Id :=
3600                    Make_Op_Add (Loc,
3601                      Left_Opnd  => To_Artyp (New_Copy (Low_Bound)),
3602                      Right_Opnd =>
3603                        Make_Op_Subtract (Loc,
3604                          Left_Opnd  => Aggr_Length (J),
3605                          Right_Opnd => Make_Artyp_Literal (1)));
3606
3607          begin
3608             --  Singleton case, simple assignment
3609
3610             if Base_Type (Etype (Operands (J))) = Ctyp then
3611                Known_Non_Null_Operand_Seen := True;
3612                Insert_Action (Cnode,
3613                  Make_Assignment_Statement (Loc,
3614                    Name       =>
3615                      Make_Indexed_Component (Loc,
3616                        Prefix      => New_Occurrence_Of (Ent, Loc),
3617                        Expressions => New_List (To_Ityp (Lo))),
3618                    Expression => Operands (J)),
3619                  Suppress => All_Checks);
3620
3621             --  Array case, slice assignment, skipped when argument is fixed
3622             --  length and known to be null.
3623
3624             elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
3625                declare
3626                   Assign : Node_Id :=
3627                              Make_Assignment_Statement (Loc,
3628                                Name       =>
3629                                  Make_Slice (Loc,
3630                                    Prefix         =>
3631                                      New_Occurrence_Of (Ent, Loc),
3632                                    Discrete_Range =>
3633                                      Make_Range (Loc,
3634                                        Low_Bound  => To_Ityp (Lo),
3635                                        High_Bound => To_Ityp (Hi))),
3636                                Expression => Operands (J));
3637                begin
3638                   if Is_Fixed_Length (J) then
3639                      Known_Non_Null_Operand_Seen := True;
3640
3641                   elsif not Known_Non_Null_Operand_Seen then
3642
3643                      --  Here if operand length is not statically known and no
3644                      --  operand known to be non-null has been processed yet.
3645                      --  If operand length is 0, we do not need to perform the
3646                      --  assignment, and we must avoid the evaluation of the
3647                      --  high bound of the slice, since it may underflow if the
3648                      --  low bound is Ityp'First.
3649
3650                      Assign :=
3651                        Make_Implicit_If_Statement (Cnode,
3652                          Condition       =>
3653                            Make_Op_Ne (Loc,
3654                              Left_Opnd  =>
3655                                New_Occurrence_Of (Var_Length (J), Loc),
3656                              Right_Opnd => Make_Integer_Literal (Loc, 0)),
3657                          Then_Statements => New_List (Assign));
3658                   end if;
3659
3660                   Insert_Action (Cnode, Assign, Suppress => All_Checks);
3661                end;
3662             end if;
3663          end;
3664       end loop;
3665
3666       --  Finally we build the result, which is a reference to the array object
3667
3668       Result := New_Reference_To (Ent, Loc);
3669
3670    <<Done>>
3671       Rewrite (Cnode, Result);
3672       Analyze_And_Resolve (Cnode, Atyp);
3673
3674    exception
3675       when Concatenation_Error =>
3676
3677          --  Kill warning generated for the declaration of the static out of
3678          --  range high bound, and instead generate a Constraint_Error with
3679          --  an appropriate specific message.
3680
3681          Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3682          Apply_Compile_Time_Constraint_Error
3683            (N      => Cnode,
3684             Msg    => "concatenation result upper bound out of range??",
3685             Reason => CE_Range_Check_Failed);
3686    end Expand_Concatenate;
3687
3688    ---------------------------------------------------
3689    -- Expand_Membership_Minimize_Eliminate_Overflow --
3690    ---------------------------------------------------
3691
3692    procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
3693       pragma Assert (Nkind (N) = N_In);
3694       --  Despite the name, this routine applies only to N_In, not to
3695       --  N_Not_In. The latter is always rewritten as not (X in Y).
3696
3697       Result_Type : constant Entity_Id := Etype (N);
3698       --  Capture result type, may be a derived boolean type
3699
3700       Loc : constant Source_Ptr := Sloc (N);
3701       Lop : constant Node_Id    := Left_Opnd (N);
3702       Rop : constant Node_Id    := Right_Opnd (N);
3703
3704       --  Note: there are many referencs to Etype (Lop) and Etype (Rop). It
3705       --  is thus tempting to capture these values, but due to the rewrites
3706       --  that occur as a result of overflow checking, these values change
3707       --  as we go along, and it is safe just to always use Etype explicitly.
3708
3709       Restype : constant Entity_Id := Etype (N);
3710       --  Save result type
3711
3712       Lo, Hi : Uint;
3713       --  Bounds in Minimize calls, not used currently
3714
3715       LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
3716       --  Entity for Long_Long_Integer'Base (Standard should export this???)
3717
3718    begin
3719       Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
3720
3721       --  If right operand is a subtype name, and the subtype name has no
3722       --  predicate, then we can just replace the right operand with an
3723       --  explicit range T'First .. T'Last, and use the explicit range code.
3724
3725       if Nkind (Rop) /= N_Range
3726         and then No (Predicate_Function (Etype (Rop)))
3727       then
3728          declare
3729             Rtyp : constant Entity_Id := Etype (Rop);
3730          begin
3731             Rewrite (Rop,
3732               Make_Range (Loc,
3733                 Low_Bound =>
3734                   Make_Attribute_Reference (Loc,
3735                     Attribute_Name => Name_First,
3736                     Prefix         => New_Reference_To (Rtyp, Loc)),
3737                 High_Bound =>
3738                   Make_Attribute_Reference (Loc,
3739                     Attribute_Name => Name_Last,
3740                     Prefix         => New_Reference_To (Rtyp, Loc))));
3741             Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
3742          end;
3743       end if;
3744
3745       --  Here for the explicit range case. Note that the bounds of the range
3746       --  have not been processed for minimized or eliminated checks.
3747
3748       if Nkind (Rop) = N_Range then
3749          Minimize_Eliminate_Overflows
3750            (Low_Bound (Rop), Lo, Hi, Top_Level => False);
3751          Minimize_Eliminate_Overflows
3752            (High_Bound (Rop), Lo, Hi, Top_Level => False);
3753
3754          --  We have A in B .. C, treated as  A >= B and then A <= C
3755
3756          --  Bignum case
3757
3758          if Is_RTE (Etype (Lop), RE_Bignum)
3759            or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
3760            or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
3761          then
3762             declare
3763                Blk    : constant Node_Id   := Make_Bignum_Block (Loc);
3764                Bnn    : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3765                L      : constant Entity_Id :=
3766                           Make_Defining_Identifier (Loc, Name_uL);
3767                Lopnd  : constant Node_Id   := Convert_To_Bignum (Lop);
3768                Lbound : constant Node_Id   :=
3769                           Convert_To_Bignum (Low_Bound (Rop));
3770                Hbound : constant Node_Id   :=
3771                           Convert_To_Bignum (High_Bound (Rop));
3772
3773             --  Now we rewrite the membership test node to look like
3774
3775             --    do
3776             --       Bnn : Result_Type;
3777             --       declare
3778             --          M : Mark_Id := SS_Mark;
3779             --          L : Bignum  := Lopnd;
3780             --       begin
3781             --          Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
3782             --          SS_Release (M);
3783             --       end;
3784             --    in
3785             --       Bnn
3786             --    end
3787
3788             begin
3789                --  Insert declaration of L into declarations of bignum block
3790
3791                Insert_After
3792                  (Last (Declarations (Blk)),
3793                   Make_Object_Declaration (Loc,
3794                     Defining_Identifier => L,
3795                     Object_Definition   =>
3796                       New_Occurrence_Of (RTE (RE_Bignum), Loc),
3797                     Expression          => Lopnd));
3798
3799                --  Insert assignment to Bnn into expressions of bignum block
3800
3801                Insert_Before
3802                  (First (Statements (Handled_Statement_Sequence (Blk))),
3803                   Make_Assignment_Statement (Loc,
3804                     Name       => New_Occurrence_Of (Bnn, Loc),
3805                     Expression =>
3806                       Make_And_Then (Loc,
3807                         Left_Opnd =>
3808                           Make_Function_Call (Loc,
3809                             Name                   =>
3810                               New_Occurrence_Of (RTE (RE_Big_GE), Loc),
3811                             Parameter_Associations => New_List (
3812                               New_Occurrence_Of (L, Loc),
3813                               Lbound)),
3814                         Right_Opnd =>
3815                           Make_Function_Call (Loc,
3816                             Name                   =>
3817                               New_Occurrence_Of (RTE (RE_Big_LE), Loc),
3818                             Parameter_Associations => New_List (
3819                               New_Occurrence_Of (L, Loc),
3820                               Hbound)))));
3821
3822                --  Now rewrite the node
3823
3824                Rewrite (N,
3825                  Make_Expression_With_Actions (Loc,
3826                    Actions    => New_List (
3827                      Make_Object_Declaration (Loc,
3828                        Defining_Identifier => Bnn,
3829                        Object_Definition   =>
3830                          New_Occurrence_Of (Result_Type, Loc)),
3831                      Blk),
3832                    Expression => New_Occurrence_Of (Bnn, Loc)));
3833                Analyze_And_Resolve (N, Result_Type);
3834                return;
3835             end;
3836
3837          --  Here if no bignums around
3838
3839          else
3840             --  Case where types are all the same
3841
3842             if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
3843                  and then
3844                Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
3845             then
3846                null;
3847
3848             --  If types are not all the same, it means that we have rewritten
3849             --  at least one of them to be of type Long_Long_Integer, and we
3850             --  will convert the other operands to Long_Long_Integer.
3851
3852             else
3853                Convert_To_And_Rewrite (LLIB, Lop);
3854                Set_Analyzed (Lop, False);
3855                Analyze_And_Resolve (Lop, LLIB);
3856
3857                --  For the right operand, avoid unnecessary recursion into
3858                --  this routine, we know that overflow is not possible.
3859
3860                Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
3861                Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
3862                Set_Analyzed (Rop, False);
3863                Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
3864             end if;
3865
3866             --  Now the three operands are of the same signed integer type,
3867             --  so we can use the normal expansion routine for membership,
3868             --  setting the flag to prevent recursion into this procedure.
3869
3870             Set_No_Minimize_Eliminate (N);
3871             Expand_N_In (N);
3872          end if;
3873
3874       --  Right operand is a subtype name and the subtype has a predicate. We
3875       --  have to make sure the predicate is checked, and for that we need to
3876       --  use the standard N_In circuitry with appropriate types.
3877
3878       else
3879          pragma Assert (Present (Predicate_Function (Etype (Rop))));
3880
3881          --  If types are "right", just call Expand_N_In preventing recursion
3882
3883          if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
3884             Set_No_Minimize_Eliminate (N);
3885             Expand_N_In (N);
3886
3887          --  Bignum case
3888
3889          elsif Is_RTE (Etype (Lop), RE_Bignum) then
3890
3891             --  For X in T, we want to rewrite our node as
3892
3893             --    do
3894             --       Bnn : Result_Type;
3895
3896             --       declare
3897             --          M   : Mark_Id := SS_Mark;
3898             --          Lnn : Long_Long_Integer'Base
3899             --          Nnn : Bignum;
3900
3901             --       begin
3902             --         Nnn := X;
3903
3904             --         if not Bignum_In_LLI_Range (Nnn) then
3905             --            Bnn := False;
3906             --         else
3907             --            Lnn := From_Bignum (Nnn);
3908             --            Bnn :=
3909             --              Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
3910             --                and then T'Base (Lnn) in T;
3911             --         end if;
3912             --
3913             --          SS_Release (M);
3914             --       end
3915             --   in
3916             --       Bnn
3917             --   end
3918
3919             --  A bit gruesome, but there doesn't seem to be a simpler way
3920
3921             declare
3922                Blk : constant Node_Id   := Make_Bignum_Block (Loc);
3923                Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
3924                Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
3925                Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
3926                T   : constant Entity_Id := Etype (Rop);
3927                TB  : constant Entity_Id := Base_Type (T);
3928                Nin : Node_Id;
3929
3930             begin
3931                --  Mark the last membership operation to prevent recursion
3932
3933                Nin :=
3934                  Make_In (Loc,
3935                    Left_Opnd  => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
3936                    Right_Opnd => New_Occurrence_Of (T, Loc));
3937                Set_No_Minimize_Eliminate (Nin);
3938
3939                --  Now decorate the block
3940
3941                Insert_After
3942                  (Last (Declarations (Blk)),
3943                   Make_Object_Declaration (Loc,
3944                     Defining_Identifier => Lnn,
3945                     Object_Definition   => New_Occurrence_Of (LLIB, Loc)));
3946
3947                Insert_After
3948                  (Last (Declarations (Blk)),
3949                   Make_Object_Declaration (Loc,
3950                     Defining_Identifier => Nnn,
3951                     Object_Definition   =>
3952                       New_Occurrence_Of (RTE (RE_Bignum), Loc)));
3953
3954                Insert_List_Before
3955                  (First (Statements (Handled_Statement_Sequence (Blk))),
3956                   New_List (
3957                     Make_Assignment_Statement (Loc,
3958                       Name       => New_Occurrence_Of (Nnn, Loc),
3959                       Expression => Relocate_Node (Lop)),
3960
3961                     Make_Implicit_If_Statement (N,
3962                       Condition =>
3963                         Make_Op_Not (Loc,
3964                           Right_Opnd =>
3965                             Make_Function_Call (Loc,
3966                               Name                   =>
3967                                 New_Occurrence_Of
3968                                   (RTE (RE_Bignum_In_LLI_Range), Loc),
3969                               Parameter_Associations => New_List (
3970                                 New_Occurrence_Of (Nnn, Loc)))),
3971
3972                       Then_Statements => New_List (
3973                         Make_Assignment_Statement (Loc,
3974                           Name       => New_Occurrence_Of (Bnn, Loc),
3975                           Expression =>
3976                             New_Occurrence_Of (Standard_False, Loc))),
3977
3978                       Else_Statements => New_List (
3979                         Make_Assignment_Statement (Loc,
3980                           Name => New_Occurrence_Of (Lnn, Loc),
3981                           Expression =>
3982                             Make_Function_Call (Loc,
3983                               Name                   =>
3984                                 New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
3985                               Parameter_Associations => New_List (
3986                                   New_Occurrence_Of (Nnn, Loc)))),
3987
3988                         Make_Assignment_Statement (Loc,
3989                           Name       => New_Occurrence_Of (Bnn, Loc),
3990                           Expression =>
3991                             Make_And_Then (Loc,
3992                               Left_Opnd  =>
3993                                 Make_In (Loc,
3994                                   Left_Opnd  => New_Occurrence_Of (Lnn, Loc),
3995                                   Right_Opnd =>
3996                                     Make_Range (Loc,
3997                                       Low_Bound  =>
3998                                         Convert_To (LLIB,
3999                                           Make_Attribute_Reference (Loc,
4000                                             Attribute_Name => Name_First,
4001                                             Prefix         =>
4002                                               New_Occurrence_Of (TB, Loc))),
4003
4004                                       High_Bound =>
4005                                         Convert_To (LLIB,
4006                                           Make_Attribute_Reference (Loc,
4007                                             Attribute_Name => Name_Last,
4008                                             Prefix         =>
4009                                               New_Occurrence_Of (TB, Loc))))),
4010
4011                               Right_Opnd => Nin))))));
4012
4013                --  Now we can do the rewrite
4014
4015                Rewrite (N,
4016                  Make_Expression_With_Actions (Loc,
4017                    Actions    => New_List (
4018                      Make_Object_Declaration (Loc,
4019                        Defining_Identifier => Bnn,
4020                        Object_Definition   =>
4021                          New_Occurrence_Of (Result_Type, Loc)),
4022                      Blk),
4023                    Expression => New_Occurrence_Of (Bnn, Loc)));
4024                Analyze_And_Resolve (N, Result_Type);
4025                return;
4026             end;
4027
4028          --  Not bignum case, but types don't match (this means we rewrote the
4029          --  left operand to be Long_Long_Integer).
4030
4031          else
4032             pragma Assert (Base_Type (Etype (Lop)) = LLIB);
4033
4034             --  We rewrite the membership test as (where T is the type with
4035             --  the predicate, i.e. the type of the right operand)
4036
4037             --    Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
4038             --      and then T'Base (Lop) in T
4039
4040             declare
4041                T   : constant Entity_Id := Etype (Rop);
4042                TB  : constant Entity_Id := Base_Type (T);
4043                Nin : Node_Id;
4044
4045             begin
4046                --  The last membership test is marked to prevent recursion
4047
4048                Nin :=
4049                  Make_In (Loc,
4050                    Left_Opnd  => Convert_To (TB, Duplicate_Subexpr (Lop)),
4051                    Right_Opnd => New_Occurrence_Of (T, Loc));
4052                Set_No_Minimize_Eliminate (Nin);
4053
4054                --  Now do the rewrite
4055
4056                Rewrite (N,
4057                  Make_And_Then (Loc,
4058                    Left_Opnd  =>
4059                      Make_In (Loc,
4060                        Left_Opnd  => Lop,
4061                        Right_Opnd =>
4062                          Make_Range (Loc,
4063                            Low_Bound  =>
4064                              Convert_To (LLIB,
4065                                Make_Attribute_Reference (Loc,
4066                                  Attribute_Name => Name_First,
4067                                  Prefix => New_Occurrence_Of (TB, Loc))),
4068                            High_Bound =>
4069                              Convert_To (LLIB,
4070                                Make_Attribute_Reference (Loc,
4071                                  Attribute_Name => Name_Last,
4072                                  Prefix => New_Occurrence_Of (TB, Loc))))),
4073                    Right_Opnd => Nin));
4074                Set_Analyzed (N, False);
4075                Analyze_And_Resolve (N, Restype);
4076             end;
4077          end if;
4078       end if;
4079    end Expand_Membership_Minimize_Eliminate_Overflow;
4080
4081    ------------------------
4082    -- Expand_N_Allocator --
4083    ------------------------
4084
4085    procedure Expand_N_Allocator (N : Node_Id) is
4086       Etyp : constant Entity_Id  := Etype (Expression (N));
4087       Loc  : constant Source_Ptr := Sloc (N);
4088       PtrT : constant Entity_Id  := Etype (N);
4089
4090       procedure Rewrite_Coextension (N : Node_Id);
4091       --  Static coextensions have the same lifetime as the entity they
4092       --  constrain. Such occurrences can be rewritten as aliased objects
4093       --  and their unrestricted access used instead of the coextension.
4094
4095       function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
4096       --  Given a constrained array type E, returns a node representing the
4097       --  code to compute the size in storage elements for the given type.
4098       --  This is done without using the attribute (which malfunctions for
4099       --  large sizes ???)
4100
4101       -------------------------
4102       -- Rewrite_Coextension --
4103       -------------------------
4104
4105       procedure Rewrite_Coextension (N : Node_Id) is
4106          Temp_Id   : constant Node_Id := Make_Temporary (Loc, 'C');
4107          Temp_Decl : Node_Id;
4108
4109       begin
4110          --  Generate:
4111          --    Cnn : aliased Etyp;
4112
4113          Temp_Decl :=
4114            Make_Object_Declaration (Loc,
4115              Defining_Identifier => Temp_Id,
4116              Aliased_Present     => True,
4117              Object_Definition   => New_Occurrence_Of (Etyp, Loc));
4118
4119          if Nkind (Expression (N)) = N_Qualified_Expression then
4120             Set_Expression (Temp_Decl, Expression (Expression (N)));
4121          end if;
4122
4123          Insert_Action (N, Temp_Decl);
4124          Rewrite (N,
4125            Make_Attribute_Reference (Loc,
4126              Prefix         => New_Occurrence_Of (Temp_Id, Loc),
4127              Attribute_Name => Name_Unrestricted_Access));
4128
4129          Analyze_And_Resolve (N, PtrT);
4130       end Rewrite_Coextension;
4131
4132       ------------------------------
4133       -- Size_In_Storage_Elements --
4134       ------------------------------
4135
4136       function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
4137       begin
4138          --  Logically this just returns E'Max_Size_In_Storage_Elements.
4139          --  However, the reason for the existence of this function is
4140          --  to construct a test for sizes too large, which means near the
4141          --  32-bit limit on a 32-bit machine, and precisely the trouble
4142          --  is that we get overflows when sizes are greater than 2**31.
4143
4144          --  So what we end up doing for array types is to use the expression:
4145
4146          --    number-of-elements * component_type'Max_Size_In_Storage_Elements
4147
4148          --  which avoids this problem. All this is a bit bogus, but it does
4149          --  mean we catch common cases of trying to allocate arrays that
4150          --  are too large, and which in the absence of a check results in
4151          --  undetected chaos ???
4152
4153          declare
4154             Len : Node_Id;
4155             Res : Node_Id;
4156
4157          begin
4158             for J in 1 .. Number_Dimensions (E) loop
4159                Len :=
4160                  Make_Attribute_Reference (Loc,
4161                    Prefix         => New_Occurrence_Of (E, Loc),
4162                    Attribute_Name => Name_Length,
4163                    Expressions    => New_List (Make_Integer_Literal (Loc, J)));
4164
4165                if J = 1 then
4166                   Res := Len;
4167
4168                else
4169                   Res :=
4170                     Make_Op_Multiply (Loc,
4171                       Left_Opnd  => Res,
4172                       Right_Opnd => Len);
4173                end if;
4174             end loop;
4175
4176             return
4177               Make_Op_Multiply (Loc,
4178                 Left_Opnd  => Len,
4179                 Right_Opnd =>
4180                   Make_Attribute_Reference (Loc,
4181                     Prefix => New_Occurrence_Of (Component_Type (E), Loc),
4182                     Attribute_Name => Name_Max_Size_In_Storage_Elements));
4183          end;
4184       end Size_In_Storage_Elements;
4185
4186       --  Local variables
4187
4188       Dtyp    : constant Entity_Id  := Available_View (Designated_Type (PtrT));
4189       Desig   : Entity_Id;
4190       Nod     : Node_Id;
4191       Pool    : Entity_Id;
4192       Rel_Typ : Entity_Id;
4193       Temp    : Entity_Id;
4194
4195    --  Start of processing for Expand_N_Allocator
4196
4197    begin
4198       --  RM E.2.3(22). We enforce that the expected type of an allocator
4199       --  shall not be a remote access-to-class-wide-limited-private type
4200
4201       --  Why is this being done at expansion time, seems clearly wrong ???
4202
4203       Validate_Remote_Access_To_Class_Wide_Type (N);
4204
4205       --  Processing for anonymous access-to-controlled types. These access
4206       --  types receive a special finalization master which appears in the
4207       --  declarations of the enclosing semantic unit. This expansion is done
4208       --  now to ensure that any additional types generated by this routine or
4209       --  Expand_Allocator_Expression inherit the proper type attributes.
4210
4211       if (Ekind (PtrT) = E_Anonymous_Access_Type
4212            or else (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
4213         and then Needs_Finalization (Dtyp)
4214       then
4215          --  Detect the allocation of an anonymous controlled object where the
4216          --  type of the context is named. For example:
4217
4218          --     procedure Proc (Ptr : Named_Access_Typ);
4219          --     Proc (new Designated_Typ);
4220
4221          --  Regardless of the anonymous-to-named access type conversion, the
4222          --  lifetime of the object must be associated with the named access
4223          --  type. Use the finalization-related attributes of this type.
4224
4225          if Nkind_In (Parent (N), N_Type_Conversion,
4226                                   N_Unchecked_Type_Conversion)
4227            and then Ekind_In (Etype (Parent (N)), E_Access_Subtype,
4228                                                   E_Access_Type,
4229                                                   E_General_Access_Type)
4230          then
4231             Rel_Typ := Etype (Parent (N));
4232          else
4233             Rel_Typ := Empty;
4234          end if;
4235
4236          --  Anonymous access-to-controlled types allocate on the global pool.
4237          --  Do not set this attribute on .NET/JVM since those targets do not
4238          --  support pools.
4239
4240          if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
4241             if Present (Rel_Typ) then
4242                Set_Associated_Storage_Pool (PtrT,
4243                  Associated_Storage_Pool (Rel_Typ));
4244             else
4245                Set_Associated_Storage_Pool (PtrT,
4246                  Get_Global_Pool_For_Access_Type (PtrT));
4247             end if;
4248          end if;
4249
4250          --  The finalization master must be inserted and analyzed as part of
4251          --  the current semantic unit. This form of expansion is not carried
4252          --  out in Alfa mode because it is useless. Note that the master is
4253          --  updated when analysis changes current units.
4254
4255          if not Alfa_Mode then
4256             if Present (Rel_Typ) then
4257                Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ));
4258             else
4259                Set_Finalization_Master (PtrT, Current_Anonymous_Master);
4260             end if;
4261          end if;
4262       end if;
4263
4264       --  Set the storage pool and find the appropriate version of Allocate to
4265       --  call. Do not overwrite the storage pool if it is already set, which
4266       --  can happen for build-in-place function returns (see
4267       --  Exp_Ch4.Expand_N_Extended_Return_Statement).
4268
4269       if No (Storage_Pool (N)) then
4270          Pool := Associated_Storage_Pool (Root_Type (PtrT));
4271
4272          if Present (Pool) then
4273             Set_Storage_Pool (N, Pool);
4274
4275             if Is_RTE (Pool, RE_SS_Pool) then
4276                if VM_Target = No_VM then
4277                   Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
4278                end if;
4279
4280             --  In the case of an allocator for a simple storage pool, locate
4281             --  and save a reference to the pool type's Allocate routine.
4282
4283             elsif Present (Get_Rep_Pragma
4284                              (Etype (Pool), Name_Simple_Storage_Pool_Type))
4285             then
4286                declare
4287                   Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
4288                   Alloc_Op  : Entity_Id;
4289                begin
4290                   Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
4291                   while Present (Alloc_Op) loop
4292                      if Scope (Alloc_Op) = Scope (Pool_Type)
4293                        and then Present (First_Formal (Alloc_Op))
4294                        and then Etype (First_Formal (Alloc_Op)) = Pool_Type
4295                      then
4296                         Set_Procedure_To_Call (N, Alloc_Op);
4297                         exit;
4298                      else
4299                         Alloc_Op := Homonym (Alloc_Op);
4300                      end if;
4301                   end loop;
4302                end;
4303
4304             elsif Is_Class_Wide_Type (Etype (Pool)) then
4305                Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
4306
4307             else
4308                Set_Procedure_To_Call (N,
4309                  Find_Prim_Op (Etype (Pool), Name_Allocate));
4310             end if;
4311          end if;
4312       end if;
4313
4314       --  Under certain circumstances we can replace an allocator by an access
4315       --  to statically allocated storage. The conditions, as noted in AARM
4316       --  3.10 (10c) are as follows:
4317
4318       --    Size and initial value is known at compile time
4319       --    Access type is access-to-constant
4320
4321       --  The allocator is not part of a constraint on a record component,
4322       --  because in that case the inserted actions are delayed until the
4323       --  record declaration is fully analyzed, which is too late for the
4324       --  analysis of the rewritten allocator.
4325
4326       if Is_Access_Constant (PtrT)
4327         and then Nkind (Expression (N)) = N_Qualified_Expression
4328         and then Compile_Time_Known_Value (Expression (Expression (N)))
4329         and then Size_Known_At_Compile_Time
4330                    (Etype (Expression (Expression (N))))
4331         and then not Is_Record_Type (Current_Scope)
4332       then
4333          --  Here we can do the optimization. For the allocator
4334
4335          --    new x'(y)
4336
4337          --  We insert an object declaration
4338
4339          --    Tnn : aliased x := y;
4340
4341          --  and replace the allocator by Tnn'Unrestricted_Access. Tnn is
4342          --  marked as requiring static allocation.
4343
4344          Temp  := Make_Temporary (Loc, 'T', Expression (Expression (N)));
4345          Desig := Subtype_Mark (Expression (N));
4346
4347          --  If context is constrained, use constrained subtype directly,
4348          --  so that the constant is not labelled as having a nominally
4349          --  unconstrained subtype.
4350
4351          if Entity (Desig) = Base_Type (Dtyp) then
4352             Desig := New_Occurrence_Of (Dtyp, Loc);
4353          end if;
4354
4355          Insert_Action (N,
4356            Make_Object_Declaration (Loc,
4357              Defining_Identifier => Temp,
4358              Aliased_Present     => True,
4359              Constant_Present    => Is_Access_Constant (PtrT),
4360              Object_Definition   => Desig,
4361              Expression          => Expression (Expression (N))));
4362
4363          Rewrite (N,
4364            Make_Attribute_Reference (Loc,
4365              Prefix         => New_Occurrence_Of (Temp, Loc),
4366              Attribute_Name => Name_Unrestricted_Access));
4367
4368          Analyze_And_Resolve (N, PtrT);
4369
4370          --  We set the variable as statically allocated, since we don't want
4371          --  it going on the stack of the current procedure!
4372
4373          Set_Is_Statically_Allocated (Temp);
4374          return;
4375       end if;
4376
4377       --  Same if the allocator is an access discriminant for a local object:
4378       --  instead of an allocator we create a local value and constrain the
4379       --  enclosing object with the corresponding access attribute.
4380
4381       if Is_Static_Coextension (N) then
4382          Rewrite_Coextension (N);
4383          return;
4384       end if;
4385
4386       --  Check for size too large, we do this because the back end misses
4387       --  proper checks here and can generate rubbish allocation calls when
4388       --  we are near the limit. We only do this for the 32-bit address case
4389       --  since that is from a practical point of view where we see a problem.
4390
4391       if System_Address_Size = 32
4392         and then not Storage_Checks_Suppressed (PtrT)
4393         and then not Storage_Checks_Suppressed (Dtyp)
4394         and then not Storage_Checks_Suppressed (Etyp)
4395       then
4396          --  The check we want to generate should look like
4397
4398          --  if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
4399          --    raise Storage_Error;
4400          --  end if;
4401
4402          --  where 3.5 gigabytes is a constant large enough to accommodate any
4403          --  reasonable request for. But we can't do it this way because at
4404          --  least at the moment we don't compute this attribute right, and
4405          --  can silently give wrong results when the result gets large. Since
4406          --  this is all about large results, that's bad, so instead we only
4407          --  apply the check for constrained arrays, and manually compute the
4408          --  value of the attribute ???
4409
4410          if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
4411             Insert_Action (N,
4412               Make_Raise_Storage_Error (Loc,
4413                 Condition =>
4414                   Make_Op_Gt (Loc,
4415                     Left_Opnd  => Size_In_Storage_Elements (Etyp),
4416                     Right_Opnd =>
4417                       Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
4418                 Reason    => SE_Object_Too_Large));
4419          end if;
4420       end if;
4421
4422       --  Handle case of qualified expression (other than optimization above)
4423       --  First apply constraint checks, because the bounds or discriminants
4424       --  in the aggregate might not match the subtype mark in the allocator.
4425
4426       if Nkind (Expression (N)) = N_Qualified_Expression then
4427          Apply_Constraint_Check
4428            (Expression (Expression (N)), Etype (Expression (N)));
4429
4430          Expand_Allocator_Expression (N);
4431          return;
4432       end if;
4433
4434       --  If the allocator is for a type which requires initialization, and
4435       --  there is no initial value (i.e. operand is a subtype indication
4436       --  rather than a qualified expression), then we must generate a call to
4437       --  the initialization routine using an expressions action node:
4438
4439       --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
4440
4441       --  Here ptr_T is the pointer type for the allocator, and T is the
4442       --  subtype of the allocator. A special case arises if the designated
4443       --  type of the access type is a task or contains tasks. In this case
4444       --  the call to Init (Temp.all ...) is replaced by code that ensures
4445       --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
4446       --  for details). In addition, if the type T is a task T, then the
4447       --  first argument to Init must be converted to the task record type.
4448
4449       declare
4450          T         : constant Entity_Id := Entity (Expression (N));
4451          Args      : List_Id;
4452          Decls     : List_Id;
4453          Decl      : Node_Id;
4454          Discr     : Elmt_Id;
4455          Init      : Entity_Id;
4456          Init_Arg1 : Node_Id;
4457          Temp_Decl : Node_Id;
4458          Temp_Type : Entity_Id;
4459
4460       begin
4461          if No_Initialization (N) then
4462
4463             --  Even though this might be a simple allocation, create a custom
4464             --  Allocate if the context requires it. Since .NET/JVM compilers
4465             --  do not support pools, this step is skipped.
4466
4467             if VM_Target = No_VM
4468               and then Present (Finalization_Master (PtrT))
4469             then
4470                Build_Allocate_Deallocate_Proc
4471                  (N           => N,
4472                   Is_Allocate => True);
4473             end if;
4474
4475          --  Case of no initialization procedure present
4476
4477          elsif not Has_Non_Null_Base_Init_Proc (T) then
4478
4479             --  Case of simple initialization required
4480
4481             if Needs_Simple_Initialization (T) then
4482                Check_Restriction (No_Default_Initialization, N);
4483                Rewrite (Expression (N),
4484                  Make_Qualified_Expression (Loc,
4485                    Subtype_Mark => New_Occurrence_Of (T, Loc),
4486                    Expression   => Get_Simple_Init_Val (T, N)));
4487
4488                Analyze_And_Resolve (Expression (Expression (N)), T);
4489                Analyze_And_Resolve (Expression (N), T);
4490                Set_Paren_Count     (Expression (Expression (N)), 1);
4491                Expand_N_Allocator  (N);
4492
4493             --  No initialization required
4494
4495             else
4496                null;
4497             end if;
4498
4499          --  Case of initialization procedure present, must be called
4500
4501          else
4502             Check_Restriction (No_Default_Initialization, N);
4503
4504             if not Restriction_Active (No_Default_Initialization) then
4505                Init := Base_Init_Proc (T);
4506                Nod  := N;
4507                Temp := Make_Temporary (Loc, 'P');
4508
4509                --  Construct argument list for the initialization routine call
4510
4511                Init_Arg1 :=
4512                  Make_Explicit_Dereference (Loc,
4513                    Prefix =>
4514                      New_Reference_To (Temp, Loc));
4515
4516                Set_Assignment_OK (Init_Arg1);
4517                Temp_Type := PtrT;
4518
4519                --  The initialization procedure expects a specific type. if the
4520                --  context is access to class wide, indicate that the object
4521                --  being allocated has the right specific type.
4522
4523                if Is_Class_Wide_Type (Dtyp) then
4524                   Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
4525                end if;
4526
4527                --  If designated type is a concurrent type or if it is private
4528                --  type whose definition is a concurrent type, the first
4529                --  argument in the Init routine has to be unchecked conversion
4530                --  to the corresponding record type. If the designated type is
4531                --  a derived type, also convert the argument to its root type.
4532
4533                if Is_Concurrent_Type (T) then
4534                   Init_Arg1 :=
4535                     Unchecked_Convert_To (
4536                       Corresponding_Record_Type (T), Init_Arg1);
4537
4538                elsif Is_Private_Type (T)
4539                  and then Present (Full_View (T))
4540                  and then Is_Concurrent_Type (Full_View (T))
4541                then
4542                   Init_Arg1 :=
4543                     Unchecked_Convert_To
4544                       (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
4545
4546                elsif Etype (First_Formal (Init)) /= Base_Type (T) then
4547                   declare
4548                      Ftyp : constant Entity_Id := Etype (First_Formal (Init));
4549
4550                   begin
4551                      Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
4552                      Set_Etype (Init_Arg1, Ftyp);
4553                   end;
4554                end if;
4555
4556                Args := New_List (Init_Arg1);
4557
4558                --  For the task case, pass the Master_Id of the access type as
4559                --  the value of the _Master parameter, and _Chain as the value
4560                --  of the _Chain parameter (_Chain will be defined as part of
4561                --  the generated code for the allocator).
4562
4563                --  In Ada 2005, the context may be a function that returns an
4564                --  anonymous access type. In that case the Master_Id has been
4565                --  created when expanding the function declaration.
4566
4567                if Has_Task (T) then
4568                   if No (Master_Id (Base_Type (PtrT))) then
4569
4570                      --  The designated type was an incomplete type, and the
4571                      --  access type did not get expanded. Salvage it now.
4572
4573                      if not Restriction_Active (No_Task_Hierarchy) then
4574                         pragma Assert (Present (Parent (Base_Type (PtrT))));
4575                         Expand_N_Full_Type_Declaration
4576                           (Parent (Base_Type (PtrT)));
4577                      end if;
4578                   end if;
4579
4580                   --  If the context of the allocator is a declaration or an
4581                   --  assignment, we can generate a meaningful image for it,
4582                   --  even though subsequent assignments might remove the
4583                   --  connection between task and entity. We build this image
4584                   --  when the left-hand side is a simple variable, a simple
4585                   --  indexed assignment or a simple selected component.
4586
4587                   if Nkind (Parent (N)) = N_Assignment_Statement then
4588                      declare
4589                         Nam : constant Node_Id := Name (Parent (N));
4590
4591                      begin
4592                         if Is_Entity_Name (Nam) then
4593                            Decls :=
4594                              Build_Task_Image_Decls
4595                                (Loc,
4596                                 New_Occurrence_Of
4597                                   (Entity (Nam), Sloc (Nam)), T);
4598
4599                         elsif Nkind_In (Nam, N_Indexed_Component,
4600                                              N_Selected_Component)
4601                           and then Is_Entity_Name (Prefix (Nam))
4602                         then
4603                            Decls :=
4604                              Build_Task_Image_Decls
4605                                (Loc, Nam, Etype (Prefix (Nam)));
4606                         else
4607                            Decls := Build_Task_Image_Decls (Loc, T, T);
4608                         end if;
4609                      end;
4610
4611                   elsif Nkind (Parent (N)) = N_Object_Declaration then
4612                      Decls :=
4613                        Build_Task_Image_Decls
4614                          (Loc, Defining_Identifier (Parent (N)), T);
4615
4616                   else
4617                      Decls := Build_Task_Image_Decls (Loc, T, T);
4618                   end if;
4619
4620                   if Restriction_Active (No_Task_Hierarchy) then
4621                      Append_To (Args,
4622                        New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
4623                   else
4624                      Append_To (Args,
4625                        New_Reference_To
4626                          (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
4627                   end if;
4628
4629                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
4630
4631                   Decl := Last (Decls);
4632                   Append_To (Args,
4633                     New_Occurrence_Of (Defining_Identifier (Decl), Loc));
4634
4635                --  Has_Task is false, Decls not used
4636
4637                else
4638                   Decls := No_List;
4639                end if;
4640
4641                --  Add discriminants if discriminated type
4642
4643                declare
4644                   Dis : Boolean := False;
4645                   Typ : Entity_Id;
4646
4647                begin
4648                   if Has_Discriminants (T) then
4649                      Dis := True;
4650                      Typ := T;
4651
4652                   elsif Is_Private_Type (T)
4653                     and then Present (Full_View (T))
4654                     and then Has_Discriminants (Full_View (T))
4655                   then
4656                      Dis := True;
4657                      Typ := Full_View (T);
4658                   end if;
4659
4660                   if Dis then
4661
4662                      --  If the allocated object will be constrained by the
4663                      --  default values for discriminants, then build a subtype
4664                      --  with those defaults, and change the allocated subtype
4665                      --  to that. Note that this happens in fewer cases in Ada
4666                      --  2005 (AI-363).
4667
4668                      if not Is_Constrained (Typ)
4669                        and then Present (Discriminant_Default_Value
4670                                           (First_Discriminant (Typ)))
4671                        and then (Ada_Version < Ada_2005
4672                                   or else not
4673                                     Effectively_Has_Constrained_Partial_View
4674                                       (Typ  => Typ,
4675                                        Scop => Current_Scope))
4676                      then
4677                         Typ := Build_Default_Subtype (Typ, N);
4678                         Set_Expression (N, New_Reference_To (Typ, Loc));
4679                      end if;
4680
4681                      Discr := First_Elmt (Discriminant_Constraint (Typ));
4682                      while Present (Discr) loop
4683                         Nod := Node (Discr);
4684                         Append (New_Copy_Tree (Node (Discr)), Args);
4685
4686                         --  AI-416: when the discriminant constraint is an
4687                         --  anonymous access type make sure an accessibility
4688                         --  check is inserted if necessary (3.10.2(22.q/2))
4689
4690                         if Ada_Version >= Ada_2005
4691                           and then
4692                             Ekind (Etype (Nod)) = E_Anonymous_Access_Type
4693                         then
4694                            Apply_Accessibility_Check
4695                              (Nod, Typ, Insert_Node => Nod);
4696                         end if;
4697
4698                         Next_Elmt (Discr);
4699                      end loop;
4700                   end if;
4701                end;
4702
4703                --  We set the allocator as analyzed so that when we analyze
4704                --  the if expression node, we do not get an unwanted recursive
4705                --  expansion of the allocator expression.
4706
4707                Set_Analyzed (N, True);
4708                Nod := Relocate_Node (N);
4709
4710                --  Here is the transformation:
4711                --    input:  new Ctrl_Typ
4712                --    output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
4713                --            Ctrl_TypIP (Temp.all, ...);
4714                --            [Deep_]Initialize (Temp.all);
4715
4716                --  Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
4717                --  is the subtype of the allocator.
4718
4719                Temp_Decl :=
4720                  Make_Object_Declaration (Loc,
4721                    Defining_Identifier => Temp,
4722                    Constant_Present    => True,
4723                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
4724                    Expression          => Nod);
4725
4726                Set_Assignment_OK (Temp_Decl);
4727                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
4728
4729                Build_Allocate_Deallocate_Proc (Temp_Decl, True);
4730
4731                --  If the designated type is a task type or contains tasks,
4732                --  create block to activate created tasks, and insert
4733                --  declaration for Task_Image variable ahead of call.
4734
4735                if Has_Task (T) then
4736                   declare
4737                      L   : constant List_Id := New_List;
4738                      Blk : Node_Id;
4739                   begin
4740                      Build_Task_Allocate_Block (L, Nod, Args);
4741                      Blk := Last (L);
4742                      Insert_List_Before (First (Declarations (Blk)), Decls);
4743                      Insert_Actions (N, L);
4744                   end;
4745
4746                else
4747                   Insert_Action (N,
4748                     Make_Procedure_Call_Statement (Loc,
4749                       Name                   => New_Reference_To (Init, Loc),
4750                       Parameter_Associations => Args));
4751                end if;
4752
4753                if Needs_Finalization (T) then
4754
4755                   --  Generate:
4756                   --    [Deep_]Initialize (Init_Arg1);
4757
4758                   Insert_Action (N,
4759                     Make_Init_Call
4760                       (Obj_Ref => New_Copy_Tree (Init_Arg1),
4761                        Typ     => T));
4762
4763                   if Present (Finalization_Master (PtrT)) then
4764
4765                      --  Special processing for .NET/JVM, the allocated object
4766                      --  is attached to the finalization master. Generate:
4767
4768                      --    Attach (<PtrT>FM, Root_Controlled_Ptr (Init_Arg1));
4769
4770                      --  Types derived from [Limited_]Controlled are the only
4771                      --  ones considered since they have fields Prev and Next.
4772
4773                      if VM_Target /= No_VM then
4774                         if Is_Controlled (T) then
4775                            Insert_Action (N,
4776                              Make_Attach_Call
4777                                (Obj_Ref => New_Copy_Tree (Init_Arg1),
4778                                 Ptr_Typ => PtrT));
4779                         end if;
4780
4781                      --  Default case, generate:
4782
4783                      --    Set_Finalize_Address
4784                      --      (<PtrT>FM, <T>FD'Unrestricted_Access);
4785
4786                      --  Do not generate this call in the following cases:
4787                      --
4788                      --    * Alfa mode - the call is useless and results in
4789                      --    unwanted expansion.
4790                      --
4791                      --    * CodePeer mode - TSS primitive Finalize_Address is
4792                      --    not created in this mode.
4793
4794                      elsif not (Alfa_Mode or CodePeer_Mode) then
4795                         Insert_Action (N,
4796                           Make_Set_Finalize_Address_Call
4797                             (Loc     => Loc,
4798                              Typ     => T,
4799                              Ptr_Typ => PtrT));
4800                      end if;
4801                   end if;
4802                end if;
4803
4804                Rewrite (N, New_Reference_To (Temp, Loc));
4805                Analyze_And_Resolve (N, PtrT);
4806             end if;
4807          end if;
4808       end;
4809
4810       --  Ada 2005 (AI-251): If the allocator is for a class-wide interface
4811       --  object that has been rewritten as a reference, we displace "this"
4812       --  to reference properly its secondary dispatch table.
4813
4814       if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
4815          Displace_Allocator_Pointer (N);
4816       end if;
4817
4818    exception
4819       when RE_Not_Available =>
4820          return;
4821    end Expand_N_Allocator;
4822
4823    -----------------------
4824    -- Expand_N_And_Then --
4825    -----------------------
4826
4827    procedure Expand_N_And_Then (N : Node_Id)
4828      renames Expand_Short_Circuit_Operator;
4829
4830    ------------------------------
4831    -- Expand_N_Case_Expression --
4832    ------------------------------
4833
4834    procedure Expand_N_Case_Expression (N : Node_Id) is
4835       Loc     : constant Source_Ptr := Sloc (N);
4836       Typ     : constant Entity_Id  := Etype (N);
4837       Cstmt   : Node_Id;
4838       Tnn     : Entity_Id;
4839       Pnn     : Entity_Id;
4840       Actions : List_Id;
4841       Ttyp    : Entity_Id;
4842       Alt     : Node_Id;
4843       Fexp    : Node_Id;
4844
4845    begin
4846       --  Check for MINIMIZED/ELIMINATED overflow mode
4847
4848       if Minimized_Eliminated_Overflow_Check (N) then
4849          Apply_Arithmetic_Overflow_Check (N);
4850          return;
4851       end if;
4852
4853       --  We expand
4854
4855       --    case X is when A => AX, when B => BX ...
4856
4857       --  to
4858
4859       --    do
4860       --       Tnn : typ;
4861       --       case X is
4862       --          when A =>
4863       --             Tnn := AX;
4864       --          when B =>
4865       --             Tnn := BX;
4866       --          ...
4867       --       end case;
4868       --    in Tnn end;
4869
4870       --  However, this expansion is wrong for limited types, and also
4871       --  wrong for unconstrained types (since the bounds may not be the
4872       --  same in all branches). Furthermore it involves an extra copy
4873       --  for large objects. So we take care of this by using the following
4874       --  modified expansion for non-elementary types:
4875
4876       --    do
4877       --       type Pnn is access all typ;
4878       --       Tnn : Pnn;
4879       --       case X is
4880       --          when A =>
4881       --             T := AX'Unrestricted_Access;
4882       --          when B =>
4883       --             T := BX'Unrestricted_Access;
4884       --          ...
4885       --       end case;
4886       --    in Tnn.all end;
4887
4888       Cstmt :=
4889         Make_Case_Statement (Loc,
4890           Expression   => Expression (N),
4891           Alternatives => New_List);
4892
4893       Actions := New_List;
4894
4895       --  Scalar case
4896
4897       if Is_Elementary_Type (Typ) then
4898          Ttyp := Typ;
4899
4900       else
4901          Pnn := Make_Temporary (Loc, 'P');
4902          Append_To (Actions,
4903            Make_Full_Type_Declaration (Loc,
4904              Defining_Identifier => Pnn,
4905              Type_Definition =>
4906                Make_Access_To_Object_Definition (Loc,
4907                  All_Present => True,
4908                  Subtype_Indication =>
4909                    New_Reference_To (Typ, Loc))));
4910          Ttyp := Pnn;
4911       end if;
4912
4913       Tnn := Make_Temporary (Loc, 'T');
4914       Append_To (Actions,
4915         Make_Object_Declaration (Loc,
4916           Defining_Identifier => Tnn,
4917           Object_Definition   => New_Occurrence_Of (Ttyp, Loc)));
4918
4919       --  Now process the alternatives
4920
4921       Alt := First (Alternatives (N));
4922       while Present (Alt) loop
4923          declare
4924             Aexp  : Node_Id             := Expression (Alt);
4925             Aloc  : constant Source_Ptr := Sloc (Aexp);
4926             Stats : List_Id;
4927
4928          begin
4929             --  As described above, take Unrestricted_Access for case of non-
4930             --  scalar types, to avoid big copies, and special cases.
4931
4932             if not Is_Elementary_Type (Typ) then
4933                Aexp :=
4934                  Make_Attribute_Reference (Aloc,
4935                    Prefix         => Relocate_Node (Aexp),
4936                    Attribute_Name => Name_Unrestricted_Access);
4937             end if;
4938
4939             Stats := New_List (
4940               Make_Assignment_Statement (Aloc,
4941                 Name       => New_Occurrence_Of (Tnn, Loc),
4942                 Expression => Aexp));
4943
4944             --  Propagate declarations inserted in the node by Insert_Actions
4945             --  (for example, temporaries generated to remove side effects).
4946             --  These actions must remain attached to the alternative, given
4947             --  that they are generated by the corresponding expression.
4948
4949             if Present (Sinfo.Actions (Alt)) then
4950                Prepend_List (Sinfo.Actions (Alt), Stats);
4951             end if;
4952
4953             Append_To
4954               (Alternatives (Cstmt),
4955                Make_Case_Statement_Alternative (Sloc (Alt),
4956                  Discrete_Choices => Discrete_Choices (Alt),
4957                  Statements       => Stats));
4958          end;
4959
4960          Next (Alt);
4961       end loop;
4962
4963       Append_To (Actions, Cstmt);
4964
4965       --  Construct and return final expression with actions
4966
4967       if Is_Elementary_Type (Typ) then
4968          Fexp := New_Occurrence_Of (Tnn, Loc);
4969       else
4970          Fexp :=
4971            Make_Explicit_Dereference (Loc,
4972              Prefix => New_Occurrence_Of (Tnn, Loc));
4973       end if;
4974
4975       Rewrite (N,
4976         Make_Expression_With_Actions (Loc,
4977           Expression => Fexp,
4978           Actions    => Actions));
4979
4980       Analyze_And_Resolve (N, Typ);
4981    end Expand_N_Case_Expression;
4982
4983    -----------------------------------
4984    -- Expand_N_Explicit_Dereference --
4985    -----------------------------------
4986
4987    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
4988    begin
4989       --  Insert explicit dereference call for the checked storage pool case
4990
4991       Insert_Dereference_Action (Prefix (N));
4992
4993       --  If the type is an Atomic type for which Atomic_Sync is enabled, then
4994       --  we set the atomic sync flag.
4995
4996       if Is_Atomic (Etype (N))
4997         and then not Atomic_Synchronization_Disabled (Etype (N))
4998       then
4999          Activate_Atomic_Synchronization (N);
5000       end if;
5001    end Expand_N_Explicit_Dereference;
5002
5003    --------------------------------------
5004    -- Expand_N_Expression_With_Actions --
5005    --------------------------------------
5006
5007    procedure Expand_N_Expression_With_Actions (N : Node_Id) is
5008       In_Case_Or_If_Expression : constant Boolean :=
5009                                    Within_Case_Or_If_Expression (N);
5010
5011       function Process_Action (Act : Node_Id) return Traverse_Result;
5012       --  Inspect and process a single action of an expression_with_actions
5013
5014       --------------------
5015       -- Process_Action --
5016       --------------------
5017
5018       function Process_Action (Act : Node_Id) return Traverse_Result is
5019          procedure Process_Transient_Object (Obj_Decl : Node_Id);
5020          --  Obj_Decl denotes the declaration of a transient controlled object.
5021          --  Generate all necessary types and hooks to properly finalize the
5022          --  result when the enclosing context is elaborated/evaluated.
5023
5024          ------------------------------
5025          -- Process_Transient_Object --
5026          ------------------------------
5027
5028          procedure Process_Transient_Object (Obj_Decl : Node_Id) is
5029             function Find_Enclosing_Context return Node_Id;
5030             --  Find the context where the expression_with_actions appears
5031
5032             ----------------------------
5033             -- Find_Enclosing_Context --
5034             ----------------------------
5035
5036             function Find_Enclosing_Context return Node_Id is
5037                function Is_Body_Or_Unit (N : Node_Id) return Boolean;
5038                --  Determine whether N denotes a body or unit declaration
5039
5040                ---------------------
5041                -- Is_Body_Or_Unit --
5042                ---------------------
5043
5044                function Is_Body_Or_Unit (N : Node_Id) return Boolean is
5045                begin
5046                   return Nkind_In (N, N_Entry_Body,
5047                                       N_Package_Body,
5048                                       N_Package_Declaration,
5049                                       N_Protected_Body,
5050                                       N_Subprogram_Body,
5051                                       N_Task_Body);
5052                end Is_Body_Or_Unit;
5053
5054                --  Local variables
5055
5056                Par : Node_Id;
5057                Top : Node_Id;
5058
5059             --  Start of processing for Find_Enclosing_Context
5060
5061             begin
5062                --  The expression_with_actions is in a case/if expression and
5063                --  the lifetime of any temporary controlled object is therefore
5064                --  extended. Find a suitable insertion node by locating the top
5065                --  most case or if expressions.
5066
5067                if In_Case_Or_If_Expression then
5068                   Par := N;
5069                   Top := N;
5070                   while Present (Par) loop
5071                      if Nkind_In (Original_Node (Par), N_Case_Expression,
5072                                                        N_If_Expression)
5073                      then
5074                         Top := Par;
5075
5076                      --  Prevent the search from going too far
5077
5078                      elsif Is_Body_Or_Unit (Par) then
5079                         exit;
5080                      end if;
5081
5082                      Par := Parent (Par);
5083                   end loop;
5084
5085                   --  The topmost case or if expression is now recovered, but
5086                   --  it may still not be the correct place to add all the
5087                   --  generated code. Climb to find a parent that is part of a
5088                   --  declarative or statement list.
5089
5090                   Par := Top;
5091                   while Present (Par) loop
5092                      if Is_List_Member (Par)
5093                        and then
5094                          not Nkind_In (Par, N_Component_Association,
5095                                             N_Discriminant_Association,
5096                                             N_Parameter_Association,
5097                                             N_Pragma_Argument_Association)
5098                      then
5099                         return Par;
5100
5101                      --  Prevent the search from going too far
5102
5103                      elsif Is_Body_Or_Unit (Par) then
5104                         exit;
5105                      end if;
5106
5107                      Par := Parent (Par);
5108                   end loop;
5109
5110                   return Par;
5111
5112                --  Short circuit operators in complex expressions are converted
5113                --  into expression_with_actions.
5114
5115                else
5116                   --  Take care of the case where the expression_with_actions
5117                   --  is buried deep inside an IF statement. The temporary
5118                   --  function result must be finalized before the then, elsif
5119                   --  or else statements are evaluated.
5120
5121                   --    if Something
5122                   --      and then Ctrl_Func_Call
5123                   --    then
5124                   --       <result must be finalized at this point>
5125                   --       <statements>
5126                   --    end if;
5127
5128                   --  To achieve this, find the topmost logical operator. The
5129                   --  generated actions are then inserted before/after it.
5130
5131                   Par := N;
5132                   while Present (Par) loop
5133
5134                      --  Keep climbing past various operators
5135
5136                      if Nkind (Parent (Par)) in N_Op
5137                        or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
5138                      then
5139                         Par := Parent (Par);
5140                      else
5141                         exit;
5142                      end if;
5143                   end loop;
5144
5145                   Top := Par;
5146
5147                   --  The expression_with_actions might be located in a pragma
5148                   --  in which case locate the pragma itself:
5149
5150                   --    pragma Precondition (... and then Ctrl_Func_Call ...);
5151
5152                   --  Similar case occurs when the expression_with_actions is
5153                   --  related to an object declaration or assignment:
5154
5155                   --    Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
5156
5157                   --  Another case to consider is an expression_with_actions as
5158                   --  part of a return statement:
5159
5160                   --    return ... and then Ctrl_Func_Call ...;
5161
5162                   --  Yet another case: a formal in a procedure call statement:
5163
5164                   --    Proc (... and then Ctrl_Func_Call ...);
5165
5166                   while Present (Par) loop
5167                      if Nkind_In (Par, N_Assignment_Statement,
5168                                        N_Object_Declaration,
5169                                        N_Pragma,
5170                                        N_Simple_Return_Statement,
5171                                        N_Procedure_Call_Statement)
5172                      then
5173                         return Par;
5174
5175                      elsif Is_Body_Or_Unit (Par) then
5176                         exit;
5177                      end if;
5178
5179                      Par := Parent (Par);
5180                   end loop;
5181
5182                   --  Return the topmost short circuit operator
5183
5184                   return Top;
5185                end if;
5186             end Find_Enclosing_Context;
5187
5188             --  Local variables
5189
5190             Context   : constant Node_Id    := Find_Enclosing_Context;
5191             Loc       : constant Source_Ptr := Sloc (Obj_Decl);
5192             Obj_Id    : constant Entity_Id  := Defining_Identifier (Obj_Decl);
5193             Obj_Typ   : constant Node_Id    := Etype (Obj_Id);
5194             Desig_Typ : Entity_Id;
5195             Expr      : Node_Id;
5196             Ptr_Id    : Entity_Id;
5197             Temp_Id   : Entity_Id;
5198
5199          --  Start of processing for Process_Transient_Object
5200
5201          begin
5202             --  Step 1: Create the access type which provides a reference to
5203             --  the transient object.
5204
5205             if Is_Access_Type (Obj_Typ) then
5206                Desig_Typ := Directly_Designated_Type (Obj_Typ);
5207             else
5208                Desig_Typ := Obj_Typ;
5209             end if;
5210
5211             Desig_Typ := Base_Type (Desig_Typ);
5212
5213             --  Generate:
5214             --    Ann : access [all] <Desig_Typ>;
5215
5216             Ptr_Id := Make_Temporary (Loc, 'A');
5217
5218             Insert_Action (Context,
5219               Make_Full_Type_Declaration (Loc,
5220                 Defining_Identifier => Ptr_Id,
5221                 Type_Definition     =>
5222                   Make_Access_To_Object_Definition (Loc,
5223                     All_Present        =>
5224                       Ekind (Obj_Typ) = E_General_Access_Type,
5225                     Subtype_Indication => New_Reference_To (Desig_Typ, Loc))));
5226
5227             --  Step 2: Create a temporary which acts as a hook to the
5228             --  transient object. Generate:
5229
5230             --    Temp : Ptr_Id := null;
5231
5232             Temp_Id := Make_Temporary (Loc, 'T');
5233
5234             Insert_Action (Context,
5235               Make_Object_Declaration (Loc,
5236                 Defining_Identifier => Temp_Id,
5237                 Object_Definition   => New_Reference_To (Ptr_Id, Loc)));
5238
5239             --  Mark this temporary as created for the purposes of exporting
5240             --  the transient declaration out of the Actions list. This signals
5241             --  the machinery in Build_Finalizer to recognize this special
5242             --  case.
5243
5244             Set_Status_Flag_Or_Transient_Decl (Temp_Id, Obj_Decl);
5245
5246             --  Step 3: Hook the transient object to the temporary
5247
5248             if Is_Access_Type (Obj_Typ) then
5249
5250                --  Why is this an unchecked conversion ???
5251                Expr :=
5252                  Unchecked_Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
5253             else
5254                Expr :=
5255                  Make_Attribute_Reference (Loc,
5256                    Prefix         => New_Reference_To (Obj_Id, Loc),
5257                    Attribute_Name => Name_Unrestricted_Access);
5258             end if;
5259
5260             --  Generate:
5261             --    Temp := Ptr_Id (Obj_Id);
5262             --      <or>
5263             --    Temp := Obj_Id'Unrestricted_Access;
5264
5265             Insert_After_And_Analyze (Obj_Decl,
5266               Make_Assignment_Statement (Loc,
5267                 Name       => New_Reference_To (Temp_Id, Loc),
5268                 Expression => Expr));
5269
5270             --  Step 4: Finalize the function result after the context has been
5271             --  evaluated/elaborated. Generate:
5272
5273             --    if Temp /= null then
5274             --       [Deep_]Finalize (Temp.all);
5275             --       Temp := null;
5276             --    end if;
5277
5278             --  When the expression_with_actions is part of a return statement,
5279             --  there is no need to insert a finalization call, as the general
5280             --  finalization mechanism (see Build_Finalizer) would take care of
5281             --  the temporary function result on subprogram exit. Note that it
5282             --  would also be impossible to insert the finalization code after
5283             --  the return statement as this would make it unreachable.
5284
5285             if Nkind (Context) /= N_Simple_Return_Statement then
5286                Insert_Action_After (Context,
5287                  Make_Implicit_If_Statement (Obj_Decl,
5288                    Condition =>
5289                      Make_Op_Ne (Loc,
5290                        Left_Opnd  => New_Reference_To (Temp_Id, Loc),
5291                        Right_Opnd => Make_Null (Loc)),
5292
5293                    Then_Statements => New_List (
5294                      Make_Final_Call
5295                        (Obj_Ref =>
5296                           Make_Explicit_Dereference (Loc,
5297                             Prefix => New_Reference_To (Temp_Id, Loc)),
5298                         Typ     => Desig_Typ),
5299
5300                      Make_Assignment_Statement (Loc,
5301                        Name       => New_Reference_To (Temp_Id, Loc),
5302                        Expression => Make_Null (Loc)))));
5303             end if;
5304          end Process_Transient_Object;
5305
5306       --  Start of processing for Process_Action
5307
5308       begin
5309          if Nkind (Act) = N_Object_Declaration
5310            and then Is_Finalizable_Transient (Act, N)
5311          then
5312             Process_Transient_Object (Act);
5313
5314          --  Avoid processing temporary function results multiple times when
5315          --  dealing with nested expression_with_actions.
5316
5317          elsif Nkind (Act) = N_Expression_With_Actions then
5318             return Abandon;
5319
5320          --  Do not process temporary function results in loops. This is
5321          --  done by Expand_N_Loop_Statement and Build_Finalizer.
5322
5323          elsif Nkind (Act) = N_Loop_Statement then
5324             return Abandon;
5325          end if;
5326
5327          return OK;
5328       end Process_Action;
5329
5330       procedure Process_Single_Action is new Traverse_Proc (Process_Action);
5331
5332       --  Local variables
5333
5334       Act : Node_Id;
5335
5336    --  Start of processing for Expand_N_Expression_With_Actions
5337
5338    begin
5339       Act := First (Actions (N));
5340       while Present (Act) loop
5341          Process_Single_Action (Act);
5342
5343          Next (Act);
5344       end loop;
5345    end Expand_N_Expression_With_Actions;
5346
5347    ----------------------------
5348    -- Expand_N_If_Expression --
5349    ----------------------------
5350
5351    --  Deal with limited types and condition actions
5352
5353    procedure Expand_N_If_Expression (N : Node_Id) is
5354       function Create_Alternative
5355         (Loc     : Source_Ptr;
5356          Temp_Id : Entity_Id;
5357          Flag_Id : Entity_Id;
5358          Expr    : Node_Id) return List_Id;
5359       --  Build the statements of a "then" or "else" dependent expression
5360       --  alternative. Temp_Id is the if expression result, Flag_Id is a
5361       --  finalization flag created to service expression Expr.
5362
5363       function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean;
5364       --  Determine if expression Expr is a rewritten controlled function call
5365
5366       ------------------------
5367       -- Create_Alternative --
5368       ------------------------
5369
5370       function Create_Alternative
5371         (Loc     : Source_Ptr;
5372          Temp_Id : Entity_Id;
5373          Flag_Id : Entity_Id;
5374          Expr    : Node_Id) return List_Id
5375       is
5376          Result : constant List_Id := New_List;
5377
5378       begin
5379          --  Generate:
5380          --    Fnn := True;
5381
5382          if Present (Flag_Id)
5383            and then not Is_Controlled_Function_Call (Expr)
5384          then
5385             Append_To (Result,
5386               Make_Assignment_Statement (Loc,
5387                 Name       => New_Reference_To (Flag_Id, Loc),
5388                 Expression => New_Reference_To (Standard_True, Loc)));
5389          end if;
5390
5391          --  Generate:
5392          --    Cnn := <expr>'Unrestricted_Access;
5393
5394          Append_To (Result,
5395            Make_Assignment_Statement (Loc,
5396              Name       => New_Reference_To (Temp_Id, Loc),
5397              Expression =>
5398                Make_Attribute_Reference (Loc,
5399                  Prefix         => Relocate_Node (Expr),
5400                  Attribute_Name => Name_Unrestricted_Access)));
5401
5402          return Result;
5403       end Create_Alternative;
5404
5405       ---------------------------------
5406       -- Is_Controlled_Function_Call --
5407       ---------------------------------
5408
5409       function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean is
5410       begin
5411          return
5412            Nkind (Original_Node (Expr)) = N_Function_Call
5413              and then Needs_Finalization (Etype (Expr));
5414       end Is_Controlled_Function_Call;
5415
5416       --  Local variables
5417
5418       Loc    : constant Source_Ptr := Sloc (N);
5419       Cond   : constant Node_Id    := First (Expressions (N));
5420       Thenx  : constant Node_Id    := Next (Cond);
5421       Elsex  : constant Node_Id    := Next (Thenx);
5422       Typ    : constant Entity_Id  := Etype (N);
5423
5424       Actions : List_Id;
5425       Cnn     : Entity_Id;
5426       Decl    : Node_Id;
5427       Expr    : Node_Id;
5428       New_If  : Node_Id;
5429       New_N   : Node_Id;
5430
5431    --  Start of processing for Expand_N_If_Expression
5432
5433    begin
5434       --  Check for MINIMIZED/ELIMINATED overflow mode
5435
5436       if Minimized_Eliminated_Overflow_Check (N) then
5437          Apply_Arithmetic_Overflow_Check (N);
5438          return;
5439       end if;
5440
5441       --  Fold at compile time if condition known. We have already folded
5442       --  static if expressions, but it is possible to fold any case in which
5443       --  the condition is known at compile time, even though the result is
5444       --  non-static.
5445
5446       --  Note that we don't do the fold of such cases in Sem_Elab because
5447       --  it can cause infinite loops with the expander adding a conditional
5448       --  expression, and Sem_Elab circuitry removing it repeatedly.
5449
5450       if Compile_Time_Known_Value (Cond) then
5451          if Is_True (Expr_Value (Cond)) then
5452             Expr := Thenx;
5453             Actions := Then_Actions (N);
5454          else
5455             Expr := Elsex;
5456             Actions := Else_Actions (N);
5457          end if;
5458
5459          Remove (Expr);
5460
5461          if Present (Actions) then
5462
5463             --  If we are not allowed to use Expression_With_Actions, just skip
5464             --  the optimization, it is not critical for correctness.
5465
5466             if not Use_Expression_With_Actions then
5467                goto Skip_Optimization;
5468             end if;
5469
5470             Rewrite (N,
5471               Make_Expression_With_Actions (Loc,
5472                 Expression => Relocate_Node (Expr),
5473                 Actions    => Actions));
5474             Analyze_And_Resolve (N, Typ);
5475
5476          else
5477             Rewrite (N, Relocate_Node (Expr));
5478          end if;
5479
5480          --  Note that the result is never static (legitimate cases of static
5481          --  if expressions were folded in Sem_Eval).
5482
5483          Set_Is_Static_Expression (N, False);
5484          return;
5485       end if;
5486
5487       <<Skip_Optimization>>
5488
5489       --  If the type is limited or unconstrained, we expand as follows to
5490       --  avoid any possibility of improper copies.
5491
5492       --  Note: it may be possible to avoid this special processing if the
5493       --  back end uses its own mechanisms for handling by-reference types ???
5494
5495       --      type Ptr is access all Typ;
5496       --      Cnn : Ptr;
5497       --      if cond then
5498       --         <<then actions>>
5499       --         Cnn := then-expr'Unrestricted_Access;
5500       --      else
5501       --         <<else actions>>
5502       --         Cnn := else-expr'Unrestricted_Access;
5503       --      end if;
5504
5505       --  and replace the if expression by a reference to Cnn.all.
5506
5507       --  This special case can be skipped if the back end handles limited
5508       --  types properly and ensures that no incorrect copies are made.
5509
5510       if Is_By_Reference_Type (Typ)
5511         and then not Back_End_Handles_Limited_Types
5512       then
5513          declare
5514             Flag_Id : Entity_Id;
5515             Ptr_Typ : Entity_Id;
5516
5517          begin
5518             Flag_Id := Empty;
5519
5520             --  At least one of the if expression dependent expressions uses a
5521             --  controlled function to provide the result. Create a status flag
5522             --  to signal the finalization machinery that Cnn needs special
5523             --  handling.
5524
5525             if Is_Controlled_Function_Call (Thenx)
5526                  or else
5527                Is_Controlled_Function_Call (Elsex)
5528             then
5529                Flag_Id := Make_Temporary (Loc, 'F');
5530
5531                Insert_Action (N,
5532                  Make_Object_Declaration (Loc,
5533                    Defining_Identifier => Flag_Id,
5534                    Object_Definition   =>
5535                      New_Reference_To (Standard_Boolean, Loc),
5536                    Expression          =>
5537                      New_Reference_To (Standard_False, Loc)));
5538             end if;
5539
5540             --  Generate:
5541             --    type Ann is access all Typ;
5542
5543             Ptr_Typ := Make_Temporary (Loc, 'A');
5544
5545             Insert_Action (N,
5546               Make_Full_Type_Declaration (Loc,
5547                 Defining_Identifier => Ptr_Typ,
5548                 Type_Definition     =>
5549                   Make_Access_To_Object_Definition (Loc,
5550                     All_Present        => True,
5551                     Subtype_Indication => New_Reference_To (Typ, Loc))));
5552
5553             --  Generate:
5554             --    Cnn : Ann;
5555
5556             Cnn := Make_Temporary (Loc, 'C', N);
5557             Set_Ekind (Cnn, E_Variable);
5558             Set_Status_Flag_Or_Transient_Decl (Cnn, Flag_Id);
5559
5560             Decl :=
5561                Make_Object_Declaration (Loc,
5562                  Defining_Identifier => Cnn,
5563                  Object_Definition   => New_Occurrence_Of (Ptr_Typ, Loc));
5564
5565             New_If :=
5566               Make_Implicit_If_Statement (N,
5567                 Condition       => Relocate_Node (Cond),
5568                 Then_Statements =>
5569                   Create_Alternative (Sloc (Thenx), Cnn, Flag_Id, Thenx),
5570                 Else_Statements =>
5571                   Create_Alternative (Sloc (Elsex), Cnn, Flag_Id, Elsex));
5572
5573             New_N :=
5574               Make_Explicit_Dereference (Loc,
5575                 Prefix => New_Occurrence_Of (Cnn, Loc));
5576          end;
5577
5578       --  For other types, we only need to expand if there are other actions
5579       --  associated with either branch.
5580
5581       elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
5582
5583          --  We have two approaches to handling this. If we are allowed to use
5584          --  N_Expression_With_Actions, then we can just wrap the actions into
5585          --  the appropriate expression.
5586
5587          if Use_Expression_With_Actions then
5588             if Present (Then_Actions (N)) then
5589                Rewrite (Thenx,
5590                  Make_Expression_With_Actions (Sloc (Thenx),
5591                    Actions    => Then_Actions (N),
5592                    Expression => Relocate_Node (Thenx)));
5593                Set_Then_Actions (N, No_List);
5594                Analyze_And_Resolve (Thenx, Typ);
5595             end if;
5596
5597             if Present (Else_Actions (N)) then
5598                Rewrite (Elsex,
5599                  Make_Expression_With_Actions (Sloc (Elsex),
5600                    Actions    => Else_Actions (N),
5601                    Expression => Relocate_Node (Elsex)));
5602                Set_Else_Actions (N, No_List);
5603                Analyze_And_Resolve (Elsex, Typ);
5604             end if;
5605
5606             return;
5607
5608             --  if we can't use N_Expression_With_Actions nodes, then we insert
5609             --  the following sequence of actions (using Insert_Actions):
5610
5611             --      Cnn : typ;
5612             --      if cond then
5613             --         <<then actions>>
5614             --         Cnn := then-expr;
5615             --      else
5616             --         <<else actions>>
5617             --         Cnn := else-expr
5618             --      end if;
5619
5620             --  and replace the if expression by a reference to Cnn
5621
5622          else
5623             Cnn := Make_Temporary (Loc, 'C', N);
5624
5625             Decl :=
5626               Make_Object_Declaration (Loc,
5627                 Defining_Identifier => Cnn,
5628                 Object_Definition   => New_Occurrence_Of (Typ, Loc));
5629
5630             New_If :=
5631               Make_Implicit_If_Statement (N,
5632                 Condition       => Relocate_Node (Cond),
5633
5634                 Then_Statements => New_List (
5635                   Make_Assignment_Statement (Sloc (Thenx),
5636                     Name       => New_Occurrence_Of (Cnn, Sloc (Thenx)),
5637                     Expression => Relocate_Node (Thenx))),
5638
5639                 Else_Statements => New_List (
5640                   Make_Assignment_Statement (Sloc (Elsex),
5641                     Name       => New_Occurrence_Of (Cnn, Sloc (Elsex)),
5642                     Expression => Relocate_Node (Elsex))));
5643
5644             Set_Assignment_OK (Name (First (Then_Statements (New_If))));
5645             Set_Assignment_OK (Name (First (Else_Statements (New_If))));
5646
5647             New_N := New_Occurrence_Of (Cnn, Loc);
5648          end if;
5649
5650          --  If no actions then no expansion needed, gigi will handle it using
5651          --  the same approach as a C conditional expression.
5652
5653       else
5654          return;
5655       end if;
5656
5657       --  Fall through here for either the limited expansion, or the case of
5658       --  inserting actions for non-limited types. In both these cases, we must
5659       --  move the SLOC of the parent If statement to the newly created one and
5660       --  change it to the SLOC of the expression which, after expansion, will
5661       --  correspond to what is being evaluated.
5662
5663       if Present (Parent (N)) and then Nkind (Parent (N)) = N_If_Statement then
5664          Set_Sloc (New_If, Sloc (Parent (N)));
5665          Set_Sloc (Parent (N), Loc);
5666       end if;
5667
5668       --  Make sure Then_Actions and Else_Actions are appropriately moved
5669       --  to the new if statement.
5670
5671       if Present (Then_Actions (N)) then
5672          Insert_List_Before
5673            (First (Then_Statements (New_If)), Then_Actions (N));
5674       end if;
5675
5676       if Present (Else_Actions (N)) then
5677          Insert_List_Before
5678            (First (Else_Statements (New_If)), Else_Actions (N));
5679       end if;
5680
5681       Insert_Action (N, Decl);
5682       Insert_Action (N, New_If);
5683       Rewrite (N, New_N);
5684       Analyze_And_Resolve (N, Typ);
5685    end Expand_N_If_Expression;
5686
5687    -----------------
5688    -- Expand_N_In --
5689    -----------------
5690
5691    procedure Expand_N_In (N : Node_Id) is
5692       Loc    : constant Source_Ptr := Sloc (N);
5693       Restyp : constant Entity_Id  := Etype (N);
5694       Lop    : constant Node_Id    := Left_Opnd (N);
5695       Rop    : constant Node_Id    := Right_Opnd (N);
5696       Static : constant Boolean    := Is_OK_Static_Expression (N);
5697
5698       Ltyp  : Entity_Id;
5699       Rtyp  : Entity_Id;
5700
5701       procedure Substitute_Valid_Check;
5702       --  Replaces node N by Lop'Valid. This is done when we have an explicit
5703       --  test for the left operand being in range of its subtype.
5704
5705       ----------------------------
5706       -- Substitute_Valid_Check --
5707       ----------------------------
5708
5709       procedure Substitute_Valid_Check is
5710       begin
5711          Rewrite (N,
5712            Make_Attribute_Reference (Loc,
5713              Prefix         => Relocate_Node (Lop),
5714              Attribute_Name => Name_Valid));
5715
5716          Analyze_And_Resolve (N, Restyp);
5717
5718          --  Give warning unless overflow checking is MINIMIZED or ELIMINATED,
5719          --  in which case, this usage makes sense, and in any case, we have
5720          --  actually eliminated the danger of optimization above.
5721
5722          if Overflow_Check_Mode not in Minimized_Or_Eliminated then
5723             Error_Msg_N
5724               ("??explicit membership test may be optimized away", N);
5725             Error_Msg_N -- CODEFIX
5726               ("\??use ''Valid attribute instead", N);
5727          end if;
5728
5729          return;
5730       end Substitute_Valid_Check;
5731
5732    --  Start of processing for Expand_N_In
5733
5734    begin
5735       --  If set membership case, expand with separate procedure
5736
5737       if Present (Alternatives (N)) then
5738          Expand_Set_Membership (N);
5739          return;
5740       end if;
5741
5742       --  Not set membership, proceed with expansion
5743
5744       Ltyp := Etype (Left_Opnd  (N));
5745       Rtyp := Etype (Right_Opnd (N));
5746
5747       --  If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
5748       --  type, then expand with a separate procedure. Note the use of the
5749       --  flag No_Minimize_Eliminate to prevent infinite recursion.
5750
5751       if Overflow_Check_Mode in Minimized_Or_Eliminated
5752         and then Is_Signed_Integer_Type (Ltyp)
5753         and then not No_Minimize_Eliminate (N)
5754       then
5755          Expand_Membership_Minimize_Eliminate_Overflow (N);
5756          return;
5757       end if;
5758
5759       --  Check case of explicit test for an expression in range of its
5760       --  subtype. This is suspicious usage and we replace it with a 'Valid
5761       --  test and give a warning for scalar types.
5762
5763       if Is_Scalar_Type (Ltyp)
5764
5765         --  Only relevant for source comparisons
5766
5767         and then Comes_From_Source (N)
5768
5769         --  In floating-point this is a standard way to check for finite values
5770         --  and using 'Valid would typically be a pessimization.
5771
5772         and then not Is_Floating_Point_Type (Ltyp)
5773
5774         --  Don't give the message unless right operand is a type entity and
5775         --  the type of the left operand matches this type. Note that this
5776         --  eliminates the cases where MINIMIZED/ELIMINATED mode overflow
5777         --  checks have changed the type of the left operand.
5778
5779         and then Nkind (Rop) in N_Has_Entity
5780         and then Ltyp = Entity (Rop)
5781
5782         --  Skip in VM mode, where we have no sense of invalid values. The
5783         --  warning still seems relevant, but not important enough to worry.
5784
5785         and then VM_Target = No_VM
5786
5787         --  Skip this for predicated types, where such expressions are a
5788         --  reasonable way of testing if something meets the predicate.
5789
5790         and then not Present (Predicate_Function (Ltyp))
5791       then
5792          Substitute_Valid_Check;
5793          return;
5794       end if;
5795
5796       --  Do validity check on operands
5797
5798       if Validity_Checks_On and Validity_Check_Operands then
5799          Ensure_Valid (Left_Opnd (N));
5800          Validity_Check_Range (Right_Opnd (N));
5801       end if;
5802
5803       --  Case of explicit range
5804
5805       if Nkind (Rop) = N_Range then
5806          declare
5807             Lo : constant Node_Id := Low_Bound (Rop);
5808             Hi : constant Node_Id := High_Bound (Rop);
5809
5810             Lo_Orig : constant Node_Id := Original_Node (Lo);
5811             Hi_Orig : constant Node_Id := Original_Node (Hi);
5812
5813             Lcheck : Compare_Result;
5814             Ucheck : Compare_Result;
5815
5816             Warn1 : constant Boolean :=
5817                       Constant_Condition_Warnings
5818                         and then Comes_From_Source (N)
5819                         and then not In_Instance;
5820             --  This must be true for any of the optimization warnings, we
5821             --  clearly want to give them only for source with the flag on. We
5822             --  also skip these warnings in an instance since it may be the
5823             --  case that different instantiations have different ranges.
5824
5825             Warn2 : constant Boolean :=
5826                       Warn1
5827                         and then Nkind (Original_Node (Rop)) = N_Range
5828                         and then Is_Integer_Type (Etype (Lo));
5829             --  For the case where only one bound warning is elided, we also
5830             --  insist on an explicit range and an integer type. The reason is
5831             --  that the use of enumeration ranges including an end point is
5832             --  common, as is the use of a subtype name, one of whose bounds is
5833             --  the same as the type of the expression.
5834
5835          begin
5836             --  If test is explicit x'First .. x'Last, replace by valid check
5837
5838             --  Could use some individual comments for this complex test ???
5839
5840             if Is_Scalar_Type (Ltyp)
5841
5842               --  And left operand is X'First where X matches left operand
5843               --  type (this eliminates cases of type mismatch, including
5844               --  the cases where ELIMINATED/MINIMIZED mode has changed the
5845               --  type of the left operand.
5846
5847               and then Nkind (Lo_Orig) = N_Attribute_Reference
5848               and then Attribute_Name (Lo_Orig) = Name_First
5849               and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
5850               and then Entity (Prefix (Lo_Orig)) = Ltyp
5851
5852             --  Same tests for right operand
5853
5854               and then Nkind (Hi_Orig) = N_Attribute_Reference
5855               and then Attribute_Name (Hi_Orig) = Name_Last
5856               and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
5857               and then Entity (Prefix (Hi_Orig)) = Ltyp
5858
5859               --  Relevant only for source cases
5860
5861               and then Comes_From_Source (N)
5862
5863               --  Omit for VM cases, where we don't have invalid values
5864
5865               and then VM_Target = No_VM
5866             then
5867                Substitute_Valid_Check;
5868                goto Leave;
5869             end if;
5870
5871             --  If bounds of type are known at compile time, and the end points
5872             --  are known at compile time and identical, this is another case
5873             --  for substituting a valid test. We only do this for discrete
5874             --  types, since it won't arise in practice for float types.
5875
5876             if Comes_From_Source (N)
5877               and then Is_Discrete_Type (Ltyp)
5878               and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
5879               and then Compile_Time_Known_Value (Type_Low_Bound  (Ltyp))
5880               and then Compile_Time_Known_Value (Lo)
5881               and then Compile_Time_Known_Value (Hi)
5882               and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
5883               and then Expr_Value (Type_Low_Bound  (Ltyp)) = Expr_Value (Lo)
5884
5885               --  Kill warnings in instances, since they may be cases where we
5886               --  have a test in the generic that makes sense with some types
5887               --  and not with other types.
5888
5889               and then not In_Instance
5890             then
5891                Substitute_Valid_Check;
5892                goto Leave;
5893             end if;
5894
5895             --  If we have an explicit range, do a bit of optimization based on
5896             --  range analysis (we may be able to kill one or both checks).
5897
5898             Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
5899             Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
5900
5901             --  If either check is known to fail, replace result by False since
5902             --  the other check does not matter. Preserve the static flag for
5903             --  legality checks, because we are constant-folding beyond RM 4.9.
5904
5905             if Lcheck = LT or else Ucheck = GT then
5906                if Warn1 then
5907                   Error_Msg_N ("?c?range test optimized away", N);
5908                   Error_Msg_N ("\?c?value is known to be out of range", N);
5909                end if;
5910
5911                Rewrite (N, New_Reference_To (Standard_False, Loc));
5912                Analyze_And_Resolve (N, Restyp);
5913                Set_Is_Static_Expression (N, Static);
5914                goto Leave;
5915
5916             --  If both checks are known to succeed, replace result by True,
5917             --  since we know we are in range.
5918
5919             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5920                if Warn1 then
5921                   Error_Msg_N ("?c?range test optimized away", N);
5922                   Error_Msg_N ("\?c?value is known to be in range", N);
5923                end if;
5924
5925                Rewrite (N, New_Reference_To (Standard_True, Loc));
5926                Analyze_And_Resolve (N, Restyp);
5927                Set_Is_Static_Expression (N, Static);
5928                goto Leave;
5929
5930             --  If lower bound check succeeds and upper bound check is not
5931             --  known to succeed or fail, then replace the range check with
5932             --  a comparison against the upper bound.
5933
5934             elsif Lcheck in Compare_GE then
5935                if Warn2 and then not In_Instance then
5936                   Error_Msg_N ("??lower bound test optimized away", Lo);
5937                   Error_Msg_N ("\??value is known to be in range", Lo);
5938                end if;
5939
5940                Rewrite (N,
5941                  Make_Op_Le (Loc,
5942                    Left_Opnd  => Lop,
5943                    Right_Opnd => High_Bound (Rop)));
5944                Analyze_And_Resolve (N, Restyp);
5945                goto Leave;
5946
5947             --  If upper bound check succeeds and lower bound check is not
5948             --  known to succeed or fail, then replace the range check with
5949             --  a comparison against the lower bound.
5950
5951             elsif Ucheck in Compare_LE then
5952                if Warn2 and then not In_Instance then
5953                   Error_Msg_N ("??upper bound test optimized away", Hi);
5954                   Error_Msg_N ("\??value is known to be in range", Hi);
5955                end if;
5956
5957                Rewrite (N,
5958                  Make_Op_Ge (Loc,
5959                    Left_Opnd  => Lop,
5960                    Right_Opnd => Low_Bound (Rop)));
5961                Analyze_And_Resolve (N, Restyp);
5962                goto Leave;
5963             end if;
5964
5965             --  We couldn't optimize away the range check, but there is one
5966             --  more issue. If we are checking constant conditionals, then we
5967             --  see if we can determine the outcome assuming everything is
5968             --  valid, and if so give an appropriate warning.
5969
5970             if Warn1 and then not Assume_No_Invalid_Values then
5971                Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
5972                Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
5973
5974                --  Result is out of range for valid value
5975
5976                if Lcheck = LT or else Ucheck = GT then
5977                   Error_Msg_N
5978                     ("?c?value can only be in range if it is invalid", N);
5979
5980                --  Result is in range for valid value
5981
5982                elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
5983                   Error_Msg_N
5984                     ("?c?value can only be out of range if it is invalid", N);
5985
5986                --  Lower bound check succeeds if value is valid
5987
5988                elsif Warn2 and then Lcheck in Compare_GE then
5989                   Error_Msg_N
5990                     ("?c?lower bound check only fails if it is invalid", Lo);
5991
5992                --  Upper bound  check succeeds if value is valid
5993
5994                elsif Warn2 and then Ucheck in Compare_LE then
5995                   Error_Msg_N
5996                     ("?c?upper bound check only fails for invalid values", Hi);
5997                end if;
5998             end if;
5999          end;
6000
6001          --  For all other cases of an explicit range, nothing to be done
6002
6003          goto Leave;
6004
6005       --  Here right operand is a subtype mark
6006
6007       else
6008          declare
6009             Typ       : Entity_Id        := Etype (Rop);
6010             Is_Acc    : constant Boolean := Is_Access_Type (Typ);
6011             Cond      : Node_Id          := Empty;
6012             New_N     : Node_Id;
6013             Obj       : Node_Id          := Lop;
6014             SCIL_Node : Node_Id;
6015
6016          begin
6017             Remove_Side_Effects (Obj);
6018
6019             --  For tagged type, do tagged membership operation
6020
6021             if Is_Tagged_Type (Typ) then
6022
6023                --  No expansion will be performed when VM_Target, as the VM
6024                --  back-ends will handle the membership tests directly (tags
6025                --  are not explicitly represented in Java objects, so the
6026                --  normal tagged membership expansion is not what we want).
6027
6028                if Tagged_Type_Expansion then
6029                   Tagged_Membership (N, SCIL_Node, New_N);
6030                   Rewrite (N, New_N);
6031                   Analyze_And_Resolve (N, Restyp);
6032
6033                   --  Update decoration of relocated node referenced by the
6034                   --  SCIL node.
6035
6036                   if Generate_SCIL and then Present (SCIL_Node) then
6037                      Set_SCIL_Node (N, SCIL_Node);
6038                   end if;
6039                end if;
6040
6041                goto Leave;
6042
6043             --  If type is scalar type, rewrite as x in t'First .. t'Last.
6044             --  This reason we do this is that the bounds may have the wrong
6045             --  type if they come from the original type definition. Also this
6046             --  way we get all the processing above for an explicit range.
6047
6048             --  Don't do this for predicated types, since in this case we
6049             --  want to check the predicate!
6050
6051             elsif Is_Scalar_Type (Typ) then
6052                if No (Predicate_Function (Typ)) then
6053                   Rewrite (Rop,
6054                     Make_Range (Loc,
6055                       Low_Bound =>
6056                         Make_Attribute_Reference (Loc,
6057                           Attribute_Name => Name_First,
6058                           Prefix         => New_Reference_To (Typ, Loc)),
6059
6060                       High_Bound =>
6061                         Make_Attribute_Reference (Loc,
6062                           Attribute_Name => Name_Last,
6063                           Prefix         => New_Reference_To (Typ, Loc))));
6064                   Analyze_And_Resolve (N, Restyp);
6065                end if;
6066
6067                goto Leave;
6068
6069             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
6070             --  a membership test if the subtype mark denotes a constrained
6071             --  Unchecked_Union subtype and the expression lacks inferable
6072             --  discriminants.
6073
6074             elsif Is_Unchecked_Union (Base_Type (Typ))
6075               and then Is_Constrained (Typ)
6076               and then not Has_Inferable_Discriminants (Lop)
6077             then
6078                Insert_Action (N,
6079                  Make_Raise_Program_Error (Loc,
6080                    Reason => PE_Unchecked_Union_Restriction));
6081
6082                --  Prevent Gigi from generating incorrect code by rewriting the
6083                --  test as False. What is this undocumented thing about ???
6084
6085                Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6086                goto Leave;
6087             end if;
6088
6089             --  Here we have a non-scalar type
6090
6091             if Is_Acc then
6092                Typ := Designated_Type (Typ);
6093             end if;
6094
6095             if not Is_Constrained (Typ) then
6096                Rewrite (N, New_Reference_To (Standard_True, Loc));
6097                Analyze_And_Resolve (N, Restyp);
6098
6099             --  For the constrained array case, we have to check the subscripts
6100             --  for an exact match if the lengths are non-zero (the lengths
6101             --  must match in any case).
6102
6103             elsif Is_Array_Type (Typ) then
6104                Check_Subscripts : declare
6105                   function Build_Attribute_Reference
6106                     (E   : Node_Id;
6107                      Nam : Name_Id;
6108                      Dim : Nat) return Node_Id;
6109                   --  Build attribute reference E'Nam (Dim)
6110
6111                   -------------------------------
6112                   -- Build_Attribute_Reference --
6113                   -------------------------------
6114
6115                   function Build_Attribute_Reference
6116                     (E   : Node_Id;
6117                      Nam : Name_Id;
6118                      Dim : Nat) return Node_Id
6119                   is
6120                   begin
6121                      return
6122                        Make_Attribute_Reference (Loc,
6123                          Prefix         => E,
6124                          Attribute_Name => Nam,
6125                          Expressions    => New_List (
6126                            Make_Integer_Literal (Loc, Dim)));
6127                   end Build_Attribute_Reference;
6128
6129                --  Start of processing for Check_Subscripts
6130
6131                begin
6132                   for J in 1 .. Number_Dimensions (Typ) loop
6133                      Evolve_And_Then (Cond,
6134                        Make_Op_Eq (Loc,
6135                          Left_Opnd  =>
6136                            Build_Attribute_Reference
6137                              (Duplicate_Subexpr_No_Checks (Obj),
6138                               Name_First, J),
6139                          Right_Opnd =>
6140                            Build_Attribute_Reference
6141                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
6142
6143                      Evolve_And_Then (Cond,
6144                        Make_Op_Eq (Loc,
6145                          Left_Opnd  =>
6146                            Build_Attribute_Reference
6147                              (Duplicate_Subexpr_No_Checks (Obj),
6148                               Name_Last, J),
6149                          Right_Opnd =>
6150                            Build_Attribute_Reference
6151                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
6152                   end loop;
6153
6154                   if Is_Acc then
6155                      Cond :=
6156                        Make_Or_Else (Loc,
6157                          Left_Opnd =>
6158                            Make_Op_Eq (Loc,
6159                              Left_Opnd  => Obj,
6160                              Right_Opnd => Make_Null (Loc)),
6161                          Right_Opnd => Cond);
6162                   end if;
6163
6164                   Rewrite (N, Cond);
6165                   Analyze_And_Resolve (N, Restyp);
6166                end Check_Subscripts;
6167
6168             --  These are the cases where constraint checks may be required,
6169             --  e.g. records with possible discriminants
6170
6171             else
6172                --  Expand the test into a series of discriminant comparisons.
6173                --  The expression that is built is the negation of the one that
6174                --  is used for checking discriminant constraints.
6175
6176                Obj := Relocate_Node (Left_Opnd (N));
6177
6178                if Has_Discriminants (Typ) then
6179                   Cond := Make_Op_Not (Loc,
6180                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
6181
6182                   if Is_Acc then
6183                      Cond := Make_Or_Else (Loc,
6184                        Left_Opnd =>
6185                          Make_Op_Eq (Loc,
6186                            Left_Opnd  => Obj,
6187                            Right_Opnd => Make_Null (Loc)),
6188                        Right_Opnd => Cond);
6189                   end if;
6190
6191                else
6192                   Cond := New_Occurrence_Of (Standard_True, Loc);
6193                end if;
6194
6195                Rewrite (N, Cond);
6196                Analyze_And_Resolve (N, Restyp);
6197             end if;
6198
6199             --  Ada 2012 (AI05-0149): Handle membership tests applied to an
6200             --  expression of an anonymous access type. This can involve an
6201             --  accessibility test and a tagged type membership test in the
6202             --  case of tagged designated types.
6203
6204             if Ada_Version >= Ada_2012
6205               and then Is_Acc
6206               and then Ekind (Ltyp) = E_Anonymous_Access_Type
6207             then
6208                declare
6209                   Expr_Entity : Entity_Id := Empty;
6210                   New_N       : Node_Id;
6211                   Param_Level : Node_Id;
6212                   Type_Level  : Node_Id;
6213
6214                begin
6215                   if Is_Entity_Name (Lop) then
6216                      Expr_Entity := Param_Entity (Lop);
6217
6218                      if not Present (Expr_Entity) then
6219                         Expr_Entity := Entity (Lop);
6220                      end if;
6221                   end if;
6222
6223                   --  If a conversion of the anonymous access value to the
6224                   --  tested type would be illegal, then the result is False.
6225
6226                   if not Valid_Conversion
6227                            (Lop, Rtyp, Lop, Report_Errs => False)
6228                   then
6229                      Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
6230                      Analyze_And_Resolve (N, Restyp);
6231
6232                   --  Apply an accessibility check if the access object has an
6233                   --  associated access level and when the level of the type is
6234                   --  less deep than the level of the access parameter. This
6235                   --  only occur for access parameters and stand-alone objects
6236                   --  of an anonymous access type.
6237
6238                   else
6239                      if Present (Expr_Entity)
6240                        and then
6241                          Present
6242                            (Effective_Extra_Accessibility (Expr_Entity))
6243                        and then UI_Gt (Object_Access_Level (Lop),
6244                                        Type_Access_Level (Rtyp))
6245                      then
6246                         Param_Level :=
6247                           New_Occurrence_Of
6248                             (Effective_Extra_Accessibility (Expr_Entity), Loc);
6249
6250                         Type_Level :=
6251                           Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
6252
6253                         --  Return True only if the accessibility level of the
6254                         --  expression entity is not deeper than the level of
6255                         --  the tested access type.
6256
6257                         Rewrite (N,
6258                           Make_And_Then (Loc,
6259                             Left_Opnd  => Relocate_Node (N),
6260                             Right_Opnd => Make_Op_Le (Loc,
6261                                             Left_Opnd  => Param_Level,
6262                                             Right_Opnd => Type_Level)));
6263
6264                         Analyze_And_Resolve (N);
6265                      end if;
6266
6267                      --  If the designated type is tagged, do tagged membership
6268                      --  operation.
6269
6270                      --  *** NOTE: we have to check not null before doing the
6271                      --  tagged membership test (but maybe that can be done
6272                      --  inside Tagged_Membership?).
6273
6274                      if Is_Tagged_Type (Typ) then
6275                         Rewrite (N,
6276                           Make_And_Then (Loc,
6277                             Left_Opnd  => Relocate_Node (N),
6278                             Right_Opnd =>
6279                               Make_Op_Ne (Loc,
6280                                 Left_Opnd  => Obj,
6281                                 Right_Opnd => Make_Null (Loc))));
6282
6283                         --  No expansion will be performed when VM_Target, as
6284                         --  the VM back-ends will handle the membership tests
6285                         --  directly (tags are not explicitly represented in
6286                         --  Java objects, so the normal tagged membership
6287                         --  expansion is not what we want).
6288
6289                         if Tagged_Type_Expansion then
6290
6291                            --  Note that we have to pass Original_Node, because
6292                            --  the membership test might already have been
6293                            --  rewritten by earlier parts of membership test.
6294
6295                            Tagged_Membership
6296                              (Original_Node (N), SCIL_Node, New_N);
6297
6298                            --  Update decoration of relocated node referenced
6299                            --  by the SCIL node.
6300
6301                            if Generate_SCIL and then Present (SCIL_Node) then
6302                               Set_SCIL_Node (New_N, SCIL_Node);
6303                            end if;
6304
6305                            Rewrite (N,
6306                              Make_And_Then (Loc,
6307                                Left_Opnd  => Relocate_Node (N),
6308                                Right_Opnd => New_N));
6309
6310                            Analyze_And_Resolve (N, Restyp);
6311                         end if;
6312                      end if;
6313                   end if;
6314                end;
6315             end if;
6316          end;
6317       end if;
6318
6319    --  At this point, we have done the processing required for the basic
6320    --  membership test, but not yet dealt with the predicate.
6321
6322    <<Leave>>
6323
6324       --  If a predicate is present, then we do the predicate test, but we
6325       --  most certainly want to omit this if we are within the predicate
6326       --  function itself, since otherwise we have an infinite recursion!
6327       --  The check should also not be emitted when testing against a range
6328       --  (the check is only done when the right operand is a subtype; see
6329       --  RM12-4.5.2 (28.1/3-30/3)).
6330
6331       declare
6332          PFunc : constant Entity_Id := Predicate_Function (Rtyp);
6333
6334       begin
6335          if Present (PFunc)
6336            and then Current_Scope /= PFunc
6337            and then Nkind (Rop) /= N_Range
6338          then
6339             Rewrite (N,
6340               Make_And_Then (Loc,
6341                 Left_Opnd  => Relocate_Node (N),
6342                 Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
6343
6344             --  Analyze new expression, mark left operand as analyzed to
6345             --  avoid infinite recursion adding predicate calls. Similarly,
6346             --  suppress further range checks on the call.
6347
6348             Set_Analyzed (Left_Opnd (N));
6349             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
6350
6351             --  All done, skip attempt at compile time determination of result
6352
6353             return;
6354          end if;
6355       end;
6356    end Expand_N_In;
6357
6358    --------------------------------
6359    -- Expand_N_Indexed_Component --
6360    --------------------------------
6361
6362    procedure Expand_N_Indexed_Component (N : Node_Id) is
6363       Loc : constant Source_Ptr := Sloc (N);
6364       Typ : constant Entity_Id  := Etype (N);
6365       P   : constant Node_Id    := Prefix (N);
6366       T   : constant Entity_Id  := Etype (P);
6367       Atp : Entity_Id;
6368
6369    begin
6370       --  A special optimization, if we have an indexed component that is
6371       --  selecting from a slice, then we can eliminate the slice, since, for
6372       --  example, x (i .. j)(k) is identical to x(k). The only difference is
6373       --  the range check required by the slice. The range check for the slice
6374       --  itself has already been generated. The range check for the
6375       --  subscripting operation is ensured by converting the subject to
6376       --  the subtype of the slice.
6377
6378       --  This optimization not only generates better code, avoiding slice
6379       --  messing especially in the packed case, but more importantly bypasses
6380       --  some problems in handling this peculiar case, for example, the issue
6381       --  of dealing specially with object renamings.
6382
6383       if Nkind (P) = N_Slice then
6384          Rewrite (N,
6385            Make_Indexed_Component (Loc,
6386              Prefix => Prefix (P),
6387              Expressions => New_List (
6388                Convert_To
6389                  (Etype (First_Index (Etype (P))),
6390                   First (Expressions (N))))));
6391          Analyze_And_Resolve (N, Typ);
6392          return;
6393       end if;
6394
6395       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
6396       --  function, then additional actuals must be passed.
6397
6398       if Ada_Version >= Ada_2005
6399         and then Is_Build_In_Place_Function_Call (P)
6400       then
6401          Make_Build_In_Place_Call_In_Anonymous_Context (P);
6402       end if;
6403
6404       --  If the prefix is an access type, then we unconditionally rewrite if
6405       --  as an explicit dereference. This simplifies processing for several
6406       --  cases, including packed array cases and certain cases in which checks
6407       --  must be generated. We used to try to do this only when it was
6408       --  necessary, but it cleans up the code to do it all the time.
6409
6410       if Is_Access_Type (T) then
6411          Insert_Explicit_Dereference (P);
6412          Analyze_And_Resolve (P, Designated_Type (T));
6413          Atp := Designated_Type (T);
6414       else
6415          Atp := T;
6416       end if;
6417
6418       --  Generate index and validity checks
6419
6420       Generate_Index_Checks (N);
6421
6422       if Validity_Checks_On and then Validity_Check_Subscripts then
6423          Apply_Subscript_Validity_Checks (N);
6424       end if;
6425
6426       --  If selecting from an array with atomic components, and atomic sync
6427       --  is not suppressed for this array type, set atomic sync flag.
6428
6429       if (Has_Atomic_Components (Atp)
6430            and then not Atomic_Synchronization_Disabled (Atp))
6431         or else (Is_Atomic (Typ)
6432                   and then not Atomic_Synchronization_Disabled (Typ))
6433       then
6434          Activate_Atomic_Synchronization (N);
6435       end if;
6436
6437       --  All done for the non-packed case
6438
6439       if not Is_Packed (Etype (Prefix (N))) then
6440          return;
6441       end if;
6442
6443       --  For packed arrays that are not bit-packed (i.e. the case of an array
6444       --  with one or more index types with a non-contiguous enumeration type),
6445       --  we can always use the normal packed element get circuit.
6446
6447       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
6448          Expand_Packed_Element_Reference (N);
6449          return;
6450       end if;
6451
6452       --  For a reference to a component of a bit packed array, we have to
6453       --  convert it to a reference to the corresponding Packed_Array_Type.
6454       --  We only want to do this for simple references, and not for:
6455
6456       --    Left side of assignment, or prefix of left side of assignment, or
6457       --    prefix of the prefix, to handle packed arrays of packed arrays,
6458       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
6459
6460       --    Renaming objects in renaming associations
6461       --      This case is handled when a use of the renamed variable occurs
6462
6463       --    Actual parameters for a procedure call
6464       --      This case is handled in Exp_Ch6.Expand_Actuals
6465
6466       --    The second expression in a 'Read attribute reference
6467
6468       --    The prefix of an address or bit or size attribute reference
6469
6470       --  The following circuit detects these exceptions
6471
6472       declare
6473          Child : Node_Id := N;
6474          Parnt : Node_Id := Parent (N);
6475
6476       begin
6477          loop
6478             if Nkind (Parnt) = N_Unchecked_Expression then
6479                null;
6480
6481             elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
6482                                    N_Procedure_Call_Statement)
6483               or else (Nkind (Parnt) = N_Parameter_Association
6484                         and then
6485                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
6486             then
6487                return;
6488
6489             elsif Nkind (Parnt) = N_Attribute_Reference
6490               and then (Attribute_Name (Parnt) = Name_Address
6491                          or else
6492                         Attribute_Name (Parnt) = Name_Bit
6493                          or else
6494                         Attribute_Name (Parnt) = Name_Size)
6495               and then Prefix (Parnt) = Child
6496             then
6497                return;
6498
6499             elsif Nkind (Parnt) = N_Assignment_Statement
6500               and then Name (Parnt) = Child
6501             then
6502                return;
6503
6504             --  If the expression is an index of an indexed component, it must
6505             --  be expanded regardless of context.
6506
6507             elsif Nkind (Parnt) = N_Indexed_Component
6508               and then Child /= Prefix (Parnt)
6509             then
6510                Expand_Packed_Element_Reference (N);
6511                return;
6512
6513             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
6514               and then Name (Parent (Parnt)) = Parnt
6515             then
6516                return;
6517
6518             elsif Nkind (Parnt) = N_Attribute_Reference
6519               and then Attribute_Name (Parnt) = Name_Read
6520               and then Next (First (Expressions (Parnt))) = Child
6521             then
6522                return;
6523
6524             elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
6525               and then Prefix (Parnt) = Child
6526             then
6527                null;
6528
6529             else
6530                Expand_Packed_Element_Reference (N);
6531                return;
6532             end if;
6533
6534             --  Keep looking up tree for unchecked expression, or if we are the
6535             --  prefix of a possible assignment left side.
6536
6537             Child := Parnt;
6538             Parnt := Parent (Child);
6539          end loop;
6540       end;
6541    end Expand_N_Indexed_Component;
6542
6543    ---------------------
6544    -- Expand_N_Not_In --
6545    ---------------------
6546
6547    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
6548    --  can be done. This avoids needing to duplicate this expansion code.
6549
6550    procedure Expand_N_Not_In (N : Node_Id) is
6551       Loc : constant Source_Ptr := Sloc (N);
6552       Typ : constant Entity_Id  := Etype (N);
6553       Cfs : constant Boolean    := Comes_From_Source (N);
6554
6555    begin
6556       Rewrite (N,
6557         Make_Op_Not (Loc,
6558           Right_Opnd =>
6559             Make_In (Loc,
6560               Left_Opnd  => Left_Opnd (N),
6561               Right_Opnd => Right_Opnd (N))));
6562
6563       --  If this is a set membership, preserve list of alternatives
6564
6565       Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
6566
6567       --  We want this to appear as coming from source if original does (see
6568       --  transformations in Expand_N_In).
6569
6570       Set_Comes_From_Source (N, Cfs);
6571       Set_Comes_From_Source (Right_Opnd (N), Cfs);
6572
6573       --  Now analyze transformed node
6574
6575       Analyze_And_Resolve (N, Typ);
6576    end Expand_N_Not_In;
6577
6578    -------------------
6579    -- Expand_N_Null --
6580    -------------------
6581
6582    --  The only replacement required is for the case of a null of a type that
6583    --  is an access to protected subprogram, or a subtype thereof. We represent
6584    --  such access values as a record, and so we must replace the occurrence of
6585    --  null by the equivalent record (with a null address and a null pointer in
6586    --  it), so that the backend creates the proper value.
6587
6588    procedure Expand_N_Null (N : Node_Id) is
6589       Loc : constant Source_Ptr := Sloc (N);
6590       Typ : constant Entity_Id  := Base_Type (Etype (N));
6591       Agg : Node_Id;
6592
6593    begin
6594       if Is_Access_Protected_Subprogram_Type (Typ) then
6595          Agg :=
6596            Make_Aggregate (Loc,
6597              Expressions => New_List (
6598                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
6599                Make_Null (Loc)));
6600
6601          Rewrite (N, Agg);
6602          Analyze_And_Resolve (N, Equivalent_Type (Typ));
6603
6604          --  For subsequent semantic analysis, the node must retain its type.
6605          --  Gigi in any case replaces this type by the corresponding record
6606          --  type before processing the node.
6607
6608          Set_Etype (N, Typ);
6609       end if;
6610
6611    exception
6612       when RE_Not_Available =>
6613          return;
6614    end Expand_N_Null;
6615
6616    ---------------------
6617    -- Expand_N_Op_Abs --
6618    ---------------------
6619
6620    procedure Expand_N_Op_Abs (N : Node_Id) is
6621       Loc  : constant Source_Ptr := Sloc (N);
6622       Expr : constant Node_Id := Right_Opnd (N);
6623
6624    begin
6625       Unary_Op_Validity_Checks (N);
6626
6627       --  Check for MINIMIZED/ELIMINATED overflow mode
6628
6629       if Minimized_Eliminated_Overflow_Check (N) then
6630          Apply_Arithmetic_Overflow_Check (N);
6631          return;
6632       end if;
6633
6634       --  Deal with software overflow checking
6635
6636       if not Backend_Overflow_Checks_On_Target
6637         and then Is_Signed_Integer_Type (Etype (N))
6638         and then Do_Overflow_Check (N)
6639       then
6640          --  The only case to worry about is when the argument is equal to the
6641          --  largest negative number, so what we do is to insert the check:
6642
6643          --     [constraint_error when Expr = typ'Base'First]
6644
6645          --  with the usual Duplicate_Subexpr use coding for expr
6646
6647          Insert_Action (N,
6648            Make_Raise_Constraint_Error (Loc,
6649              Condition =>
6650                Make_Op_Eq (Loc,
6651                  Left_Opnd  => Duplicate_Subexpr (Expr),
6652                  Right_Opnd =>
6653                    Make_Attribute_Reference (Loc,
6654                      Prefix =>
6655                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
6656                      Attribute_Name => Name_First)),
6657              Reason => CE_Overflow_Check_Failed));
6658       end if;
6659
6660       --  Vax floating-point types case
6661
6662       if Vax_Float (Etype (N)) then
6663          Expand_Vax_Arith (N);
6664       end if;
6665    end Expand_N_Op_Abs;
6666
6667    ---------------------
6668    -- Expand_N_Op_Add --
6669    ---------------------
6670
6671    procedure Expand_N_Op_Add (N : Node_Id) is
6672       Typ : constant Entity_Id := Etype (N);
6673
6674    begin
6675       Binary_Op_Validity_Checks (N);
6676
6677       --  Check for MINIMIZED/ELIMINATED overflow mode
6678
6679       if Minimized_Eliminated_Overflow_Check (N) then
6680          Apply_Arithmetic_Overflow_Check (N);
6681          return;
6682       end if;
6683
6684       --  N + 0 = 0 + N = N for integer types
6685
6686       if Is_Integer_Type (Typ) then
6687          if Compile_Time_Known_Value (Right_Opnd (N))
6688            and then Expr_Value (Right_Opnd (N)) = Uint_0
6689          then
6690             Rewrite (N, Left_Opnd (N));
6691             return;
6692
6693          elsif Compile_Time_Known_Value (Left_Opnd (N))
6694            and then Expr_Value (Left_Opnd (N)) = Uint_0
6695          then
6696             Rewrite (N, Right_Opnd (N));
6697             return;
6698          end if;
6699       end if;
6700
6701       --  Arithmetic overflow checks for signed integer/fixed point types
6702
6703       if Is_Signed_Integer_Type (Typ)
6704         or else Is_Fixed_Point_Type (Typ)
6705       then
6706          Apply_Arithmetic_Overflow_Check (N);
6707          return;
6708
6709       --  Vax floating-point types case
6710
6711       elsif Vax_Float (Typ) then
6712          Expand_Vax_Arith (N);
6713       end if;
6714    end Expand_N_Op_Add;
6715
6716    ---------------------
6717    -- Expand_N_Op_And --
6718    ---------------------
6719
6720    procedure Expand_N_Op_And (N : Node_Id) is
6721       Typ : constant Entity_Id := Etype (N);
6722
6723    begin
6724       Binary_Op_Validity_Checks (N);
6725
6726       if Is_Array_Type (Etype (N)) then
6727          Expand_Boolean_Operator (N);
6728
6729       elsif Is_Boolean_Type (Etype (N)) then
6730          Adjust_Condition (Left_Opnd (N));
6731          Adjust_Condition (Right_Opnd (N));
6732          Set_Etype (N, Standard_Boolean);
6733          Adjust_Result_Type (N, Typ);
6734
6735       elsif Is_Intrinsic_Subprogram (Entity (N)) then
6736          Expand_Intrinsic_Call (N, Entity (N));
6737
6738       end if;
6739    end Expand_N_Op_And;
6740
6741    ------------------------
6742    -- Expand_N_Op_Concat --
6743    ------------------------
6744
6745    procedure Expand_N_Op_Concat (N : Node_Id) is
6746       Opnds : List_Id;
6747       --  List of operands to be concatenated
6748
6749       Cnode : Node_Id;
6750       --  Node which is to be replaced by the result of concatenating the nodes
6751       --  in the list Opnds.
6752
6753    begin
6754       --  Ensure validity of both operands
6755
6756       Binary_Op_Validity_Checks (N);
6757
6758       --  If we are the left operand of a concatenation higher up the tree,
6759       --  then do nothing for now, since we want to deal with a series of
6760       --  concatenations as a unit.
6761
6762       if Nkind (Parent (N)) = N_Op_Concat
6763         and then N = Left_Opnd (Parent (N))
6764       then
6765          return;
6766       end if;
6767
6768       --  We get here with a concatenation whose left operand may be a
6769       --  concatenation itself with a consistent type. We need to process
6770       --  these concatenation operands from left to right, which means
6771       --  from the deepest node in the tree to the highest node.
6772
6773       Cnode := N;
6774       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
6775          Cnode := Left_Opnd (Cnode);
6776       end loop;
6777
6778       --  Now Cnode is the deepest concatenation, and its parents are the
6779       --  concatenation nodes above, so now we process bottom up, doing the
6780       --  operands.
6781
6782       --  The outer loop runs more than once if more than one concatenation
6783       --  type is involved.
6784
6785       Outer : loop
6786          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
6787          Set_Parent (Opnds, N);
6788
6789          --  The inner loop gathers concatenation operands
6790
6791          Inner : while Cnode /= N
6792                    and then Base_Type (Etype (Cnode)) =
6793                             Base_Type (Etype (Parent (Cnode)))
6794          loop
6795             Cnode := Parent (Cnode);
6796             Append (Right_Opnd (Cnode), Opnds);
6797          end loop Inner;
6798
6799          Expand_Concatenate (Cnode, Opnds);
6800
6801          exit Outer when Cnode = N;
6802          Cnode := Parent (Cnode);
6803       end loop Outer;
6804    end Expand_N_Op_Concat;
6805
6806    ------------------------
6807    -- Expand_N_Op_Divide --
6808    ------------------------
6809
6810    procedure Expand_N_Op_Divide (N : Node_Id) is
6811       Loc   : constant Source_Ptr := Sloc (N);
6812       Lopnd : constant Node_Id    := Left_Opnd (N);
6813       Ropnd : constant Node_Id    := Right_Opnd (N);
6814       Ltyp  : constant Entity_Id  := Etype (Lopnd);
6815       Rtyp  : constant Entity_Id  := Etype (Ropnd);
6816       Typ   : Entity_Id           := Etype (N);
6817       Rknow : constant Boolean    := Is_Integer_Type (Typ)
6818                                        and then
6819                                          Compile_Time_Known_Value (Ropnd);
6820       Rval  : Uint;
6821
6822    begin
6823       Binary_Op_Validity_Checks (N);
6824
6825       --  Check for MINIMIZED/ELIMINATED overflow mode
6826
6827       if Minimized_Eliminated_Overflow_Check (N) then
6828          Apply_Arithmetic_Overflow_Check (N);
6829          return;
6830       end if;
6831
6832       --  Otherwise proceed with expansion of division
6833
6834       if Rknow then
6835          Rval := Expr_Value (Ropnd);
6836       end if;
6837
6838       --  N / 1 = N for integer types
6839
6840       if Rknow and then Rval = Uint_1 then
6841          Rewrite (N, Lopnd);
6842          return;
6843       end if;
6844
6845       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
6846       --  Is_Power_Of_2_For_Shift is set means that we know that our left
6847       --  operand is an unsigned integer, as required for this to work.
6848
6849       if Nkind (Ropnd) = N_Op_Expon
6850         and then Is_Power_Of_2_For_Shift (Ropnd)
6851
6852       --  We cannot do this transformation in configurable run time mode if we
6853       --  have 64-bit integers and long shifts are not available.
6854
6855         and then (Esize (Ltyp) <= 32
6856                    or else Support_Long_Shifts_On_Target)
6857       then
6858          Rewrite (N,
6859            Make_Op_Shift_Right (Loc,
6860              Left_Opnd  => Lopnd,
6861              Right_Opnd =>
6862                Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
6863          Analyze_And_Resolve (N, Typ);
6864          return;
6865       end if;
6866
6867       --  Do required fixup of universal fixed operation
6868
6869       if Typ = Universal_Fixed then
6870          Fixup_Universal_Fixed_Operation (N);
6871          Typ := Etype (N);
6872       end if;
6873
6874       --  Divisions with fixed-point results
6875
6876       if Is_Fixed_Point_Type (Typ) then
6877
6878          --  No special processing if Treat_Fixed_As_Integer is set, since
6879          --  from a semantic point of view such operations are simply integer
6880          --  operations and will be treated that way.
6881
6882          if not Treat_Fixed_As_Integer (N) then
6883             if Is_Integer_Type (Rtyp) then
6884                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
6885             else
6886                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
6887             end if;
6888          end if;
6889
6890       --  Other cases of division of fixed-point operands. Again we exclude the
6891       --  case where Treat_Fixed_As_Integer is set.
6892
6893       elsif (Is_Fixed_Point_Type (Ltyp) or else
6894              Is_Fixed_Point_Type (Rtyp))
6895         and then not Treat_Fixed_As_Integer (N)
6896       then
6897          if Is_Integer_Type (Typ) then
6898             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
6899          else
6900             pragma Assert (Is_Floating_Point_Type (Typ));
6901             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
6902          end if;
6903
6904       --  Mixed-mode operations can appear in a non-static universal context,
6905       --  in which case the integer argument must be converted explicitly.
6906
6907       elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
6908          Rewrite (Ropnd,
6909            Convert_To (Universal_Real, Relocate_Node (Ropnd)));
6910
6911          Analyze_And_Resolve (Ropnd, Universal_Real);
6912
6913       elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
6914          Rewrite (Lopnd,
6915            Convert_To (Universal_Real, Relocate_Node (Lopnd)));
6916
6917          Analyze_And_Resolve (Lopnd, Universal_Real);
6918
6919       --  Non-fixed point cases, do integer zero divide and overflow checks
6920
6921       elsif Is_Integer_Type (Typ) then
6922          Apply_Divide_Checks (N);
6923
6924       --  Deal with Vax_Float
6925
6926       elsif Vax_Float (Typ) then
6927          Expand_Vax_Arith (N);
6928          return;
6929       end if;
6930    end Expand_N_Op_Divide;
6931
6932    --------------------
6933    -- Expand_N_Op_Eq --
6934    --------------------
6935
6936    procedure Expand_N_Op_Eq (N : Node_Id) is
6937       Loc    : constant Source_Ptr := Sloc (N);
6938       Typ    : constant Entity_Id  := Etype (N);
6939       Lhs    : constant Node_Id    := Left_Opnd (N);
6940       Rhs    : constant Node_Id    := Right_Opnd (N);
6941       Bodies : constant List_Id    := New_List;
6942       A_Typ  : constant Entity_Id  := Etype (Lhs);
6943
6944       Typl    : Entity_Id := A_Typ;
6945       Op_Name : Entity_Id;
6946       Prim    : Elmt_Id;
6947
6948       procedure Build_Equality_Call (Eq : Entity_Id);
6949       --  If a constructed equality exists for the type or for its parent,
6950       --  build and analyze call, adding conversions if the operation is
6951       --  inherited.
6952
6953       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
6954       --  Determines whether a type has a subcomponent of an unconstrained
6955       --  Unchecked_Union subtype. Typ is a record type.
6956
6957       -------------------------
6958       -- Build_Equality_Call --
6959       -------------------------
6960
6961       procedure Build_Equality_Call (Eq : Entity_Id) is
6962          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
6963          L_Exp   : Node_Id := Relocate_Node (Lhs);
6964          R_Exp   : Node_Id := Relocate_Node (Rhs);
6965
6966       begin
6967          if Base_Type (Op_Type) /= Base_Type (A_Typ)
6968            and then not Is_Class_Wide_Type (A_Typ)
6969          then
6970             L_Exp := OK_Convert_To (Op_Type, L_Exp);
6971             R_Exp := OK_Convert_To (Op_Type, R_Exp);
6972          end if;
6973
6974          --  If we have an Unchecked_Union, we need to add the inferred
6975          --  discriminant values as actuals in the function call. At this
6976          --  point, the expansion has determined that both operands have
6977          --  inferable discriminants.
6978
6979          if Is_Unchecked_Union (Op_Type) then
6980             declare
6981                Lhs_Type      : constant Node_Id := Etype (L_Exp);
6982                Rhs_Type      : constant Node_Id := Etype (R_Exp);
6983                Lhs_Discr_Val : Node_Id;
6984                Rhs_Discr_Val : Node_Id;
6985
6986             begin
6987                --  Per-object constrained selected components require special
6988                --  attention. If the enclosing scope of the component is an
6989                --  Unchecked_Union, we cannot reference its discriminants
6990                --  directly. This is why we use the two extra parameters of
6991                --  the equality function of the enclosing Unchecked_Union.
6992
6993                --  type UU_Type (Discr : Integer := 0) is
6994                --     . . .
6995                --  end record;
6996                --  pragma Unchecked_Union (UU_Type);
6997
6998                --  1. Unchecked_Union enclosing record:
6999
7000                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
7001                --        . . .
7002                --        Comp : UU_Type (Discr);
7003                --        . . .
7004                --     end Enclosing_UU_Type;
7005                --     pragma Unchecked_Union (Enclosing_UU_Type);
7006
7007                --     Obj1 : Enclosing_UU_Type;
7008                --     Obj2 : Enclosing_UU_Type (1);
7009
7010                --     [. . .] Obj1 = Obj2 [. . .]
7011
7012                --     Generated code:
7013
7014                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
7015
7016                --  A and B are the formal parameters of the equality function
7017                --  of Enclosing_UU_Type. The function always has two extra
7018                --  formals to capture the inferred discriminant values.
7019
7020                --  2. Non-Unchecked_Union enclosing record:
7021
7022                --     type
7023                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
7024                --     is record
7025                --        . . .
7026                --        Comp : UU_Type (Discr);
7027                --        . . .
7028                --     end Enclosing_Non_UU_Type;
7029
7030                --     Obj1 : Enclosing_Non_UU_Type;
7031                --     Obj2 : Enclosing_Non_UU_Type (1);
7032
7033                --     ...  Obj1 = Obj2 ...
7034
7035                --     Generated code:
7036
7037                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
7038                --                        obj1.discr, obj2.discr)) then
7039
7040                --  In this case we can directly reference the discriminants of
7041                --  the enclosing record.
7042
7043                --  Lhs of equality
7044
7045                if Nkind (Lhs) = N_Selected_Component
7046                  and then
7047                    Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
7048                then
7049                   --  Enclosing record is an Unchecked_Union, use formal A
7050
7051                   if Is_Unchecked_Union
7052                        (Scope (Entity (Selector_Name (Lhs))))
7053                   then
7054                      Lhs_Discr_Val := Make_Identifier (Loc, Name_A);
7055
7056                   --  Enclosing record is of a non-Unchecked_Union type, it is
7057                   --  possible to reference the discriminant.
7058
7059                   else
7060                      Lhs_Discr_Val :=
7061                        Make_Selected_Component (Loc,
7062                          Prefix => Prefix (Lhs),
7063                          Selector_Name =>
7064                            New_Copy
7065                              (Get_Discriminant_Value
7066                                 (First_Discriminant (Lhs_Type),
7067                                  Lhs_Type,
7068                                  Stored_Constraint (Lhs_Type))));
7069                   end if;
7070
7071                --  Comment needed here ???
7072
7073                else
7074                   --  Infer the discriminant value
7075
7076                   Lhs_Discr_Val :=
7077                     New_Copy
7078                       (Get_Discriminant_Value
7079                          (First_Discriminant (Lhs_Type),
7080                           Lhs_Type,
7081                           Stored_Constraint (Lhs_Type)));
7082                end if;
7083
7084                --  Rhs of equality
7085
7086                if Nkind (Rhs) = N_Selected_Component
7087                  and then
7088                    Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
7089                then
7090                   if Is_Unchecked_Union
7091                        (Scope (Entity (Selector_Name (Rhs))))
7092                   then
7093                      Rhs_Discr_Val := Make_Identifier (Loc, Name_B);
7094
7095                   else
7096                      Rhs_Discr_Val :=
7097                        Make_Selected_Component (Loc,
7098                          Prefix => Prefix (Rhs),
7099                          Selector_Name =>
7100                            New_Copy (Get_Discriminant_Value (
7101                              First_Discriminant (Rhs_Type),
7102                              Rhs_Type,
7103                              Stored_Constraint (Rhs_Type))));
7104
7105                   end if;
7106                else
7107                   Rhs_Discr_Val :=
7108                     New_Copy (Get_Discriminant_Value (
7109                       First_Discriminant (Rhs_Type),
7110                       Rhs_Type,
7111                       Stored_Constraint (Rhs_Type)));
7112
7113                end if;
7114
7115                Rewrite (N,
7116                  Make_Function_Call (Loc,
7117                    Name => New_Reference_To (Eq, Loc),
7118                    Parameter_Associations => New_List (
7119                      L_Exp,
7120                      R_Exp,
7121                      Lhs_Discr_Val,
7122                      Rhs_Discr_Val)));
7123             end;
7124
7125          --  Normal case, not an unchecked union
7126
7127          else
7128             Rewrite (N,
7129               Make_Function_Call (Loc,
7130                 Name => New_Reference_To (Eq, Loc),
7131                 Parameter_Associations => New_List (L_Exp, R_Exp)));
7132          end if;
7133
7134          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7135       end Build_Equality_Call;
7136
7137       ------------------------------------
7138       -- Has_Unconstrained_UU_Component --
7139       ------------------------------------
7140
7141       function Has_Unconstrained_UU_Component
7142         (Typ : Node_Id) return Boolean
7143       is
7144          Tdef  : constant Node_Id :=
7145                    Type_Definition (Declaration_Node (Base_Type (Typ)));
7146          Clist : Node_Id;
7147          Vpart : Node_Id;
7148
7149          function Component_Is_Unconstrained_UU
7150            (Comp : Node_Id) return Boolean;
7151          --  Determines whether the subtype of the component is an
7152          --  unconstrained Unchecked_Union.
7153
7154          function Variant_Is_Unconstrained_UU
7155            (Variant : Node_Id) return Boolean;
7156          --  Determines whether a component of the variant has an unconstrained
7157          --  Unchecked_Union subtype.
7158
7159          -----------------------------------
7160          -- Component_Is_Unconstrained_UU --
7161          -----------------------------------
7162
7163          function Component_Is_Unconstrained_UU
7164            (Comp : Node_Id) return Boolean
7165          is
7166          begin
7167             if Nkind (Comp) /= N_Component_Declaration then
7168                return False;
7169             end if;
7170
7171             declare
7172                Sindic : constant Node_Id :=
7173                           Subtype_Indication (Component_Definition (Comp));
7174
7175             begin
7176                --  Unconstrained nominal type. In the case of a constraint
7177                --  present, the node kind would have been N_Subtype_Indication.
7178
7179                if Nkind (Sindic) = N_Identifier then
7180                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
7181                end if;
7182
7183                return False;
7184             end;
7185          end Component_Is_Unconstrained_UU;
7186
7187          ---------------------------------
7188          -- Variant_Is_Unconstrained_UU --
7189          ---------------------------------
7190
7191          function Variant_Is_Unconstrained_UU
7192            (Variant : Node_Id) return Boolean
7193          is
7194             Clist : constant Node_Id := Component_List (Variant);
7195
7196          begin
7197             if Is_Empty_List (Component_Items (Clist)) then
7198                return False;
7199             end if;
7200
7201             --  We only need to test one component
7202
7203             declare
7204                Comp : Node_Id := First (Component_Items (Clist));
7205
7206             begin
7207                while Present (Comp) loop
7208                   if Component_Is_Unconstrained_UU (Comp) then
7209                      return True;
7210                   end if;
7211
7212                   Next (Comp);
7213                end loop;
7214             end;
7215
7216             --  None of the components withing the variant were of
7217             --  unconstrained Unchecked_Union type.
7218
7219             return False;
7220          end Variant_Is_Unconstrained_UU;
7221
7222       --  Start of processing for Has_Unconstrained_UU_Component
7223
7224       begin
7225          if Null_Present (Tdef) then
7226             return False;
7227          end if;
7228
7229          Clist := Component_List (Tdef);
7230          Vpart := Variant_Part (Clist);
7231
7232          --  Inspect available components
7233
7234          if Present (Component_Items (Clist)) then
7235             declare
7236                Comp : Node_Id := First (Component_Items (Clist));
7237
7238             begin
7239                while Present (Comp) loop
7240
7241                   --  One component is sufficient
7242
7243                   if Component_Is_Unconstrained_UU (Comp) then
7244                      return True;
7245                   end if;
7246
7247                   Next (Comp);
7248                end loop;
7249             end;
7250          end if;
7251
7252          --  Inspect available components withing variants
7253
7254          if Present (Vpart) then
7255             declare
7256                Variant : Node_Id := First (Variants (Vpart));
7257
7258             begin
7259                while Present (Variant) loop
7260
7261                   --  One component within a variant is sufficient
7262
7263                   if Variant_Is_Unconstrained_UU (Variant) then
7264                      return True;
7265                   end if;
7266
7267                   Next (Variant);
7268                end loop;
7269             end;
7270          end if;
7271
7272          --  Neither the available components, nor the components inside the
7273          --  variant parts were of an unconstrained Unchecked_Union subtype.
7274
7275          return False;
7276       end Has_Unconstrained_UU_Component;
7277
7278    --  Start of processing for Expand_N_Op_Eq
7279
7280    begin
7281       Binary_Op_Validity_Checks (N);
7282
7283       --  Deal with private types
7284
7285       if Ekind (Typl) = E_Private_Type then
7286          Typl := Underlying_Type (Typl);
7287       elsif Ekind (Typl) = E_Private_Subtype then
7288          Typl := Underlying_Type (Base_Type (Typl));
7289       else
7290          null;
7291       end if;
7292
7293       --  It may happen in error situations that the underlying type is not
7294       --  set. The error will be detected later, here we just defend the
7295       --  expander code.
7296
7297       if No (Typl) then
7298          return;
7299       end if;
7300
7301       Typl := Base_Type (Typl);
7302
7303       --  Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7304       --  means we no longer have a comparison operation, we are all done.
7305
7306       Expand_Compare_Minimize_Eliminate_Overflow (N);
7307
7308       if Nkind (N) /= N_Op_Eq then
7309          return;
7310       end if;
7311
7312       --  Boolean types (requiring handling of non-standard case)
7313
7314       if Is_Boolean_Type (Typl) then
7315          Adjust_Condition (Left_Opnd (N));
7316          Adjust_Condition (Right_Opnd (N));
7317          Set_Etype (N, Standard_Boolean);
7318          Adjust_Result_Type (N, Typ);
7319
7320       --  Array types
7321
7322       elsif Is_Array_Type (Typl) then
7323
7324          --  If we are doing full validity checking, and it is possible for the
7325          --  array elements to be invalid then expand out array comparisons to
7326          --  make sure that we check the array elements.
7327
7328          if Validity_Check_Operands
7329            and then not Is_Known_Valid (Component_Type (Typl))
7330          then
7331             declare
7332                Save_Force_Validity_Checks : constant Boolean :=
7333                                               Force_Validity_Checks;
7334             begin
7335                Force_Validity_Checks := True;
7336                Rewrite (N,
7337                  Expand_Array_Equality
7338                   (N,
7339                    Relocate_Node (Lhs),
7340                    Relocate_Node (Rhs),
7341                    Bodies,
7342                    Typl));
7343                Insert_Actions (N, Bodies);
7344                Analyze_And_Resolve (N, Standard_Boolean);
7345                Force_Validity_Checks := Save_Force_Validity_Checks;
7346             end;
7347
7348          --  Packed case where both operands are known aligned
7349
7350          elsif Is_Bit_Packed_Array (Typl)
7351            and then not Is_Possibly_Unaligned_Object (Lhs)
7352            and then not Is_Possibly_Unaligned_Object (Rhs)
7353          then
7354             Expand_Packed_Eq (N);
7355
7356          --  Where the component type is elementary we can use a block bit
7357          --  comparison (if supported on the target) exception in the case
7358          --  of floating-point (negative zero issues require element by
7359          --  element comparison), and atomic types (where we must be sure
7360          --  to load elements independently) and possibly unaligned arrays.
7361
7362          elsif Is_Elementary_Type (Component_Type (Typl))
7363            and then not Is_Floating_Point_Type (Component_Type (Typl))
7364            and then not Is_Atomic (Component_Type (Typl))
7365            and then not Is_Possibly_Unaligned_Object (Lhs)
7366            and then not Is_Possibly_Unaligned_Object (Rhs)
7367            and then Support_Composite_Compare_On_Target
7368          then
7369             null;
7370
7371          --  For composite and floating-point cases, expand equality loop to
7372          --  make sure of using proper comparisons for tagged types, and
7373          --  correctly handling the floating-point case.
7374
7375          else
7376             Rewrite (N,
7377               Expand_Array_Equality
7378                 (N,
7379                  Relocate_Node (Lhs),
7380                  Relocate_Node (Rhs),
7381                  Bodies,
7382                  Typl));
7383             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
7384             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7385          end if;
7386
7387       --  Record Types
7388
7389       elsif Is_Record_Type (Typl) then
7390
7391          --  For tagged types, use the primitive "="
7392
7393          if Is_Tagged_Type (Typl) then
7394
7395             --  No need to do anything else compiling under restriction
7396             --  No_Dispatching_Calls. During the semantic analysis we
7397             --  already notified such violation.
7398
7399             if Restriction_Active (No_Dispatching_Calls) then
7400                return;
7401             end if;
7402
7403             --  If this is derived from an untagged private type completed with
7404             --  a tagged type, it does not have a full view, so we use the
7405             --  primitive operations of the private type. This check should no
7406             --  longer be necessary when these types get their full views???
7407
7408             if Is_Private_Type (A_Typ)
7409               and then not Is_Tagged_Type (A_Typ)
7410               and then Is_Derived_Type (A_Typ)
7411               and then No (Full_View (A_Typ))
7412             then
7413                --  Search for equality operation, checking that the operands
7414                --  have the same type. Note that we must find a matching entry,
7415                --  or something is very wrong!
7416
7417                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
7418
7419                while Present (Prim) loop
7420                   exit when Chars (Node (Prim)) = Name_Op_Eq
7421                     and then Etype (First_Formal (Node (Prim))) =
7422                              Etype (Next_Formal (First_Formal (Node (Prim))))
7423                     and then
7424                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7425
7426                   Next_Elmt (Prim);
7427                end loop;
7428
7429                pragma Assert (Present (Prim));
7430                Op_Name := Node (Prim);
7431
7432             --  Find the type's predefined equality or an overriding
7433             --  user- defined equality. The reason for not simply calling
7434             --  Find_Prim_Op here is that there may be a user-defined
7435             --  overloaded equality op that precedes the equality that we want,
7436             --  so we have to explicitly search (e.g., there could be an
7437             --  equality with two different parameter types).
7438
7439             else
7440                if Is_Class_Wide_Type (Typl) then
7441                   Typl := Root_Type (Typl);
7442                end if;
7443
7444                Prim := First_Elmt (Primitive_Operations (Typl));
7445                while Present (Prim) loop
7446                   exit when Chars (Node (Prim)) = Name_Op_Eq
7447                     and then Etype (First_Formal (Node (Prim))) =
7448                              Etype (Next_Formal (First_Formal (Node (Prim))))
7449                     and then
7450                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
7451
7452                   Next_Elmt (Prim);
7453                end loop;
7454
7455                pragma Assert (Present (Prim));
7456                Op_Name := Node (Prim);
7457             end if;
7458
7459             Build_Equality_Call (Op_Name);
7460
7461          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
7462          --  predefined equality operator for a type which has a subcomponent
7463          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
7464
7465          elsif Has_Unconstrained_UU_Component (Typl) then
7466             Insert_Action (N,
7467               Make_Raise_Program_Error (Loc,
7468                 Reason => PE_Unchecked_Union_Restriction));
7469
7470             --  Prevent Gigi from generating incorrect code by rewriting the
7471             --  equality as a standard False. (is this documented somewhere???)
7472
7473             Rewrite (N,
7474               New_Occurrence_Of (Standard_False, Loc));
7475
7476          elsif Is_Unchecked_Union (Typl) then
7477
7478             --  If we can infer the discriminants of the operands, we make a
7479             --  call to the TSS equality function.
7480
7481             if Has_Inferable_Discriminants (Lhs)
7482                  and then
7483                Has_Inferable_Discriminants (Rhs)
7484             then
7485                Build_Equality_Call
7486                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
7487
7488             else
7489                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
7490                --  the predefined equality operator for an Unchecked_Union type
7491                --  if either of the operands lack inferable discriminants.
7492
7493                Insert_Action (N,
7494                  Make_Raise_Program_Error (Loc,
7495                    Reason => PE_Unchecked_Union_Restriction));
7496
7497                --  Prevent Gigi from generating incorrect code by rewriting
7498                --  the equality as a standard False (documented where???).
7499
7500                Rewrite (N,
7501                  New_Occurrence_Of (Standard_False, Loc));
7502
7503             end if;
7504
7505          --  If a type support function is present (for complex cases), use it
7506
7507          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
7508             Build_Equality_Call
7509               (TSS (Root_Type (Typl), TSS_Composite_Equality));
7510
7511          --  Otherwise expand the component by component equality. Note that
7512          --  we never use block-bit comparisons for records, because of the
7513          --  problems with gaps. The backend will often be able to recombine
7514          --  the separate comparisons that we generate here.
7515
7516          else
7517             Remove_Side_Effects (Lhs);
7518             Remove_Side_Effects (Rhs);
7519             Rewrite (N,
7520               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
7521
7522             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
7523             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
7524          end if;
7525       end if;
7526
7527       --  Test if result is known at compile time
7528
7529       Rewrite_Comparison (N);
7530
7531       --  If we still have comparison for Vax_Float, process it
7532
7533       if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare  then
7534          Expand_Vax_Comparison (N);
7535          return;
7536       end if;
7537
7538       Optimize_Length_Comparison (N);
7539    end Expand_N_Op_Eq;
7540
7541    -----------------------
7542    -- Expand_N_Op_Expon --
7543    -----------------------
7544
7545    procedure Expand_N_Op_Expon (N : Node_Id) is
7546       Loc    : constant Source_Ptr := Sloc (N);
7547       Typ    : constant Entity_Id  := Etype (N);
7548       Rtyp   : constant Entity_Id  := Root_Type (Typ);
7549       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
7550       Bastyp : constant Node_Id    := Etype (Base);
7551       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
7552       Exptyp : constant Entity_Id  := Etype (Exp);
7553       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
7554       Expv   : Uint;
7555       Temp   : Node_Id;
7556       Rent   : RE_Id;
7557       Ent    : Entity_Id;
7558       Etyp   : Entity_Id;
7559       Xnode  : Node_Id;
7560
7561    begin
7562       Binary_Op_Validity_Checks (N);
7563
7564       --  CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
7565
7566       if CodePeer_Mode or Alfa_Mode then
7567          return;
7568       end if;
7569
7570       --  If either operand is of a private type, then we have the use of an
7571       --  intrinsic operator, and we get rid of the privateness, by using root
7572       --  types of underlying types for the actual operation. Otherwise the
7573       --  private types will cause trouble if we expand multiplications or
7574       --  shifts etc. We also do this transformation if the result type is
7575       --  different from the base type.
7576
7577       if Is_Private_Type (Etype (Base))
7578         or else Is_Private_Type (Typ)
7579         or else Is_Private_Type (Exptyp)
7580         or else Rtyp /= Root_Type (Bastyp)
7581       then
7582          declare
7583             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
7584             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
7585
7586          begin
7587             Rewrite (N,
7588               Unchecked_Convert_To (Typ,
7589                 Make_Op_Expon (Loc,
7590                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
7591                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
7592             Analyze_And_Resolve (N, Typ);
7593             return;
7594          end;
7595       end if;
7596
7597       --  Check for MINIMIZED/ELIMINATED overflow mode
7598
7599       if Minimized_Eliminated_Overflow_Check (N) then
7600          Apply_Arithmetic_Overflow_Check (N);
7601          return;
7602       end if;
7603
7604       --  Test for case of known right argument where we can replace the
7605       --  exponentiation by an equivalent expression using multiplication.
7606
7607       if Compile_Time_Known_Value (Exp) then
7608          Expv := Expr_Value (Exp);
7609
7610          --  We only fold small non-negative exponents. You might think we
7611          --  could fold small negative exponents for the real case, but we
7612          --  can't because we are required to raise Constraint_Error for
7613          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
7614          --  See ACVC test C4A012B.
7615
7616          if Expv >= 0 and then Expv <= 4 then
7617
7618             --  X ** 0 = 1 (or 1.0)
7619
7620             if Expv = 0 then
7621
7622                --  Call Remove_Side_Effects to ensure that any side effects
7623                --  in the ignored left operand (in particular function calls
7624                --  to user defined functions) are properly executed.
7625
7626                Remove_Side_Effects (Base);
7627
7628                if Ekind (Typ) in Integer_Kind then
7629                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
7630                else
7631                   Xnode := Make_Real_Literal (Loc, Ureal_1);
7632                end if;
7633
7634             --  X ** 1 = X
7635
7636             elsif Expv = 1 then
7637                Xnode := Base;
7638
7639             --  X ** 2 = X * X
7640
7641             elsif Expv = 2 then
7642                Xnode :=
7643                  Make_Op_Multiply (Loc,
7644                    Left_Opnd  => Duplicate_Subexpr (Base),
7645                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
7646
7647             --  X ** 3 = X * X * X
7648
7649             elsif Expv = 3 then
7650                Xnode :=
7651                  Make_Op_Multiply (Loc,
7652                    Left_Opnd =>
7653                      Make_Op_Multiply (Loc,
7654                        Left_Opnd  => Duplicate_Subexpr (Base),
7655                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
7656                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
7657
7658             --  X ** 4  ->
7659
7660             --  do
7661             --    En : constant base'type := base * base;
7662             --  in
7663             --    En * En
7664
7665             else
7666                pragma Assert (Expv = 4);
7667                Temp := Make_Temporary (Loc, 'E', Base);
7668
7669                Xnode :=
7670                  Make_Expression_With_Actions (Loc,
7671                    Actions    => New_List (
7672                      Make_Object_Declaration (Loc,
7673                        Defining_Identifier => Temp,
7674                        Constant_Present    => True,
7675                        Object_Definition   => New_Reference_To (Typ, Loc),
7676                        Expression =>
7677                          Make_Op_Multiply (Loc,
7678                            Left_Opnd  =>
7679                              Duplicate_Subexpr (Base),
7680                            Right_Opnd =>
7681                              Duplicate_Subexpr_No_Checks (Base)))),
7682
7683                    Expression =>
7684                      Make_Op_Multiply (Loc,
7685                        Left_Opnd  => New_Reference_To (Temp, Loc),
7686                        Right_Opnd => New_Reference_To (Temp, Loc)));
7687             end if;
7688
7689             Rewrite (N, Xnode);
7690             Analyze_And_Resolve (N, Typ);
7691             return;
7692          end if;
7693       end if;
7694
7695       --  Case of (2 ** expression) appearing as an argument of an integer
7696       --  multiplication, or as the right argument of a division of a non-
7697       --  negative integer. In such cases we leave the node untouched, setting
7698       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
7699       --  of the higher level node converts it into a shift.
7700
7701       --  Another case is 2 ** N in any other context. We simply convert
7702       --  this to 1 * 2 ** N, and then the above transformation applies.
7703
7704       --  Note: this transformation is not applicable for a modular type with
7705       --  a non-binary modulus in the multiplication case, since we get a wrong
7706       --  result if the shift causes an overflow before the modular reduction.
7707
7708       if Nkind (Base) = N_Integer_Literal
7709         and then Intval (Base) = 2
7710         and then Is_Integer_Type (Root_Type (Exptyp))
7711         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
7712         and then Is_Unsigned_Type (Exptyp)
7713         and then not Ovflo
7714       then
7715          --  First the multiply and divide cases
7716
7717          if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
7718             declare
7719                P : constant Node_Id := Parent (N);
7720                L : constant Node_Id := Left_Opnd (P);
7721                R : constant Node_Id := Right_Opnd (P);
7722
7723             begin
7724                if (Nkind (P) = N_Op_Multiply
7725                    and then not Non_Binary_Modulus (Typ)
7726                    and then
7727                      ((Is_Integer_Type (Etype (L)) and then R = N)
7728                          or else
7729                       (Is_Integer_Type (Etype (R)) and then L = N))
7730                    and then not Do_Overflow_Check (P))
7731                  or else
7732                   (Nkind (P) = N_Op_Divide
7733                     and then Is_Integer_Type (Etype (L))
7734                     and then Is_Unsigned_Type (Etype (L))
7735                     and then R = N
7736                     and then not Do_Overflow_Check (P))
7737                then
7738                   Set_Is_Power_Of_2_For_Shift (N);
7739                   return;
7740                end if;
7741             end;
7742
7743          --  Now the other cases
7744
7745          elsif not Non_Binary_Modulus (Typ) then
7746             Rewrite (N,
7747               Make_Op_Multiply (Loc,
7748                 Left_Opnd  => Make_Integer_Literal (Loc, 1),
7749                 Right_Opnd => Relocate_Node (N)));
7750             Analyze_And_Resolve (N, Typ);
7751             return;
7752          end if;
7753       end if;
7754
7755       --  Fall through if exponentiation must be done using a runtime routine
7756
7757       --  First deal with modular case
7758
7759       if Is_Modular_Integer_Type (Rtyp) then
7760
7761          --  Non-binary case, we call the special exponentiation routine for
7762          --  the non-binary case, converting the argument to Long_Long_Integer
7763          --  and passing the modulus value. Then the result is converted back
7764          --  to the base type.
7765
7766          if Non_Binary_Modulus (Rtyp) then
7767             Rewrite (N,
7768               Convert_To (Typ,
7769                 Make_Function_Call (Loc,
7770                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
7771                   Parameter_Associations => New_List (
7772                     Convert_To (Standard_Integer, Base),
7773                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
7774                     Exp))));
7775
7776          --  Binary case, in this case, we call one of two routines, either the
7777          --  unsigned integer case, or the unsigned long long integer case,
7778          --  with a final "and" operation to do the required mod.
7779
7780          else
7781             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
7782                Ent := RTE (RE_Exp_Unsigned);
7783             else
7784                Ent := RTE (RE_Exp_Long_Long_Unsigned);
7785             end if;
7786
7787             Rewrite (N,
7788               Convert_To (Typ,
7789                 Make_Op_And (Loc,
7790                   Left_Opnd =>
7791                     Make_Function_Call (Loc,
7792                       Name => New_Reference_To (Ent, Loc),
7793                       Parameter_Associations => New_List (
7794                         Convert_To (Etype (First_Formal (Ent)), Base),
7795                         Exp)),
7796                    Right_Opnd =>
7797                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
7798
7799          end if;
7800
7801          --  Common exit point for modular type case
7802
7803          Analyze_And_Resolve (N, Typ);
7804          return;
7805
7806       --  Signed integer cases, done using either Integer or Long_Long_Integer.
7807       --  It is not worth having routines for Short_[Short_]Integer, since for
7808       --  most machines it would not help, and it would generate more code that
7809       --  might need certification when a certified run time is required.
7810
7811       --  In the integer cases, we have two routines, one for when overflow
7812       --  checks are required, and one when they are not required, since there
7813       --  is a real gain in omitting checks on many machines.
7814
7815       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
7816         or else (Rtyp = Base_Type (Standard_Long_Integer)
7817                    and then
7818                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
7819         or else (Rtyp = Universal_Integer)
7820       then
7821          Etyp := Standard_Long_Long_Integer;
7822
7823          if Ovflo then
7824             Rent := RE_Exp_Long_Long_Integer;
7825          else
7826             Rent := RE_Exn_Long_Long_Integer;
7827          end if;
7828
7829       elsif Is_Signed_Integer_Type (Rtyp) then
7830          Etyp := Standard_Integer;
7831
7832          if Ovflo then
7833             Rent := RE_Exp_Integer;
7834          else
7835             Rent := RE_Exn_Integer;
7836          end if;
7837
7838       --  Floating-point cases, always done using Long_Long_Float. We do not
7839       --  need separate routines for the overflow case here, since in the case
7840       --  of floating-point, we generate infinities anyway as a rule (either
7841       --  that or we automatically trap overflow), and if there is an infinity
7842       --  generated and a range check is required, the check will fail anyway.
7843
7844       else
7845          pragma Assert (Is_Floating_Point_Type (Rtyp));
7846          Etyp := Standard_Long_Long_Float;
7847          Rent := RE_Exn_Long_Long_Float;
7848       end if;
7849
7850       --  Common processing for integer cases and floating-point cases.
7851       --  If we are in the right type, we can call runtime routine directly
7852
7853       if Typ = Etyp
7854         and then Rtyp /= Universal_Integer
7855         and then Rtyp /= Universal_Real
7856       then
7857          Rewrite (N,
7858            Make_Function_Call (Loc,
7859              Name => New_Reference_To (RTE (Rent), Loc),
7860              Parameter_Associations => New_List (Base, Exp)));
7861
7862       --  Otherwise we have to introduce conversions (conversions are also
7863       --  required in the universal cases, since the runtime routine is
7864       --  typed using one of the standard types).
7865
7866       else
7867          Rewrite (N,
7868            Convert_To (Typ,
7869              Make_Function_Call (Loc,
7870                Name => New_Reference_To (RTE (Rent), Loc),
7871                Parameter_Associations => New_List (
7872                  Convert_To (Etyp, Base),
7873                  Exp))));
7874       end if;
7875
7876       Analyze_And_Resolve (N, Typ);
7877       return;
7878
7879    exception
7880       when RE_Not_Available =>
7881          return;
7882    end Expand_N_Op_Expon;
7883
7884    --------------------
7885    -- Expand_N_Op_Ge --
7886    --------------------
7887
7888    procedure Expand_N_Op_Ge (N : Node_Id) is
7889       Typ  : constant Entity_Id := Etype (N);
7890       Op1  : constant Node_Id   := Left_Opnd (N);
7891       Op2  : constant Node_Id   := Right_Opnd (N);
7892       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7893
7894    begin
7895       Binary_Op_Validity_Checks (N);
7896
7897       --  Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7898       --  means we no longer have a comparison operation, we are all done.
7899
7900       Expand_Compare_Minimize_Eliminate_Overflow (N);
7901
7902       if Nkind (N) /= N_Op_Ge then
7903          return;
7904       end if;
7905
7906       --  Array type case
7907
7908       if Is_Array_Type (Typ1) then
7909          Expand_Array_Comparison (N);
7910          return;
7911       end if;
7912
7913       --  Deal with boolean operands
7914
7915       if Is_Boolean_Type (Typ1) then
7916          Adjust_Condition (Op1);
7917          Adjust_Condition (Op2);
7918          Set_Etype (N, Standard_Boolean);
7919          Adjust_Result_Type (N, Typ);
7920       end if;
7921
7922       Rewrite_Comparison (N);
7923
7924       --  If we still have comparison, and Vax_Float type, process it
7925
7926       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
7927          Expand_Vax_Comparison (N);
7928          return;
7929       end if;
7930
7931       Optimize_Length_Comparison (N);
7932    end Expand_N_Op_Ge;
7933
7934    --------------------
7935    -- Expand_N_Op_Gt --
7936    --------------------
7937
7938    procedure Expand_N_Op_Gt (N : Node_Id) is
7939       Typ  : constant Entity_Id := Etype (N);
7940       Op1  : constant Node_Id   := Left_Opnd (N);
7941       Op2  : constant Node_Id   := Right_Opnd (N);
7942       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7943
7944    begin
7945       Binary_Op_Validity_Checks (N);
7946
7947       --  Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7948       --  means we no longer have a comparison operation, we are all done.
7949
7950       Expand_Compare_Minimize_Eliminate_Overflow (N);
7951
7952       if Nkind (N) /= N_Op_Gt then
7953          return;
7954       end if;
7955
7956       --  Deal with array type operands
7957
7958       if Is_Array_Type (Typ1) then
7959          Expand_Array_Comparison (N);
7960          return;
7961       end if;
7962
7963       --  Deal with boolean type operands
7964
7965       if Is_Boolean_Type (Typ1) then
7966          Adjust_Condition (Op1);
7967          Adjust_Condition (Op2);
7968          Set_Etype (N, Standard_Boolean);
7969          Adjust_Result_Type (N, Typ);
7970       end if;
7971
7972       Rewrite_Comparison (N);
7973
7974       --  If we still have comparison, and Vax_Float type, process it
7975
7976       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
7977          Expand_Vax_Comparison (N);
7978          return;
7979       end if;
7980
7981       Optimize_Length_Comparison (N);
7982    end Expand_N_Op_Gt;
7983
7984    --------------------
7985    -- Expand_N_Op_Le --
7986    --------------------
7987
7988    procedure Expand_N_Op_Le (N : Node_Id) is
7989       Typ  : constant Entity_Id := Etype (N);
7990       Op1  : constant Node_Id   := Left_Opnd (N);
7991       Op2  : constant Node_Id   := Right_Opnd (N);
7992       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
7993
7994    begin
7995       Binary_Op_Validity_Checks (N);
7996
7997       --  Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
7998       --  means we no longer have a comparison operation, we are all done.
7999
8000       Expand_Compare_Minimize_Eliminate_Overflow (N);
8001
8002       if Nkind (N) /= N_Op_Le then
8003          return;
8004       end if;
8005
8006       --  Deal with array type operands
8007
8008       if Is_Array_Type (Typ1) then
8009          Expand_Array_Comparison (N);
8010          return;
8011       end if;
8012
8013       --  Deal with Boolean type operands
8014
8015       if Is_Boolean_Type (Typ1) then
8016          Adjust_Condition (Op1);
8017          Adjust_Condition (Op2);
8018          Set_Etype (N, Standard_Boolean);
8019          Adjust_Result_Type (N, Typ);
8020       end if;
8021
8022       Rewrite_Comparison (N);
8023
8024       --  If we still have comparison, and Vax_Float type, process it
8025
8026       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
8027          Expand_Vax_Comparison (N);
8028          return;
8029       end if;
8030
8031       Optimize_Length_Comparison (N);
8032    end Expand_N_Op_Le;
8033
8034    --------------------
8035    -- Expand_N_Op_Lt --
8036    --------------------
8037
8038    procedure Expand_N_Op_Lt (N : Node_Id) is
8039       Typ  : constant Entity_Id := Etype (N);
8040       Op1  : constant Node_Id   := Left_Opnd (N);
8041       Op2  : constant Node_Id   := Right_Opnd (N);
8042       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
8043
8044    begin
8045       Binary_Op_Validity_Checks (N);
8046
8047       --  Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
8048       --  means we no longer have a comparison operation, we are all done.
8049
8050       Expand_Compare_Minimize_Eliminate_Overflow (N);
8051
8052       if Nkind (N) /= N_Op_Lt then
8053          return;
8054       end if;
8055
8056       --  Deal with array type operands
8057
8058       if Is_Array_Type (Typ1) then
8059          Expand_Array_Comparison (N);
8060          return;
8061       end if;
8062
8063       --  Deal with Boolean type operands
8064
8065       if Is_Boolean_Type (Typ1) then
8066          Adjust_Condition (Op1);
8067          Adjust_Condition (Op2);
8068          Set_Etype (N, Standard_Boolean);
8069          Adjust_Result_Type (N, Typ);
8070       end if;
8071
8072       Rewrite_Comparison (N);
8073
8074       --  If we still have comparison, and Vax_Float type, process it
8075
8076       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
8077          Expand_Vax_Comparison (N);
8078          return;
8079       end if;
8080
8081       Optimize_Length_Comparison (N);
8082    end Expand_N_Op_Lt;
8083
8084    -----------------------
8085    -- Expand_N_Op_Minus --
8086    -----------------------
8087
8088    procedure Expand_N_Op_Minus (N : Node_Id) is
8089       Loc : constant Source_Ptr := Sloc (N);
8090       Typ : constant Entity_Id  := Etype (N);
8091
8092    begin
8093       Unary_Op_Validity_Checks (N);
8094
8095       --  Check for MINIMIZED/ELIMINATED overflow mode
8096
8097       if Minimized_Eliminated_Overflow_Check (N) then
8098          Apply_Arithmetic_Overflow_Check (N);
8099          return;
8100       end if;
8101
8102       if not Backend_Overflow_Checks_On_Target
8103          and then Is_Signed_Integer_Type (Etype (N))
8104          and then Do_Overflow_Check (N)
8105       then
8106          --  Software overflow checking expands -expr into (0 - expr)
8107
8108          Rewrite (N,
8109            Make_Op_Subtract (Loc,
8110              Left_Opnd  => Make_Integer_Literal (Loc, 0),
8111              Right_Opnd => Right_Opnd (N)));
8112
8113          Analyze_And_Resolve (N, Typ);
8114
8115       --  Vax floating-point types case
8116
8117       elsif Vax_Float (Etype (N)) then
8118          Expand_Vax_Arith (N);
8119       end if;
8120    end Expand_N_Op_Minus;
8121
8122    ---------------------
8123    -- Expand_N_Op_Mod --
8124    ---------------------
8125
8126    procedure Expand_N_Op_Mod (N : Node_Id) is
8127       Loc   : constant Source_Ptr := Sloc (N);
8128       Typ   : constant Entity_Id  := Etype (N);
8129       DDC   : constant Boolean    := Do_Division_Check (N);
8130
8131       Left  : Node_Id;
8132       Right : Node_Id;
8133
8134       LLB : Uint;
8135       Llo : Uint;
8136       Lhi : Uint;
8137       LOK : Boolean;
8138       Rlo : Uint;
8139       Rhi : Uint;
8140       ROK : Boolean;
8141
8142       pragma Warnings (Off, Lhi);
8143
8144    begin
8145       Binary_Op_Validity_Checks (N);
8146
8147       --  Check for MINIMIZED/ELIMINATED overflow mode
8148
8149       if Minimized_Eliminated_Overflow_Check (N) then
8150          Apply_Arithmetic_Overflow_Check (N);
8151          return;
8152       end if;
8153
8154       if Is_Integer_Type (Etype (N)) then
8155          Apply_Divide_Checks (N);
8156
8157          --  All done if we don't have a MOD any more, which can happen as a
8158          --  result of overflow expansion in MINIMIZED or ELIMINATED modes.
8159
8160          if Nkind (N) /= N_Op_Mod then
8161             return;
8162          end if;
8163       end if;
8164
8165       --  Proceed with expansion of mod operator
8166
8167       Left  := Left_Opnd (N);
8168       Right := Right_Opnd (N);
8169
8170       Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
8171       Determine_Range (Left,  LOK, Llo, Lhi, Assume_Valid => True);
8172
8173       --  Convert mod to rem if operands are known non-negative. We do this
8174       --  since it is quite likely that this will improve the quality of code,
8175       --  (the operation now corresponds to the hardware remainder), and it
8176       --  does not seem likely that it could be harmful.
8177
8178       if LOK and then Llo >= 0 and then ROK and then Rlo >= 0 then
8179          Rewrite (N,
8180            Make_Op_Rem (Sloc (N),
8181              Left_Opnd  => Left_Opnd (N),
8182              Right_Opnd => Right_Opnd (N)));
8183
8184          --  Instead of reanalyzing the node we do the analysis manually. This
8185          --  avoids anomalies when the replacement is done in an instance and
8186          --  is epsilon more efficient.
8187
8188          Set_Entity            (N, Standard_Entity (S_Op_Rem));
8189          Set_Etype             (N, Typ);
8190          Set_Do_Division_Check (N, DDC);
8191          Expand_N_Op_Rem (N);
8192          Set_Analyzed (N);
8193
8194       --  Otherwise, normal mod processing
8195
8196       else
8197          --  Apply optimization x mod 1 = 0. We don't really need that with
8198          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
8199          --  certainly harmless.
8200
8201          if Is_Integer_Type (Etype (N))
8202            and then Compile_Time_Known_Value (Right)
8203            and then Expr_Value (Right) = Uint_1
8204          then
8205             --  Call Remove_Side_Effects to ensure that any side effects in
8206             --  the ignored left operand (in particular function calls to
8207             --  user defined functions) are properly executed.
8208
8209             Remove_Side_Effects (Left);
8210
8211             Rewrite (N, Make_Integer_Literal (Loc, 0));
8212             Analyze_And_Resolve (N, Typ);
8213             return;
8214          end if;
8215
8216          --  Deal with annoying case of largest negative number remainder
8217          --  minus one. Gigi may not handle this case correctly, because
8218          --  on some targets, the mod value is computed using a divide
8219          --  instruction which gives an overflow trap for this case.
8220
8221          --  It would be a bit more efficient to figure out which targets
8222          --  this is really needed for, but in practice it is reasonable
8223          --  to do the following special check in all cases, since it means
8224          --  we get a clearer message, and also the overhead is minimal given
8225          --  that division is expensive in any case.
8226
8227          --  In fact the check is quite easy, if the right operand is -1, then
8228          --  the mod value is always 0, and we can just ignore the left operand
8229          --  completely in this case.
8230
8231          --  This only applies if we still have a mod operator. Skip if we
8232          --  have already rewritten this (e.g. in the case of eliminated
8233          --  overflow checks which have driven us into bignum mode).
8234
8235          if Nkind (N) = N_Op_Mod then
8236
8237             --  The operand type may be private (e.g. in the expansion of an
8238             --  intrinsic operation) so we must use the underlying type to get
8239             --  the bounds, and convert the literals explicitly.
8240
8241             LLB :=
8242               Expr_Value
8243                 (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
8244
8245             if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
8246               and then
8247                 ((not LOK) or else (Llo = LLB))
8248             then
8249                Rewrite (N,
8250                  Make_If_Expression (Loc,
8251                    Expressions => New_List (
8252                      Make_Op_Eq (Loc,
8253                        Left_Opnd => Duplicate_Subexpr (Right),
8254                        Right_Opnd =>
8255                          Unchecked_Convert_To (Typ,
8256                            Make_Integer_Literal (Loc, -1))),
8257                      Unchecked_Convert_To (Typ,
8258                        Make_Integer_Literal (Loc, Uint_0)),
8259                      Relocate_Node (N))));
8260
8261                Set_Analyzed (Next (Next (First (Expressions (N)))));
8262                Analyze_And_Resolve (N, Typ);
8263             end if;
8264          end if;
8265       end if;
8266    end Expand_N_Op_Mod;
8267
8268    --------------------------
8269    -- Expand_N_Op_Multiply --
8270    --------------------------
8271
8272    procedure Expand_N_Op_Multiply (N : Node_Id) is
8273       Loc : constant Source_Ptr := Sloc (N);
8274       Lop : constant Node_Id    := Left_Opnd (N);
8275       Rop : constant Node_Id    := Right_Opnd (N);
8276
8277       Lp2 : constant Boolean :=
8278               Nkind (Lop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Lop);
8279       Rp2 : constant Boolean :=
8280               Nkind (Rop) = N_Op_Expon and then Is_Power_Of_2_For_Shift (Rop);
8281
8282       Ltyp : constant Entity_Id  := Etype (Lop);
8283       Rtyp : constant Entity_Id  := Etype (Rop);
8284       Typ  : Entity_Id           := Etype (N);
8285
8286    begin
8287       Binary_Op_Validity_Checks (N);
8288
8289       --  Check for MINIMIZED/ELIMINATED overflow mode
8290
8291       if Minimized_Eliminated_Overflow_Check (N) then
8292          Apply_Arithmetic_Overflow_Check (N);
8293          return;
8294       end if;
8295
8296       --  Special optimizations for integer types
8297
8298       if Is_Integer_Type (Typ) then
8299
8300          --  N * 0 = 0 for integer types
8301
8302          if Compile_Time_Known_Value (Rop)
8303            and then Expr_Value (Rop) = Uint_0
8304          then
8305             --  Call Remove_Side_Effects to ensure that any side effects in
8306             --  the ignored left operand (in particular function calls to
8307             --  user defined functions) are properly executed.
8308
8309             Remove_Side_Effects (Lop);
8310
8311             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8312             Analyze_And_Resolve (N, Typ);
8313             return;
8314          end if;
8315
8316          --  Similar handling for 0 * N = 0
8317
8318          if Compile_Time_Known_Value (Lop)
8319            and then Expr_Value (Lop) = Uint_0
8320          then
8321             Remove_Side_Effects (Rop);
8322             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
8323             Analyze_And_Resolve (N, Typ);
8324             return;
8325          end if;
8326
8327          --  N * 1 = 1 * N = N for integer types
8328
8329          --  This optimisation is not done if we are going to
8330          --  rewrite the product 1 * 2 ** N to a shift.
8331
8332          if Compile_Time_Known_Value (Rop)
8333            and then Expr_Value (Rop) = Uint_1
8334            and then not Lp2
8335          then
8336             Rewrite (N, Lop);
8337             return;
8338
8339          elsif Compile_Time_Known_Value (Lop)
8340            and then Expr_Value (Lop) = Uint_1
8341            and then not Rp2
8342          then
8343             Rewrite (N, Rop);
8344             return;
8345          end if;
8346       end if;
8347
8348       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
8349       --  Is_Power_Of_2_For_Shift is set means that we know that our left
8350       --  operand is an integer, as required for this to work.
8351
8352       if Rp2 then
8353          if Lp2 then
8354
8355             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
8356
8357             Rewrite (N,
8358               Make_Op_Expon (Loc,
8359                 Left_Opnd => Make_Integer_Literal (Loc, 2),
8360                 Right_Opnd =>
8361                   Make_Op_Add (Loc,
8362                     Left_Opnd  => Right_Opnd (Lop),
8363                     Right_Opnd => Right_Opnd (Rop))));
8364             Analyze_And_Resolve (N, Typ);
8365             return;
8366
8367          else
8368             Rewrite (N,
8369               Make_Op_Shift_Left (Loc,
8370                 Left_Opnd  => Lop,
8371                 Right_Opnd =>
8372                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
8373             Analyze_And_Resolve (N, Typ);
8374             return;
8375          end if;
8376
8377       --  Same processing for the operands the other way round
8378
8379       elsif Lp2 then
8380          Rewrite (N,
8381            Make_Op_Shift_Left (Loc,
8382              Left_Opnd  => Rop,
8383              Right_Opnd =>
8384                Convert_To (Standard_Natural, Right_Opnd (Lop))));
8385          Analyze_And_Resolve (N, Typ);
8386          return;
8387       end if;
8388
8389       --  Do required fixup of universal fixed operation
8390
8391       if Typ = Universal_Fixed then
8392          Fixup_Universal_Fixed_Operation (N);
8393          Typ := Etype (N);
8394       end if;
8395
8396       --  Multiplications with fixed-point results
8397
8398       if Is_Fixed_Point_Type (Typ) then
8399
8400          --  No special processing if Treat_Fixed_As_Integer is set, since from
8401          --  a semantic point of view such operations are simply integer
8402          --  operations and will be treated that way.
8403
8404          if not Treat_Fixed_As_Integer (N) then
8405
8406             --  Case of fixed * integer => fixed
8407
8408             if Is_Integer_Type (Rtyp) then
8409                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
8410
8411             --  Case of integer * fixed => fixed
8412
8413             elsif Is_Integer_Type (Ltyp) then
8414                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
8415
8416             --  Case of fixed * fixed => fixed
8417
8418             else
8419                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
8420             end if;
8421          end if;
8422
8423       --  Other cases of multiplication of fixed-point operands. Again we
8424       --  exclude the cases where Treat_Fixed_As_Integer flag is set.
8425
8426       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
8427         and then not Treat_Fixed_As_Integer (N)
8428       then
8429          if Is_Integer_Type (Typ) then
8430             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
8431          else
8432             pragma Assert (Is_Floating_Point_Type (Typ));
8433             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
8434          end if;
8435
8436       --  Mixed-mode operations can appear in a non-static universal context,
8437       --  in which case the integer argument must be converted explicitly.
8438
8439       elsif Typ = Universal_Real and then Is_Integer_Type (Rtyp) then
8440          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
8441          Analyze_And_Resolve (Rop, Universal_Real);
8442
8443       elsif Typ = Universal_Real and then Is_Integer_Type (Ltyp) then
8444          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
8445          Analyze_And_Resolve (Lop, Universal_Real);
8446
8447       --  Non-fixed point cases, check software overflow checking required
8448
8449       elsif Is_Signed_Integer_Type (Etype (N)) then
8450          Apply_Arithmetic_Overflow_Check (N);
8451
8452       --  Deal with VAX float case
8453
8454       elsif Vax_Float (Typ) then
8455          Expand_Vax_Arith (N);
8456          return;
8457       end if;
8458    end Expand_N_Op_Multiply;
8459
8460    --------------------
8461    -- Expand_N_Op_Ne --
8462    --------------------
8463
8464    procedure Expand_N_Op_Ne (N : Node_Id) is
8465       Typ : constant Entity_Id := Etype (Left_Opnd (N));
8466
8467    begin
8468       --  Case of elementary type with standard operator
8469
8470       if Is_Elementary_Type (Typ)
8471         and then Sloc (Entity (N)) = Standard_Location
8472       then
8473          Binary_Op_Validity_Checks (N);
8474
8475          --  Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
8476          --  means we no longer have a /= operation, we are all done.
8477
8478          Expand_Compare_Minimize_Eliminate_Overflow (N);
8479
8480          if Nkind (N) /= N_Op_Ne then
8481             return;
8482          end if;
8483
8484          --  Boolean types (requiring handling of non-standard case)
8485
8486          if Is_Boolean_Type (Typ) then
8487             Adjust_Condition (Left_Opnd (N));
8488             Adjust_Condition (Right_Opnd (N));
8489             Set_Etype (N, Standard_Boolean);
8490             Adjust_Result_Type (N, Typ);
8491          end if;
8492
8493          Rewrite_Comparison (N);
8494
8495          --  If we still have comparison for Vax_Float, process it
8496
8497          if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare  then
8498             Expand_Vax_Comparison (N);
8499             return;
8500          end if;
8501
8502       --  For all cases other than elementary types, we rewrite node as the
8503       --  negation of an equality operation, and reanalyze. The equality to be
8504       --  used is defined in the same scope and has the same signature. This
8505       --  signature must be set explicitly since in an instance it may not have
8506       --  the same visibility as in the generic unit. This avoids duplicating
8507       --  or factoring the complex code for record/array equality tests etc.
8508
8509       else
8510          declare
8511             Loc : constant Source_Ptr := Sloc (N);
8512             Neg : Node_Id;
8513             Ne  : constant Entity_Id := Entity (N);
8514
8515          begin
8516             Binary_Op_Validity_Checks (N);
8517
8518             Neg :=
8519               Make_Op_Not (Loc,
8520                 Right_Opnd =>
8521                   Make_Op_Eq (Loc,
8522                     Left_Opnd =>  Left_Opnd (N),
8523                     Right_Opnd => Right_Opnd (N)));
8524             Set_Paren_Count (Right_Opnd (Neg), 1);
8525
8526             if Scope (Ne) /= Standard_Standard then
8527                Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
8528             end if;
8529
8530             --  For navigation purposes, we want to treat the inequality as an
8531             --  implicit reference to the corresponding equality. Preserve the
8532             --  Comes_From_ source flag to generate proper Xref entries.
8533
8534             Preserve_Comes_From_Source (Neg, N);
8535             Preserve_Comes_From_Source (Right_Opnd (Neg), N);
8536             Rewrite (N, Neg);
8537             Analyze_And_Resolve (N, Standard_Boolean);
8538          end;
8539       end if;
8540
8541       Optimize_Length_Comparison (N);
8542    end Expand_N_Op_Ne;
8543
8544    ---------------------
8545    -- Expand_N_Op_Not --
8546    ---------------------
8547
8548    --  If the argument is other than a Boolean array type, there is no special
8549    --  expansion required, except for VMS operations on signed integers.
8550
8551    --  For the packed case, we call the special routine in Exp_Pakd, except
8552    --  that if the component size is greater than one, we use the standard
8553    --  routine generating a gruesome loop (it is so peculiar to have packed
8554    --  arrays with non-standard Boolean representations anyway, so it does not
8555    --  matter that we do not handle this case efficiently).
8556
8557    --  For the unpacked case (and for the special packed case where we have non
8558    --  standard Booleans, as discussed above), we generate and insert into the
8559    --  tree the following function definition:
8560
8561    --     function Nnnn (A : arr) is
8562    --       B : arr;
8563    --     begin
8564    --       for J in a'range loop
8565    --          B (J) := not A (J);
8566    --       end loop;
8567    --       return B;
8568    --     end Nnnn;
8569
8570    --  Here arr is the actual subtype of the parameter (and hence always
8571    --  constrained). Then we replace the not with a call to this function.
8572
8573    procedure Expand_N_Op_Not (N : Node_Id) is
8574       Loc  : constant Source_Ptr := Sloc (N);
8575       Typ  : constant Entity_Id  := Etype (N);
8576       Opnd : Node_Id;
8577       Arr  : Entity_Id;
8578       A    : Entity_Id;
8579       B    : Entity_Id;
8580       J    : Entity_Id;
8581       A_J  : Node_Id;
8582       B_J  : Node_Id;
8583
8584       Func_Name      : Entity_Id;
8585       Loop_Statement : Node_Id;
8586
8587    begin
8588       Unary_Op_Validity_Checks (N);
8589
8590       --  For boolean operand, deal with non-standard booleans
8591
8592       if Is_Boolean_Type (Typ) then
8593          Adjust_Condition (Right_Opnd (N));
8594          Set_Etype (N, Standard_Boolean);
8595          Adjust_Result_Type (N, Typ);
8596          return;
8597       end if;
8598
8599       --  For the VMS "not" on signed integer types, use conversion to and from
8600       --  a predefined modular type.
8601
8602       if Is_VMS_Operator (Entity (N)) then
8603          declare
8604             Rtyp : Entity_Id;
8605             Utyp : Entity_Id;
8606
8607          begin
8608             --  If this is a derived type, retrieve original VMS type so that
8609             --  the proper sized type is used for intermediate values.
8610
8611             if Is_Derived_Type (Typ) then
8612                Rtyp := First_Subtype (Etype (Typ));
8613             else
8614                Rtyp := Typ;
8615             end if;
8616
8617             --  The proper unsigned type must have a size compatible with the
8618             --  operand, to prevent misalignment.
8619
8620             if RM_Size (Rtyp) <= 8 then
8621                Utyp := RTE (RE_Unsigned_8);
8622
8623             elsif RM_Size (Rtyp) <= 16 then
8624                Utyp := RTE (RE_Unsigned_16);
8625
8626             elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
8627                Utyp := RTE (RE_Unsigned_32);
8628
8629             else
8630                Utyp := RTE (RE_Long_Long_Unsigned);
8631             end if;
8632
8633             Rewrite (N,
8634               Unchecked_Convert_To (Typ,
8635                 Make_Op_Not (Loc,
8636                   Unchecked_Convert_To (Utyp, Right_Opnd (N)))));
8637             Analyze_And_Resolve (N, Typ);
8638             return;
8639          end;
8640       end if;
8641
8642       --  Only array types need any other processing
8643
8644       if not Is_Array_Type (Typ) then
8645          return;
8646       end if;
8647
8648       --  Case of array operand. If bit packed with a component size of 1,
8649       --  handle it in Exp_Pakd if the operand is known to be aligned.
8650
8651       if Is_Bit_Packed_Array (Typ)
8652         and then Component_Size (Typ) = 1
8653         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
8654       then
8655          Expand_Packed_Not (N);
8656          return;
8657       end if;
8658
8659       --  Case of array operand which is not bit-packed. If the context is
8660       --  a safe assignment, call in-place operation, If context is a larger
8661       --  boolean expression in the context of a safe assignment, expansion is
8662       --  done by enclosing operation.
8663
8664       Opnd := Relocate_Node (Right_Opnd (N));
8665       Convert_To_Actual_Subtype (Opnd);
8666       Arr := Etype (Opnd);
8667       Ensure_Defined (Arr, N);
8668       Silly_Boolean_Array_Not_Test (N, Arr);
8669
8670       if Nkind (Parent (N)) = N_Assignment_Statement then
8671          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
8672             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8673             return;
8674
8675          --  Special case the negation of a binary operation
8676
8677          elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
8678            and then Safe_In_Place_Array_Op
8679                       (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
8680          then
8681             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
8682             return;
8683          end if;
8684
8685       elsif Nkind (Parent (N)) in N_Binary_Op
8686         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
8687       then
8688          declare
8689             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
8690             Op2 : constant Node_Id := Right_Opnd (Parent (N));
8691             Lhs : constant Node_Id := Name (Parent (Parent (N)));
8692
8693          begin
8694             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
8695
8696                --  (not A) op (not B) can be reduced to a single call
8697
8698                if N = Op1 and then Nkind (Op2) = N_Op_Not then
8699                   return;
8700
8701                elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
8702                   return;
8703
8704                --  A xor (not B) can also be special-cased
8705
8706                elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
8707                   return;
8708                end if;
8709             end if;
8710          end;
8711       end if;
8712
8713       A := Make_Defining_Identifier (Loc, Name_uA);
8714       B := Make_Defining_Identifier (Loc, Name_uB);
8715       J := Make_Defining_Identifier (Loc, Name_uJ);
8716
8717       A_J :=
8718         Make_Indexed_Component (Loc,
8719           Prefix      => New_Reference_To (A, Loc),
8720           Expressions => New_List (New_Reference_To (J, Loc)));
8721
8722       B_J :=
8723         Make_Indexed_Component (Loc,
8724           Prefix      => New_Reference_To (B, Loc),
8725           Expressions => New_List (New_Reference_To (J, Loc)));
8726
8727       Loop_Statement :=
8728         Make_Implicit_Loop_Statement (N,
8729           Identifier => Empty,
8730
8731           Iteration_Scheme =>
8732             Make_Iteration_Scheme (Loc,
8733               Loop_Parameter_Specification =>
8734                 Make_Loop_Parameter_Specification (Loc,
8735                   Defining_Identifier         => J,
8736                   Discrete_Subtype_Definition =>
8737                     Make_Attribute_Reference (Loc,
8738                       Prefix         => Make_Identifier (Loc, Chars (A)),
8739                       Attribute_Name => Name_Range))),
8740
8741           Statements => New_List (
8742             Make_Assignment_Statement (Loc,
8743               Name       => B_J,
8744               Expression => Make_Op_Not (Loc, A_J))));
8745
8746       Func_Name := Make_Temporary (Loc, 'N');
8747       Set_Is_Inlined (Func_Name);
8748
8749       Insert_Action (N,
8750         Make_Subprogram_Body (Loc,
8751           Specification =>
8752             Make_Function_Specification (Loc,
8753               Defining_Unit_Name => Func_Name,
8754               Parameter_Specifications => New_List (
8755                 Make_Parameter_Specification (Loc,
8756                   Defining_Identifier => A,
8757                   Parameter_Type      => New_Reference_To (Typ, Loc))),
8758               Result_Definition => New_Reference_To (Typ, Loc)),
8759
8760           Declarations => New_List (
8761             Make_Object_Declaration (Loc,
8762               Defining_Identifier => B,
8763               Object_Definition   => New_Reference_To (Arr, Loc))),
8764
8765           Handled_Statement_Sequence =>
8766             Make_Handled_Sequence_Of_Statements (Loc,
8767               Statements => New_List (
8768                 Loop_Statement,
8769                 Make_Simple_Return_Statement (Loc,
8770                   Expression => Make_Identifier (Loc, Chars (B)))))));
8771
8772       Rewrite (N,
8773         Make_Function_Call (Loc,
8774           Name                   => New_Reference_To (Func_Name, Loc),
8775           Parameter_Associations => New_List (Opnd)));
8776
8777       Analyze_And_Resolve (N, Typ);
8778    end Expand_N_Op_Not;
8779
8780    --------------------
8781    -- Expand_N_Op_Or --
8782    --------------------
8783
8784    procedure Expand_N_Op_Or (N : Node_Id) is
8785       Typ : constant Entity_Id := Etype (N);
8786
8787    begin
8788       Binary_Op_Validity_Checks (N);
8789
8790       if Is_Array_Type (Etype (N)) then
8791          Expand_Boolean_Operator (N);
8792
8793       elsif Is_Boolean_Type (Etype (N)) then
8794          Adjust_Condition (Left_Opnd (N));
8795          Adjust_Condition (Right_Opnd (N));
8796          Set_Etype (N, Standard_Boolean);
8797          Adjust_Result_Type (N, Typ);
8798
8799       elsif Is_Intrinsic_Subprogram (Entity (N)) then
8800          Expand_Intrinsic_Call (N, Entity (N));
8801
8802       end if;
8803    end Expand_N_Op_Or;
8804
8805    ----------------------
8806    -- Expand_N_Op_Plus --
8807    ----------------------
8808
8809    procedure Expand_N_Op_Plus (N : Node_Id) is
8810    begin
8811       Unary_Op_Validity_Checks (N);
8812
8813       --  Check for MINIMIZED/ELIMINATED overflow mode
8814
8815       if Minimized_Eliminated_Overflow_Check (N) then
8816          Apply_Arithmetic_Overflow_Check (N);
8817          return;
8818       end if;
8819    end Expand_N_Op_Plus;
8820
8821    ---------------------
8822    -- Expand_N_Op_Rem --
8823    ---------------------
8824
8825    procedure Expand_N_Op_Rem (N : Node_Id) is
8826       Loc : constant Source_Ptr := Sloc (N);
8827       Typ : constant Entity_Id  := Etype (N);
8828
8829       Left  : Node_Id;
8830       Right : Node_Id;
8831
8832       Lo : Uint;
8833       Hi : Uint;
8834       OK : Boolean;
8835
8836       Lneg : Boolean;
8837       Rneg : Boolean;
8838       --  Set if corresponding operand can be negative
8839
8840       pragma Unreferenced (Hi);
8841
8842    begin
8843       Binary_Op_Validity_Checks (N);
8844
8845       --  Check for MINIMIZED/ELIMINATED overflow mode
8846
8847       if Minimized_Eliminated_Overflow_Check (N) then
8848          Apply_Arithmetic_Overflow_Check (N);
8849          return;
8850       end if;
8851
8852       if Is_Integer_Type (Etype (N)) then
8853          Apply_Divide_Checks (N);
8854
8855          --  All done if we don't have a REM any more, which can happen as a
8856          --  result of overflow expansion in MINIMIZED or ELIMINATED modes.
8857
8858          if Nkind (N) /= N_Op_Rem then
8859             return;
8860          end if;
8861       end if;
8862
8863       --  Proceed with expansion of REM
8864
8865       Left  := Left_Opnd (N);
8866       Right := Right_Opnd (N);
8867
8868       --  Apply optimization x rem 1 = 0. We don't really need that with gcc,
8869       --  but it is useful with other back ends (e.g. AAMP), and is certainly
8870       --  harmless.
8871
8872       if Is_Integer_Type (Etype (N))
8873         and then Compile_Time_Known_Value (Right)
8874         and then Expr_Value (Right) = Uint_1
8875       then
8876          --  Call Remove_Side_Effects to ensure that any side effects in the
8877          --  ignored left operand (in particular function calls to user defined
8878          --  functions) are properly executed.
8879
8880          Remove_Side_Effects (Left);
8881
8882          Rewrite (N, Make_Integer_Literal (Loc, 0));
8883          Analyze_And_Resolve (N, Typ);
8884          return;
8885       end if;
8886
8887       --  Deal with annoying case of largest negative number remainder minus
8888       --  one. Gigi may not handle this case correctly, because on some
8889       --  targets, the mod value is computed using a divide instruction
8890       --  which gives an overflow trap for this case.
8891
8892       --  It would be a bit more efficient to figure out which targets this
8893       --  is really needed for, but in practice it is reasonable to do the
8894       --  following special check in all cases, since it means we get a clearer
8895       --  message, and also the overhead is minimal given that division is
8896       --  expensive in any case.
8897
8898       --  In fact the check is quite easy, if the right operand is -1, then
8899       --  the remainder is always 0, and we can just ignore the left operand
8900       --  completely in this case.
8901
8902       Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
8903       Lneg := (not OK) or else Lo < 0;
8904
8905       Determine_Range (Left,  OK, Lo, Hi, Assume_Valid => True);
8906       Rneg := (not OK) or else Lo < 0;
8907
8908       --  We won't mess with trying to find out if the left operand can really
8909       --  be the largest negative number (that's a pain in the case of private
8910       --  types and this is really marginal). We will just assume that we need
8911       --  the test if the left operand can be negative at all.
8912
8913       if Lneg and Rneg then
8914          Rewrite (N,
8915            Make_If_Expression (Loc,
8916              Expressions => New_List (
8917                Make_Op_Eq (Loc,
8918                  Left_Opnd  => Duplicate_Subexpr (Right),
8919                  Right_Opnd =>
8920                    Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
8921
8922                Unchecked_Convert_To (Typ,
8923                  Make_Integer_Literal (Loc, Uint_0)),
8924
8925                Relocate_Node (N))));
8926
8927          Set_Analyzed (Next (Next (First (Expressions (N)))));
8928          Analyze_And_Resolve (N, Typ);
8929       end if;
8930    end Expand_N_Op_Rem;
8931
8932    -----------------------------
8933    -- Expand_N_Op_Rotate_Left --
8934    -----------------------------
8935
8936    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
8937    begin
8938       Binary_Op_Validity_Checks (N);
8939    end Expand_N_Op_Rotate_Left;
8940
8941    ------------------------------
8942    -- Expand_N_Op_Rotate_Right --
8943    ------------------------------
8944
8945    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
8946    begin
8947       Binary_Op_Validity_Checks (N);
8948    end Expand_N_Op_Rotate_Right;
8949
8950    ----------------------------
8951    -- Expand_N_Op_Shift_Left --
8952    ----------------------------
8953
8954    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
8955    begin
8956       Binary_Op_Validity_Checks (N);
8957    end Expand_N_Op_Shift_Left;
8958
8959    -----------------------------
8960    -- Expand_N_Op_Shift_Right --
8961    -----------------------------
8962
8963    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
8964    begin
8965       Binary_Op_Validity_Checks (N);
8966    end Expand_N_Op_Shift_Right;
8967
8968    ----------------------------------------
8969    -- Expand_N_Op_Shift_Right_Arithmetic --
8970    ----------------------------------------
8971
8972    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
8973    begin
8974       Binary_Op_Validity_Checks (N);
8975    end Expand_N_Op_Shift_Right_Arithmetic;
8976
8977    --------------------------
8978    -- Expand_N_Op_Subtract --
8979    --------------------------
8980
8981    procedure Expand_N_Op_Subtract (N : Node_Id) is
8982       Typ : constant Entity_Id := Etype (N);
8983
8984    begin
8985       Binary_Op_Validity_Checks (N);
8986
8987       --  Check for MINIMIZED/ELIMINATED overflow mode
8988
8989       if Minimized_Eliminated_Overflow_Check (N) then
8990          Apply_Arithmetic_Overflow_Check (N);
8991          return;
8992       end if;
8993
8994       --  N - 0 = N for integer types
8995
8996       if Is_Integer_Type (Typ)
8997         and then Compile_Time_Known_Value (Right_Opnd (N))
8998         and then Expr_Value (Right_Opnd (N)) = 0
8999       then
9000          Rewrite (N, Left_Opnd (N));
9001          return;
9002       end if;
9003
9004       --  Arithmetic overflow checks for signed integer/fixed point types
9005
9006       if Is_Signed_Integer_Type (Typ)
9007            or else
9008          Is_Fixed_Point_Type (Typ)
9009       then
9010          Apply_Arithmetic_Overflow_Check (N);
9011
9012       --  VAX floating-point types case
9013
9014       elsif Vax_Float (Typ) then
9015          Expand_Vax_Arith (N);
9016       end if;
9017    end Expand_N_Op_Subtract;
9018
9019    ---------------------
9020    -- Expand_N_Op_Xor --
9021    ---------------------
9022
9023    procedure Expand_N_Op_Xor (N : Node_Id) is
9024       Typ : constant Entity_Id := Etype (N);
9025
9026    begin
9027       Binary_Op_Validity_Checks (N);
9028
9029       if Is_Array_Type (Etype (N)) then
9030          Expand_Boolean_Operator (N);
9031
9032       elsif Is_Boolean_Type (Etype (N)) then
9033          Adjust_Condition (Left_Opnd (N));
9034          Adjust_Condition (Right_Opnd (N));
9035          Set_Etype (N, Standard_Boolean);
9036          Adjust_Result_Type (N, Typ);
9037
9038       elsif Is_Intrinsic_Subprogram (Entity (N)) then
9039          Expand_Intrinsic_Call (N, Entity (N));
9040
9041       end if;
9042    end Expand_N_Op_Xor;
9043
9044    ----------------------
9045    -- Expand_N_Or_Else --
9046    ----------------------
9047
9048    procedure Expand_N_Or_Else (N : Node_Id)
9049      renames Expand_Short_Circuit_Operator;
9050
9051    -----------------------------------
9052    -- Expand_N_Qualified_Expression --
9053    -----------------------------------
9054
9055    procedure Expand_N_Qualified_Expression (N : Node_Id) is
9056       Operand     : constant Node_Id   := Expression (N);
9057       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
9058
9059    begin
9060       --  Do validity check if validity checking operands
9061
9062       if Validity_Checks_On and Validity_Check_Operands then
9063          Ensure_Valid (Operand);
9064       end if;
9065
9066       --  Apply possible constraint check
9067
9068       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
9069
9070       if Do_Range_Check (Operand) then
9071          Set_Do_Range_Check (Operand, False);
9072          Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
9073       end if;
9074    end Expand_N_Qualified_Expression;
9075
9076    ------------------------------------
9077    -- Expand_N_Quantified_Expression --
9078    ------------------------------------
9079
9080    --  We expand:
9081
9082    --    for all X in range => Cond
9083
9084    --  into:
9085
9086    --        T := True;
9087    --        for X in range loop
9088    --           if not Cond then
9089    --              T := False;
9090    --              exit;
9091    --           end if;
9092    --        end loop;
9093
9094    --  Similarly, an existentially quantified expression:
9095
9096    --    for some X in range => Cond
9097
9098    --  becomes:
9099
9100    --        T := False;
9101    --        for X in range loop
9102    --           if Cond then
9103    --              T := True;
9104    --              exit;
9105    --           end if;
9106    --        end loop;
9107
9108    --  In both cases, the iteration may be over a container in which case it is
9109    --  given by an iterator specification, not a loop parameter specification.
9110
9111    procedure Expand_N_Quantified_Expression (N : Node_Id) is
9112       Actions   : constant List_Id    := New_List;
9113       For_All   : constant Boolean    := All_Present (N);
9114       Iter_Spec : constant Node_Id    := Iterator_Specification (N);
9115       Loc       : constant Source_Ptr := Sloc (N);
9116       Loop_Spec : constant Node_Id    := Loop_Parameter_Specification (N);
9117       Cond      : Node_Id;
9118       Flag      : Entity_Id;
9119       Scheme    : Node_Id;
9120       Stmts     : List_Id;
9121
9122    begin
9123       --  Create the declaration of the flag which tracks the status of the
9124       --  quantified expression. Generate:
9125
9126       --    Flag : Boolean := (True | False);
9127
9128       Flag := Make_Temporary (Loc, 'T', N);
9129
9130       Append_To (Actions,
9131         Make_Object_Declaration (Loc,
9132           Defining_Identifier => Flag,
9133           Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc),
9134           Expression          =>
9135             New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
9136
9137       --  Construct the circuitry which tracks the status of the quantified
9138       --  expression. Generate:
9139
9140       --    if [not] Cond then
9141       --       Flag := (False | True);
9142       --       exit;
9143       --    end if;
9144
9145       Cond := Relocate_Node (Condition (N));
9146
9147       if For_All then
9148          Cond := Make_Op_Not (Loc, Cond);
9149       end if;
9150
9151       Stmts := New_List (
9152         Make_Implicit_If_Statement (N,
9153           Condition       => Cond,
9154           Then_Statements => New_List (
9155             Make_Assignment_Statement (Loc,
9156               Name       => New_Occurrence_Of (Flag, Loc),
9157               Expression =>
9158                 New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
9159             Make_Exit_Statement (Loc))));
9160
9161       --  Build the loop equivalent of the quantified expression
9162
9163       if Present (Iter_Spec) then
9164          Scheme :=
9165            Make_Iteration_Scheme (Loc,
9166              Iterator_Specification => Iter_Spec);
9167       else
9168          Scheme :=
9169            Make_Iteration_Scheme (Loc,
9170              Loop_Parameter_Specification => Loop_Spec);
9171       end if;
9172
9173       Append_To (Actions,
9174         Make_Loop_Statement (Loc,
9175           Iteration_Scheme => Scheme,
9176           Statements       => Stmts,
9177           End_Label        => Empty));
9178
9179       --  Transform the quantified expression
9180
9181       Rewrite (N,
9182         Make_Expression_With_Actions (Loc,
9183           Expression => New_Occurrence_Of (Flag, Loc),
9184           Actions    => Actions));
9185       Analyze_And_Resolve (N, Standard_Boolean);
9186    end Expand_N_Quantified_Expression;
9187
9188    ---------------------------------
9189    -- Expand_N_Selected_Component --
9190    ---------------------------------
9191
9192    procedure Expand_N_Selected_Component (N : Node_Id) is
9193       Loc   : constant Source_Ptr := Sloc (N);
9194       Par   : constant Node_Id    := Parent (N);
9195       P     : constant Node_Id    := Prefix (N);
9196       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
9197       Disc  : Entity_Id;
9198       New_N : Node_Id;
9199       Dcon  : Elmt_Id;
9200       Dval  : Node_Id;
9201
9202       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
9203       --  Gigi needs a temporary for prefixes that depend on a discriminant,
9204       --  unless the context of an assignment can provide size information.
9205       --  Don't we have a general routine that does this???
9206
9207       function Is_Subtype_Declaration return Boolean;
9208       --  The replacement of a discriminant reference by its value is required
9209       --  if this is part of the initialization of an temporary generated by a
9210       --  change of representation. This shows up as the construction of a
9211       --  discriminant constraint for a subtype declared at the same point as
9212       --  the entity in the prefix of the selected component. We recognize this
9213       --  case when the context of the reference is:
9214       --    subtype ST is T(Obj.D);
9215       --  where the entity for Obj comes from source, and ST has the same sloc.
9216
9217       -----------------------
9218       -- In_Left_Hand_Side --
9219       -----------------------
9220
9221       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
9222       begin
9223          return (Nkind (Parent (Comp)) = N_Assignment_Statement
9224                   and then Comp = Name (Parent (Comp)))
9225            or else (Present (Parent (Comp))
9226                      and then Nkind (Parent (Comp)) in N_Subexpr
9227                      and then In_Left_Hand_Side (Parent (Comp)));
9228       end In_Left_Hand_Side;
9229
9230       -----------------------------
9231       --  Is_Subtype_Declaration --
9232       -----------------------------
9233
9234       function Is_Subtype_Declaration return Boolean is
9235          Par : constant Node_Id := Parent (N);
9236       begin
9237          return
9238            Nkind (Par) = N_Index_Or_Discriminant_Constraint
9239              and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration
9240              and then Comes_From_Source (Entity (Prefix (N)))
9241              and then Sloc (Par) = Sloc (Entity (Prefix (N)));
9242       end Is_Subtype_Declaration;
9243
9244    --  Start of processing for Expand_N_Selected_Component
9245
9246    begin
9247       --  Insert explicit dereference if required
9248
9249       if Is_Access_Type (Ptyp) then
9250
9251          --  First set prefix type to proper access type, in case it currently
9252          --  has a private (non-access) view of this type.
9253
9254          Set_Etype (P, Ptyp);
9255
9256          Insert_Explicit_Dereference (P);
9257          Analyze_And_Resolve (P, Designated_Type (Ptyp));
9258
9259          if Ekind (Etype (P)) = E_Private_Subtype
9260            and then Is_For_Access_Subtype (Etype (P))
9261          then
9262             Set_Etype (P, Base_Type (Etype (P)));
9263          end if;
9264
9265          Ptyp := Etype (P);
9266       end if;
9267
9268       --  Deal with discriminant check required
9269
9270       if Do_Discriminant_Check (N) then
9271
9272          --  Present the discriminant checking function to the backend, so that
9273          --  it can inline the call to the function.
9274
9275          Add_Inlined_Body
9276            (Discriminant_Checking_Func
9277              (Original_Record_Component (Entity (Selector_Name (N)))));
9278
9279          --  Now reset the flag and generate the call
9280
9281          Set_Do_Discriminant_Check (N, False);
9282          Generate_Discriminant_Check (N);
9283       end if;
9284
9285       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9286       --  function, then additional actuals must be passed.
9287
9288       if Ada_Version >= Ada_2005
9289         and then Is_Build_In_Place_Function_Call (P)
9290       then
9291          Make_Build_In_Place_Call_In_Anonymous_Context (P);
9292       end if;
9293
9294       --  Gigi cannot handle unchecked conversions that are the prefix of a
9295       --  selected component with discriminants. This must be checked during
9296       --  expansion, because during analysis the type of the selector is not
9297       --  known at the point the prefix is analyzed. If the conversion is the
9298       --  target of an assignment, then we cannot force the evaluation.
9299
9300       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
9301         and then Has_Discriminants (Etype (N))
9302         and then not In_Left_Hand_Side (N)
9303       then
9304          Force_Evaluation (Prefix (N));
9305       end if;
9306
9307       --  Remaining processing applies only if selector is a discriminant
9308
9309       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
9310
9311          --  If the selector is a discriminant of a constrained record type,
9312          --  we may be able to rewrite the expression with the actual value
9313          --  of the discriminant, a useful optimization in some cases.
9314
9315          if Is_Record_Type (Ptyp)
9316            and then Has_Discriminants (Ptyp)
9317            and then Is_Constrained (Ptyp)
9318          then
9319             --  Do this optimization for discrete types only, and not for
9320             --  access types (access discriminants get us into trouble!)
9321
9322             if not Is_Discrete_Type (Etype (N)) then
9323                null;
9324
9325             --  Don't do this on the left hand of an assignment statement.
9326             --  Normally one would think that references like this would not
9327             --  occur, but they do in generated code, and mean that we really
9328             --  do want to assign the discriminant!
9329
9330             elsif Nkind (Par) = N_Assignment_Statement
9331               and then Name (Par) = N
9332             then
9333                null;
9334
9335             --  Don't do this optimization for the prefix of an attribute or
9336             --  the name of an object renaming declaration since these are
9337             --  contexts where we do not want the value anyway.
9338
9339             elsif (Nkind (Par) = N_Attribute_Reference
9340                     and then Prefix (Par) = N)
9341               or else Is_Renamed_Object (N)
9342             then
9343                null;
9344
9345             --  Don't do this optimization if we are within the code for a
9346             --  discriminant check, since the whole point of such a check may
9347             --  be to verify the condition on which the code below depends!
9348
9349             elsif Is_In_Discriminant_Check (N) then
9350                null;
9351
9352             --  Green light to see if we can do the optimization. There is
9353             --  still one condition that inhibits the optimization below but
9354             --  now is the time to check the particular discriminant.
9355
9356             else
9357                --  Loop through discriminants to find the matching discriminant
9358                --  constraint to see if we can copy it.
9359
9360                Disc := First_Discriminant (Ptyp);
9361                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
9362                Discr_Loop : while Present (Dcon) loop
9363                   Dval := Node (Dcon);
9364
9365                   --  Check if this is the matching discriminant and if the
9366                   --  discriminant value is simple enough to make sense to
9367                   --  copy. We don't want to copy complex expressions, and
9368                   --  indeed to do so can cause trouble (before we put in
9369                   --  this guard, a discriminant expression containing an
9370                   --  AND THEN was copied, causing problems for coverage
9371                   --  analysis tools).
9372
9373                   --  However, if the reference is part of the initialization
9374                   --  code generated for an object declaration, we must use
9375                   --  the discriminant value from the subtype constraint,
9376                   --  because the selected component may be a reference to the
9377                   --  object being initialized, whose discriminant is not yet
9378                   --  set. This only happens in complex cases involving changes
9379                   --  or representation.
9380
9381                   if Disc = Entity (Selector_Name (N))
9382                     and then (Is_Entity_Name (Dval)
9383                                or else Compile_Time_Known_Value (Dval)
9384                                or else Is_Subtype_Declaration)
9385                   then
9386                      --  Here we have the matching discriminant. Check for
9387                      --  the case of a discriminant of a component that is
9388                      --  constrained by an outer discriminant, which cannot
9389                      --  be optimized away.
9390
9391                      if Denotes_Discriminant
9392                           (Dval, Check_Concurrent => True)
9393                      then
9394                         exit Discr_Loop;
9395
9396                      elsif Nkind (Original_Node (Dval)) = N_Selected_Component
9397                        and then
9398                          Denotes_Discriminant
9399                            (Selector_Name (Original_Node (Dval)), True)
9400                      then
9401                         exit Discr_Loop;
9402
9403                      --  Do not retrieve value if constraint is not static. It
9404                      --  is generally not useful, and the constraint may be a
9405                      --  rewritten outer discriminant in which case it is in
9406                      --  fact incorrect.
9407
9408                      elsif Is_Entity_Name (Dval)
9409                        and then
9410                          Nkind (Parent (Entity (Dval))) = N_Object_Declaration
9411                        and then Present (Expression (Parent (Entity (Dval))))
9412                        and then not
9413                          Is_Static_Expression
9414                            (Expression (Parent (Entity (Dval))))
9415                      then
9416                         exit Discr_Loop;
9417
9418                      --  In the context of a case statement, the expression may
9419                      --  have the base type of the discriminant, and we need to
9420                      --  preserve the constraint to avoid spurious errors on
9421                      --  missing cases.
9422
9423                      elsif Nkind (Parent (N)) = N_Case_Statement
9424                        and then Etype (Dval) /= Etype (Disc)
9425                      then
9426                         Rewrite (N,
9427                           Make_Qualified_Expression (Loc,
9428                             Subtype_Mark =>
9429                               New_Occurrence_Of (Etype (Disc), Loc),
9430                             Expression   =>
9431                               New_Copy_Tree (Dval)));
9432                         Analyze_And_Resolve (N, Etype (Disc));
9433
9434                         --  In case that comes out as a static expression,
9435                         --  reset it (a selected component is never static).
9436
9437                         Set_Is_Static_Expression (N, False);
9438                         return;
9439
9440                      --  Otherwise we can just copy the constraint, but the
9441                      --  result is certainly not static! In some cases the
9442                      --  discriminant constraint has been analyzed in the
9443                      --  context of the original subtype indication, but for
9444                      --  itypes the constraint might not have been analyzed
9445                      --  yet, and this must be done now.
9446
9447                      else
9448                         Rewrite (N, New_Copy_Tree (Dval));
9449                         Analyze_And_Resolve (N);
9450                         Set_Is_Static_Expression (N, False);
9451                         return;
9452                      end if;
9453                   end if;
9454
9455                   Next_Elmt (Dcon);
9456                   Next_Discriminant (Disc);
9457                end loop Discr_Loop;
9458
9459                --  Note: the above loop should always find a matching
9460                --  discriminant, but if it does not, we just missed an
9461                --  optimization due to some glitch (perhaps a previous
9462                --  error), so ignore.
9463
9464             end if;
9465          end if;
9466
9467          --  The only remaining processing is in the case of a discriminant of
9468          --  a concurrent object, where we rewrite the prefix to denote the
9469          --  corresponding record type. If the type is derived and has renamed
9470          --  discriminants, use corresponding discriminant, which is the one
9471          --  that appears in the corresponding record.
9472
9473          if not Is_Concurrent_Type (Ptyp) then
9474             return;
9475          end if;
9476
9477          Disc := Entity (Selector_Name (N));
9478
9479          if Is_Derived_Type (Ptyp)
9480            and then Present (Corresponding_Discriminant (Disc))
9481          then
9482             Disc := Corresponding_Discriminant (Disc);
9483          end if;
9484
9485          New_N :=
9486            Make_Selected_Component (Loc,
9487              Prefix =>
9488                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
9489                  New_Copy_Tree (P)),
9490              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
9491
9492          Rewrite (N, New_N);
9493          Analyze (N);
9494       end if;
9495
9496       --  Set Atomic_Sync_Required if necessary for atomic component
9497
9498       if Nkind (N) = N_Selected_Component then
9499          declare
9500             E   : constant Entity_Id := Entity (Selector_Name (N));
9501             Set : Boolean;
9502
9503          begin
9504             --  If component is atomic, but type is not, setting depends on
9505             --  disable/enable state for the component.
9506
9507             if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
9508                Set := not Atomic_Synchronization_Disabled (E);
9509
9510             --  If component is not atomic, but its type is atomic, setting
9511             --  depends on disable/enable state for the type.
9512
9513             elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9514                Set := not Atomic_Synchronization_Disabled (Etype (E));
9515
9516             --  If both component and type are atomic, we disable if either
9517             --  component or its type have sync disabled.
9518
9519             elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
9520                Set := (not Atomic_Synchronization_Disabled (E))
9521                         and then
9522                       (not Atomic_Synchronization_Disabled (Etype (E)));
9523
9524             else
9525                Set := False;
9526             end if;
9527
9528             --  Set flag if required
9529
9530             if Set then
9531                Activate_Atomic_Synchronization (N);
9532             end if;
9533          end;
9534       end if;
9535    end Expand_N_Selected_Component;
9536
9537    --------------------
9538    -- Expand_N_Slice --
9539    --------------------
9540
9541    procedure Expand_N_Slice (N : Node_Id) is
9542       Loc  : constant Source_Ptr := Sloc (N);
9543       Typ  : constant Entity_Id  := Etype (N);
9544       Pfx  : constant Node_Id    := Prefix (N);
9545       Ptp  : Entity_Id           := Etype (Pfx);
9546
9547       function Is_Procedure_Actual (N : Node_Id) return Boolean;
9548       --  Check whether the argument is an actual for a procedure call, in
9549       --  which case the expansion of a bit-packed slice is deferred until the
9550       --  call itself is expanded. The reason this is required is that we might
9551       --  have an IN OUT or OUT parameter, and the copy out is essential, and
9552       --  that copy out would be missed if we created a temporary here in
9553       --  Expand_N_Slice. Note that we don't bother to test specifically for an
9554       --  IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
9555       --  is harmless to defer expansion in the IN case, since the call
9556       --  processing will still generate the appropriate copy in operation,
9557       --  which will take care of the slice.
9558
9559       procedure Make_Temporary_For_Slice;
9560       --  Create a named variable for the value of the slice, in cases where
9561       --  the back-end cannot handle it properly, e.g. when packed types or
9562       --  unaligned slices are involved.
9563
9564       -------------------------
9565       -- Is_Procedure_Actual --
9566       -------------------------
9567
9568       function Is_Procedure_Actual (N : Node_Id) return Boolean is
9569          Par : Node_Id := Parent (N);
9570
9571       begin
9572          loop
9573             --  If our parent is a procedure call we can return
9574
9575             if Nkind (Par) = N_Procedure_Call_Statement then
9576                return True;
9577
9578             --  If our parent is a type conversion, keep climbing the tree,
9579             --  since a type conversion can be a procedure actual. Also keep
9580             --  climbing if parameter association or a qualified expression,
9581             --  since these are additional cases that do can appear on
9582             --  procedure actuals.
9583
9584             elsif Nkind_In (Par, N_Type_Conversion,
9585                                  N_Parameter_Association,
9586                                  N_Qualified_Expression)
9587             then
9588                Par := Parent (Par);
9589
9590                --  Any other case is not what we are looking for
9591
9592             else
9593                return False;
9594             end if;
9595          end loop;
9596       end Is_Procedure_Actual;
9597
9598       ------------------------------
9599       -- Make_Temporary_For_Slice --
9600       ------------------------------
9601
9602       procedure Make_Temporary_For_Slice is
9603          Decl : Node_Id;
9604          Ent  : constant Entity_Id := Make_Temporary (Loc, 'T', N);
9605
9606       begin
9607          Decl :=
9608            Make_Object_Declaration (Loc,
9609              Defining_Identifier => Ent,
9610              Object_Definition   => New_Occurrence_Of (Typ, Loc));
9611
9612          Set_No_Initialization (Decl);
9613
9614          Insert_Actions (N, New_List (
9615            Decl,
9616            Make_Assignment_Statement (Loc,
9617              Name => New_Occurrence_Of (Ent, Loc),
9618              Expression => Relocate_Node (N))));
9619
9620          Rewrite (N, New_Occurrence_Of (Ent, Loc));
9621          Analyze_And_Resolve (N, Typ);
9622       end Make_Temporary_For_Slice;
9623
9624    --  Start of processing for Expand_N_Slice
9625
9626    begin
9627       --  Special handling for access types
9628
9629       if Is_Access_Type (Ptp) then
9630
9631          Ptp := Designated_Type (Ptp);
9632
9633          Rewrite (Pfx,
9634            Make_Explicit_Dereference (Sloc (N),
9635             Prefix => Relocate_Node (Pfx)));
9636
9637          Analyze_And_Resolve (Pfx, Ptp);
9638       end if;
9639
9640       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
9641       --  function, then additional actuals must be passed.
9642
9643       if Ada_Version >= Ada_2005
9644         and then Is_Build_In_Place_Function_Call (Pfx)
9645       then
9646          Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
9647       end if;
9648
9649       --  The remaining case to be handled is packed slices. We can leave
9650       --  packed slices as they are in the following situations:
9651
9652       --    1. Right or left side of an assignment (we can handle this
9653       --       situation correctly in the assignment statement expansion).
9654
9655       --    2. Prefix of indexed component (the slide is optimized away in this
9656       --       case, see the start of Expand_N_Slice.)
9657
9658       --    3. Object renaming declaration, since we want the name of the
9659       --       slice, not the value.
9660
9661       --    4. Argument to procedure call, since copy-in/copy-out handling may
9662       --       be required, and this is handled in the expansion of call
9663       --       itself.
9664
9665       --    5. Prefix of an address attribute (this is an error which is caught
9666       --       elsewhere, and the expansion would interfere with generating the
9667       --       error message).
9668
9669       if not Is_Packed (Typ) then
9670
9671          --  Apply transformation for actuals of a function call, where
9672          --  Expand_Actuals is not used.
9673
9674          if Nkind (Parent (N)) = N_Function_Call
9675            and then Is_Possibly_Unaligned_Slice (N)
9676          then
9677             Make_Temporary_For_Slice;
9678          end if;
9679
9680       elsif Nkind (Parent (N)) = N_Assignment_Statement
9681         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
9682                   and then Parent (N) = Name (Parent (Parent (N))))
9683       then
9684          return;
9685
9686       elsif Nkind (Parent (N)) = N_Indexed_Component
9687         or else Is_Renamed_Object (N)
9688         or else Is_Procedure_Actual (N)
9689       then
9690          return;
9691
9692       elsif Nkind (Parent (N)) = N_Attribute_Reference
9693         and then Attribute_Name (Parent (N)) = Name_Address
9694       then
9695          return;
9696
9697       else
9698          Make_Temporary_For_Slice;
9699       end if;
9700    end Expand_N_Slice;
9701
9702    ------------------------------
9703    -- Expand_N_Type_Conversion --
9704    ------------------------------
9705
9706    procedure Expand_N_Type_Conversion (N : Node_Id) is
9707       Loc          : constant Source_Ptr := Sloc (N);
9708       Operand      : constant Node_Id    := Expression (N);
9709       Target_Type  : constant Entity_Id  := Etype (N);
9710       Operand_Type : Entity_Id           := Etype (Operand);
9711
9712       procedure Handle_Changed_Representation;
9713       --  This is called in the case of record and array type conversions to
9714       --  see if there is a change of representation to be handled. Change of
9715       --  representation is actually handled at the assignment statement level,
9716       --  and what this procedure does is rewrite node N conversion as an
9717       --  assignment to temporary. If there is no change of representation,
9718       --  then the conversion node is unchanged.
9719
9720       procedure Raise_Accessibility_Error;
9721       --  Called when we know that an accessibility check will fail. Rewrites
9722       --  node N to an appropriate raise statement and outputs warning msgs.
9723       --  The Etype of the raise node is set to Target_Type.
9724
9725       procedure Real_Range_Check;
9726       --  Handles generation of range check for real target value
9727
9728       function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
9729       --  True iff Present (Effective_Extra_Accessibility (Id)) successfully
9730       --  evaluates to True.
9731
9732       -----------------------------------
9733       -- Handle_Changed_Representation --
9734       -----------------------------------
9735
9736       procedure Handle_Changed_Representation is
9737          Temp : Entity_Id;
9738          Decl : Node_Id;
9739          Odef : Node_Id;
9740          Disc : Node_Id;
9741          N_Ix : Node_Id;
9742          Cons : List_Id;
9743
9744       begin
9745          --  Nothing else to do if no change of representation
9746
9747          if Same_Representation (Operand_Type, Target_Type) then
9748             return;
9749
9750          --  The real change of representation work is done by the assignment
9751          --  statement processing. So if this type conversion is appearing as
9752          --  the expression of an assignment statement, nothing needs to be
9753          --  done to the conversion.
9754
9755          elsif Nkind (Parent (N)) = N_Assignment_Statement then
9756             return;
9757
9758          --  Otherwise we need to generate a temporary variable, and do the
9759          --  change of representation assignment into that temporary variable.
9760          --  The conversion is then replaced by a reference to this variable.
9761
9762          else
9763             Cons := No_List;
9764
9765             --  If type is unconstrained we have to add a constraint, copied
9766             --  from the actual value of the left hand side.
9767
9768             if not Is_Constrained (Target_Type) then
9769                if Has_Discriminants (Operand_Type) then
9770                   Disc := First_Discriminant (Operand_Type);
9771
9772                   if Disc /= First_Stored_Discriminant (Operand_Type) then
9773                      Disc := First_Stored_Discriminant (Operand_Type);
9774                   end if;
9775
9776                   Cons := New_List;
9777                   while Present (Disc) loop
9778                      Append_To (Cons,
9779                        Make_Selected_Component (Loc,
9780                          Prefix        =>
9781                            Duplicate_Subexpr_Move_Checks (Operand),
9782                          Selector_Name =>
9783                            Make_Identifier (Loc, Chars (Disc))));
9784                      Next_Discriminant (Disc);
9785                   end loop;
9786
9787                elsif Is_Array_Type (Operand_Type) then
9788                   N_Ix := First_Index (Target_Type);
9789                   Cons := New_List;
9790
9791                   for J in 1 .. Number_Dimensions (Operand_Type) loop
9792
9793                      --  We convert the bounds explicitly. We use an unchecked
9794                      --  conversion because bounds checks are done elsewhere.
9795
9796                      Append_To (Cons,
9797                        Make_Range (Loc,
9798                          Low_Bound =>
9799                            Unchecked_Convert_To (Etype (N_Ix),
9800                              Make_Attribute_Reference (Loc,
9801                                Prefix =>
9802                                  Duplicate_Subexpr_No_Checks
9803                                    (Operand, Name_Req => True),
9804                                Attribute_Name => Name_First,
9805                                Expressions    => New_List (
9806                                  Make_Integer_Literal (Loc, J)))),
9807
9808                          High_Bound =>
9809                            Unchecked_Convert_To (Etype (N_Ix),
9810                              Make_Attribute_Reference (Loc,
9811                                Prefix =>
9812                                  Duplicate_Subexpr_No_Checks
9813                                    (Operand, Name_Req => True),
9814                                Attribute_Name => Name_Last,
9815                                Expressions    => New_List (
9816                                  Make_Integer_Literal (Loc, J))))));
9817
9818                      Next_Index (N_Ix);
9819                   end loop;
9820                end if;
9821             end if;
9822
9823             Odef := New_Occurrence_Of (Target_Type, Loc);
9824
9825             if Present (Cons) then
9826                Odef :=
9827                  Make_Subtype_Indication (Loc,
9828                    Subtype_Mark => Odef,
9829                    Constraint =>
9830                      Make_Index_Or_Discriminant_Constraint (Loc,
9831                        Constraints => Cons));
9832             end if;
9833
9834             Temp := Make_Temporary (Loc, 'C');
9835             Decl :=
9836               Make_Object_Declaration (Loc,
9837                 Defining_Identifier => Temp,
9838                 Object_Definition   => Odef);
9839
9840             Set_No_Initialization (Decl, True);
9841
9842             --  Insert required actions. It is essential to suppress checks
9843             --  since we have suppressed default initialization, which means
9844             --  that the variable we create may have no discriminants.
9845
9846             Insert_Actions (N,
9847               New_List (
9848                 Decl,
9849                 Make_Assignment_Statement (Loc,
9850                   Name => New_Occurrence_Of (Temp, Loc),
9851                   Expression => Relocate_Node (N))),
9852                 Suppress => All_Checks);
9853
9854             Rewrite (N, New_Occurrence_Of (Temp, Loc));
9855             return;
9856          end if;
9857       end Handle_Changed_Representation;
9858
9859       -------------------------------
9860       -- Raise_Accessibility_Error --
9861       -------------------------------
9862
9863       procedure Raise_Accessibility_Error is
9864       begin
9865          Rewrite (N,
9866            Make_Raise_Program_Error (Sloc (N),
9867              Reason => PE_Accessibility_Check_Failed));
9868          Set_Etype (N, Target_Type);
9869
9870          Error_Msg_N
9871            ("??accessibility check failure", N);
9872          Error_Msg_NE
9873            ("\??& will be raised at run time", N, Standard_Program_Error);
9874       end Raise_Accessibility_Error;
9875
9876       ----------------------
9877       -- Real_Range_Check --
9878       ----------------------
9879
9880       --  Case of conversions to floating-point or fixed-point. If range checks
9881       --  are enabled and the target type has a range constraint, we convert:
9882
9883       --     typ (x)
9884
9885       --       to
9886
9887       --     Tnn : typ'Base := typ'Base (x);
9888       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
9889       --     Tnn
9890
9891       --  This is necessary when there is a conversion of integer to float or
9892       --  to fixed-point to ensure that the correct checks are made. It is not
9893       --  necessary for float to float where it is enough to simply set the
9894       --  Do_Range_Check flag.
9895
9896       procedure Real_Range_Check is
9897          Btyp : constant Entity_Id := Base_Type (Target_Type);
9898          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
9899          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
9900          Xtyp : constant Entity_Id := Etype (Operand);
9901          Conv : Node_Id;
9902          Tnn  : Entity_Id;
9903
9904       begin
9905          --  Nothing to do if conversion was rewritten
9906
9907          if Nkind (N) /= N_Type_Conversion then
9908             return;
9909          end if;
9910
9911          --  Nothing to do if range checks suppressed, or target has the same
9912          --  range as the base type (or is the base type).
9913
9914          if Range_Checks_Suppressed (Target_Type)
9915            or else (Lo = Type_Low_Bound  (Btyp)
9916                       and then
9917                     Hi = Type_High_Bound (Btyp))
9918          then
9919             return;
9920          end if;
9921
9922          --  Nothing to do if expression is an entity on which checks have been
9923          --  suppressed.
9924
9925          if Is_Entity_Name (Operand)
9926            and then Range_Checks_Suppressed (Entity (Operand))
9927          then
9928             return;
9929          end if;
9930
9931          --  Nothing to do if bounds are all static and we can tell that the
9932          --  expression is within the bounds of the target. Note that if the
9933          --  operand is of an unconstrained floating-point type, then we do
9934          --  not trust it to be in range (might be infinite)
9935
9936          declare
9937             S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
9938             S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
9939
9940          begin
9941             if (not Is_Floating_Point_Type (Xtyp)
9942                  or else Is_Constrained (Xtyp))
9943               and then Compile_Time_Known_Value (S_Lo)
9944               and then Compile_Time_Known_Value (S_Hi)
9945               and then Compile_Time_Known_Value (Hi)
9946               and then Compile_Time_Known_Value (Lo)
9947             then
9948                declare
9949                   D_Lov : constant Ureal := Expr_Value_R (Lo);
9950                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
9951                   S_Lov : Ureal;
9952                   S_Hiv : Ureal;
9953
9954                begin
9955                   if Is_Real_Type (Xtyp) then
9956                      S_Lov := Expr_Value_R (S_Lo);
9957                      S_Hiv := Expr_Value_R (S_Hi);
9958                   else
9959                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
9960                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
9961                   end if;
9962
9963                   if D_Hiv > D_Lov
9964                     and then S_Lov >= D_Lov
9965                     and then S_Hiv <= D_Hiv
9966                   then
9967                      Set_Do_Range_Check (Operand, False);
9968                      return;
9969                   end if;
9970                end;
9971             end if;
9972          end;
9973
9974          --  For float to float conversions, we are done
9975
9976          if Is_Floating_Point_Type (Xtyp)
9977               and then
9978             Is_Floating_Point_Type (Btyp)
9979          then
9980             return;
9981          end if;
9982
9983          --  Otherwise rewrite the conversion as described above
9984
9985          Conv := Relocate_Node (N);
9986          Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
9987          Set_Etype (Conv, Btyp);
9988
9989          --  Enable overflow except for case of integer to float conversions,
9990          --  where it is never required, since we can never have overflow in
9991          --  this case.
9992
9993          if not Is_Integer_Type (Etype (Operand)) then
9994             Enable_Overflow_Check (Conv);
9995          end if;
9996
9997          Tnn := Make_Temporary (Loc, 'T', Conv);
9998
9999          Insert_Actions (N, New_List (
10000            Make_Object_Declaration (Loc,
10001              Defining_Identifier => Tnn,
10002              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
10003              Constant_Present    => True,
10004              Expression          => Conv),
10005
10006            Make_Raise_Constraint_Error (Loc,
10007              Condition =>
10008               Make_Or_Else (Loc,
10009                 Left_Opnd =>
10010                   Make_Op_Lt (Loc,
10011                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
10012                     Right_Opnd =>
10013                       Make_Attribute_Reference (Loc,
10014                         Attribute_Name => Name_First,
10015                         Prefix =>
10016                           New_Occurrence_Of (Target_Type, Loc))),
10017
10018                 Right_Opnd =>
10019                   Make_Op_Gt (Loc,
10020                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
10021                     Right_Opnd =>
10022                       Make_Attribute_Reference (Loc,
10023                         Attribute_Name => Name_Last,
10024                         Prefix =>
10025                           New_Occurrence_Of (Target_Type, Loc)))),
10026              Reason => CE_Range_Check_Failed)));
10027
10028          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
10029          Analyze_And_Resolve (N, Btyp);
10030       end Real_Range_Check;
10031
10032       -----------------------------
10033       -- Has_Extra_Accessibility --
10034       -----------------------------
10035
10036       --  Returns true for a formal of an anonymous access type or for
10037       --  an Ada 2012-style stand-alone object of an anonymous access type.
10038
10039       function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
10040       begin
10041          if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
10042             return Present (Effective_Extra_Accessibility (Id));
10043          else
10044             return False;
10045          end if;
10046       end Has_Extra_Accessibility;
10047
10048    --  Start of processing for Expand_N_Type_Conversion
10049
10050    begin
10051       --  Nothing at all to do if conversion is to the identical type so remove
10052       --  the conversion completely, it is useless, except that it may carry
10053       --  an Assignment_OK attribute, which must be propagated to the operand.
10054
10055       if Operand_Type = Target_Type then
10056          if Assignment_OK (N) then
10057             Set_Assignment_OK (Operand);
10058          end if;
10059
10060          Rewrite (N, Relocate_Node (Operand));
10061          goto Done;
10062       end if;
10063
10064       --  Nothing to do if this is the second argument of read. This is a
10065       --  "backwards" conversion that will be handled by the specialized code
10066       --  in attribute processing.
10067
10068       if Nkind (Parent (N)) = N_Attribute_Reference
10069         and then Attribute_Name (Parent (N)) = Name_Read
10070         and then Next (First (Expressions (Parent (N)))) = N
10071       then
10072          goto Done;
10073       end if;
10074
10075       --  Check for case of converting to a type that has an invariant
10076       --  associated with it. This required an invariant check. We convert
10077
10078       --    typ (expr)
10079
10080       --  into
10081
10082       --    do invariant_check (typ (expr)) in typ (expr);
10083
10084       --  using Duplicate_Subexpr to avoid multiple side effects
10085
10086       --  Note: the Comes_From_Source check, and then the resetting of this
10087       --  flag prevents what would otherwise be an infinite recursion.
10088
10089       if Has_Invariants (Target_Type)
10090         and then Present (Invariant_Procedure (Target_Type))
10091         and then Comes_From_Source (N)
10092       then
10093          Set_Comes_From_Source (N, False);
10094          Rewrite (N,
10095            Make_Expression_With_Actions (Loc,
10096              Actions    => New_List (
10097                Make_Invariant_Call (Duplicate_Subexpr (N))),
10098              Expression => Duplicate_Subexpr_No_Checks (N)));
10099          Analyze_And_Resolve (N, Target_Type);
10100          goto Done;
10101       end if;
10102
10103       --  Here if we may need to expand conversion
10104
10105       --  If the operand of the type conversion is an arithmetic operation on
10106       --  signed integers, and the based type of the signed integer type in
10107       --  question is smaller than Standard.Integer, we promote both of the
10108       --  operands to type Integer.
10109
10110       --  For example, if we have
10111
10112       --     target-type (opnd1 + opnd2)
10113
10114       --  and opnd1 and opnd2 are of type short integer, then we rewrite
10115       --  this as:
10116
10117       --     target-type (integer(opnd1) + integer(opnd2))
10118
10119       --  We do this because we are always allowed to compute in a larger type
10120       --  if we do the right thing with the result, and in this case we are
10121       --  going to do a conversion which will do an appropriate check to make
10122       --  sure that things are in range of the target type in any case. This
10123       --  avoids some unnecessary intermediate overflows.
10124
10125       --  We might consider a similar transformation in the case where the
10126       --  target is a real type or a 64-bit integer type, and the operand
10127       --  is an arithmetic operation using a 32-bit integer type. However,
10128       --  we do not bother with this case, because it could cause significant
10129       --  inefficiencies on 32-bit machines. On a 64-bit machine it would be
10130       --  much cheaper, but we don't want different behavior on 32-bit and
10131       --  64-bit machines. Note that the exclusion of the 64-bit case also
10132       --  handles the configurable run-time cases where 64-bit arithmetic
10133       --  may simply be unavailable.
10134
10135       --  Note: this circuit is partially redundant with respect to the circuit
10136       --  in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
10137       --  the processing here. Also we still need the Checks circuit, since we
10138       --  have to be sure not to generate junk overflow checks in the first
10139       --  place, since it would be trick to remove them here!
10140
10141       if Integer_Promotion_Possible (N) then
10142
10143          --  All conditions met, go ahead with transformation
10144
10145          declare
10146             Opnd : Node_Id;
10147             L, R : Node_Id;
10148
10149          begin
10150             R :=
10151               Make_Type_Conversion (Loc,
10152                 Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
10153                 Expression   => Relocate_Node (Right_Opnd (Operand)));
10154
10155             Opnd := New_Op_Node (Nkind (Operand), Loc);
10156             Set_Right_Opnd (Opnd, R);
10157
10158             if Nkind (Operand) in N_Binary_Op then
10159                L :=
10160                  Make_Type_Conversion (Loc,
10161                    Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
10162                    Expression   => Relocate_Node (Left_Opnd (Operand)));
10163
10164                Set_Left_Opnd  (Opnd, L);
10165             end if;
10166
10167             Rewrite (N,
10168               Make_Type_Conversion (Loc,
10169                 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
10170                 Expression   => Opnd));
10171
10172             Analyze_And_Resolve (N, Target_Type);
10173             goto Done;
10174          end;
10175       end if;
10176
10177       --  Do validity check if validity checking operands
10178
10179       if Validity_Checks_On and Validity_Check_Operands then
10180          Ensure_Valid (Operand);
10181       end if;
10182
10183       --  Special case of converting from non-standard boolean type
10184
10185       if Is_Boolean_Type (Operand_Type)
10186         and then (Nonzero_Is_True (Operand_Type))
10187       then
10188          Adjust_Condition (Operand);
10189          Set_Etype (Operand, Standard_Boolean);
10190          Operand_Type := Standard_Boolean;
10191       end if;
10192
10193       --  Case of converting to an access type
10194
10195       if Is_Access_Type (Target_Type) then
10196
10197          --  Apply an accessibility check when the conversion operand is an
10198          --  access parameter (or a renaming thereof), unless conversion was
10199          --  expanded from an Unchecked_ or Unrestricted_Access attribute.
10200          --  Note that other checks may still need to be applied below (such
10201          --  as tagged type checks).
10202
10203          if Is_Entity_Name (Operand)
10204            and then Has_Extra_Accessibility (Entity (Operand))
10205            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
10206            and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
10207                       or else Attribute_Name (Original_Node (N)) = Name_Access)
10208          then
10209             Apply_Accessibility_Check
10210               (Operand, Target_Type, Insert_Node => Operand);
10211
10212          --  If the level of the operand type is statically deeper than the
10213          --  level of the target type, then force Program_Error. Note that this
10214          --  can only occur for cases where the attribute is within the body of
10215          --  an instantiation (otherwise the conversion will already have been
10216          --  rejected as illegal). Note: warnings are issued by the analyzer
10217          --  for the instance cases.
10218
10219          elsif In_Instance_Body
10220            and then Type_Access_Level (Operand_Type) >
10221                     Type_Access_Level (Target_Type)
10222          then
10223             Raise_Accessibility_Error;
10224
10225          --  When the operand is a selected access discriminant the check needs
10226          --  to be made against the level of the object denoted by the prefix
10227          --  of the selected name. Force Program_Error for this case as well
10228          --  (this accessibility violation can only happen if within the body
10229          --  of an instantiation).
10230
10231          elsif In_Instance_Body
10232            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
10233            and then Nkind (Operand) = N_Selected_Component
10234            and then Object_Access_Level (Operand) >
10235                       Type_Access_Level (Target_Type)
10236          then
10237             Raise_Accessibility_Error;
10238             goto Done;
10239          end if;
10240       end if;
10241
10242       --  Case of conversions of tagged types and access to tagged types
10243
10244       --  When needed, that is to say when the expression is class-wide, Add
10245       --  runtime a tag check for (strict) downward conversion by using the
10246       --  membership test, generating:
10247
10248       --      [constraint_error when Operand not in Target_Type'Class]
10249
10250       --  or in the access type case
10251
10252       --      [constraint_error
10253       --        when Operand /= null
10254       --          and then Operand.all not in
10255       --            Designated_Type (Target_Type)'Class]
10256
10257       if (Is_Access_Type (Target_Type)
10258            and then Is_Tagged_Type (Designated_Type (Target_Type)))
10259         or else Is_Tagged_Type (Target_Type)
10260       then
10261          --  Do not do any expansion in the access type case if the parent is a
10262          --  renaming, since this is an error situation which will be caught by
10263          --  Sem_Ch8, and the expansion can interfere with this error check.
10264
10265          if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
10266             goto Done;
10267          end if;
10268
10269          --  Otherwise, proceed with processing tagged conversion
10270
10271          Tagged_Conversion : declare
10272             Actual_Op_Typ   : Entity_Id;
10273             Actual_Targ_Typ : Entity_Id;
10274             Make_Conversion : Boolean := False;
10275             Root_Op_Typ     : Entity_Id;
10276
10277             procedure Make_Tag_Check (Targ_Typ : Entity_Id);
10278             --  Create a membership check to test whether Operand is a member
10279             --  of Targ_Typ. If the original Target_Type is an access, include
10280             --  a test for null value. The check is inserted at N.
10281
10282             --------------------
10283             -- Make_Tag_Check --
10284             --------------------
10285
10286             procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
10287                Cond : Node_Id;
10288
10289             begin
10290                --  Generate:
10291                --    [Constraint_Error
10292                --       when Operand /= null
10293                --         and then Operand.all not in Targ_Typ]
10294
10295                if Is_Access_Type (Target_Type) then
10296                   Cond :=
10297                     Make_And_Then (Loc,
10298                       Left_Opnd =>
10299                         Make_Op_Ne (Loc,
10300                           Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
10301                           Right_Opnd => Make_Null (Loc)),
10302
10303                       Right_Opnd =>
10304                         Make_Not_In (Loc,
10305                           Left_Opnd  =>
10306                             Make_Explicit_Dereference (Loc,
10307                               Prefix => Duplicate_Subexpr_No_Checks (Operand)),
10308                           Right_Opnd => New_Reference_To (Targ_Typ, Loc)));
10309
10310                --  Generate:
10311                --    [Constraint_Error when Operand not in Targ_Typ]
10312
10313                else
10314                   Cond :=
10315                     Make_Not_In (Loc,
10316                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
10317                       Right_Opnd => New_Reference_To (Targ_Typ, Loc));
10318                end if;
10319
10320                Insert_Action (N,
10321                  Make_Raise_Constraint_Error (Loc,
10322                    Condition => Cond,
10323                    Reason    => CE_Tag_Check_Failed));
10324             end Make_Tag_Check;
10325
10326          --  Start of processing for Tagged_Conversion
10327
10328          begin
10329             --  Handle entities from the limited view
10330
10331             if Is_Access_Type (Operand_Type) then
10332                Actual_Op_Typ :=
10333                  Available_View (Designated_Type (Operand_Type));
10334             else
10335                Actual_Op_Typ := Operand_Type;
10336             end if;
10337
10338             if Is_Access_Type (Target_Type) then
10339                Actual_Targ_Typ :=
10340                  Available_View (Designated_Type (Target_Type));
10341             else
10342                Actual_Targ_Typ := Target_Type;
10343             end if;
10344
10345             Root_Op_Typ := Root_Type (Actual_Op_Typ);
10346
10347             --  Ada 2005 (AI-251): Handle interface type conversion
10348
10349             if Is_Interface (Actual_Op_Typ) then
10350                Expand_Interface_Conversion (N, Is_Static => False);
10351                goto Done;
10352             end if;
10353
10354             if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
10355
10356                --  Create a runtime tag check for a downward class-wide type
10357                --  conversion.
10358
10359                if Is_Class_Wide_Type (Actual_Op_Typ)
10360                  and then Actual_Op_Typ /= Actual_Targ_Typ
10361                  and then Root_Op_Typ /= Actual_Targ_Typ
10362                  and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ,
10363                                        Use_Full_View => True)
10364                then
10365                   Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
10366                   Make_Conversion := True;
10367                end if;
10368
10369                --  AI05-0073: If the result subtype of the function is defined
10370                --  by an access_definition designating a specific tagged type
10371                --  T, a check is made that the result value is null or the tag
10372                --  of the object designated by the result value identifies T.
10373                --  Constraint_Error is raised if this check fails.
10374
10375                if Nkind (Parent (N)) = N_Simple_Return_Statement then
10376                   declare
10377                      Func     : Entity_Id;
10378                      Func_Typ : Entity_Id;
10379
10380                   begin
10381                      --  Climb scope stack looking for the enclosing function
10382
10383                      Func := Current_Scope;
10384                      while Present (Func)
10385                        and then Ekind (Func) /= E_Function
10386                      loop
10387                         Func := Scope (Func);
10388                      end loop;
10389
10390                      --  The function's return subtype must be defined using
10391                      --  an access definition.
10392
10393                      if Nkind (Result_Definition (Parent (Func))) =
10394                           N_Access_Definition
10395                      then
10396                         Func_Typ := Directly_Designated_Type (Etype (Func));
10397
10398                         --  The return subtype denotes a specific tagged type,
10399                         --  in other words, a non class-wide type.
10400
10401                         if Is_Tagged_Type (Func_Typ)
10402                           and then not Is_Class_Wide_Type (Func_Typ)
10403                         then
10404                            Make_Tag_Check (Actual_Targ_Typ);
10405                            Make_Conversion := True;
10406                         end if;
10407                      end if;
10408                   end;
10409                end if;
10410
10411                --  We have generated a tag check for either a class-wide type
10412                --  conversion or for AI05-0073.
10413
10414                if Make_Conversion then
10415                   declare
10416                      Conv : Node_Id;
10417                   begin
10418                      Conv :=
10419                        Make_Unchecked_Type_Conversion (Loc,
10420                          Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
10421                          Expression   => Relocate_Node (Expression (N)));
10422                      Rewrite (N, Conv);
10423                      Analyze_And_Resolve (N, Target_Type);
10424                   end;
10425                end if;
10426             end if;
10427          end Tagged_Conversion;
10428
10429       --  Case of other access type conversions
10430
10431       elsif Is_Access_Type (Target_Type) then
10432          Apply_Constraint_Check (Operand, Target_Type);
10433
10434       --  Case of conversions from a fixed-point type
10435
10436       --  These conversions require special expansion and processing, found in
10437       --  the Exp_Fixd package. We ignore cases where Conversion_OK is set,
10438       --  since from a semantic point of view, these are simple integer
10439       --  conversions, which do not need further processing.
10440
10441       elsif Is_Fixed_Point_Type (Operand_Type)
10442         and then not Conversion_OK (N)
10443       then
10444          --  We should never see universal fixed at this case, since the
10445          --  expansion of the constituent divide or multiply should have
10446          --  eliminated the explicit mention of universal fixed.
10447
10448          pragma Assert (Operand_Type /= Universal_Fixed);
10449
10450          --  Check for special case of the conversion to universal real that
10451          --  occurs as a result of the use of a round attribute. In this case,
10452          --  the real type for the conversion is taken from the target type of
10453          --  the Round attribute and the result must be marked as rounded.
10454
10455          if Target_Type = Universal_Real
10456            and then Nkind (Parent (N)) = N_Attribute_Reference
10457            and then Attribute_Name (Parent (N)) = Name_Round
10458          then
10459             Set_Rounded_Result (N);
10460             Set_Etype (N, Etype (Parent (N)));
10461          end if;
10462
10463          --  Otherwise do correct fixed-conversion, but skip these if the
10464          --  Conversion_OK flag is set, because from a semantic point of view
10465          --  these are simple integer conversions needing no further processing
10466          --  (the backend will simply treat them as integers).
10467
10468          if not Conversion_OK (N) then
10469             if Is_Fixed_Point_Type (Etype (N)) then
10470                Expand_Convert_Fixed_To_Fixed (N);
10471                Real_Range_Check;
10472
10473             elsif Is_Integer_Type (Etype (N)) then
10474                Expand_Convert_Fixed_To_Integer (N);
10475
10476             else
10477                pragma Assert (Is_Floating_Point_Type (Etype (N)));
10478                Expand_Convert_Fixed_To_Float (N);
10479                Real_Range_Check;
10480             end if;
10481          end if;
10482
10483       --  Case of conversions to a fixed-point type
10484
10485       --  These conversions require special expansion and processing, found in
10486       --  the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
10487       --  since from a semantic point of view, these are simple integer
10488       --  conversions, which do not need further processing.
10489
10490       elsif Is_Fixed_Point_Type (Target_Type)
10491         and then not Conversion_OK (N)
10492       then
10493          if Is_Integer_Type (Operand_Type) then
10494             Expand_Convert_Integer_To_Fixed (N);
10495             Real_Range_Check;
10496          else
10497             pragma Assert (Is_Floating_Point_Type (Operand_Type));
10498             Expand_Convert_Float_To_Fixed (N);
10499             Real_Range_Check;
10500          end if;
10501
10502       --  Case of float-to-integer conversions
10503
10504       --  We also handle float-to-fixed conversions with Conversion_OK set
10505       --  since semantically the fixed-point target is treated as though it
10506       --  were an integer in such cases.
10507
10508       elsif Is_Floating_Point_Type (Operand_Type)
10509         and then
10510           (Is_Integer_Type (Target_Type)
10511             or else
10512           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
10513       then
10514          --  One more check here, gcc is still not able to do conversions of
10515          --  this type with proper overflow checking, and so gigi is doing an
10516          --  approximation of what is required by doing floating-point compares
10517          --  with the end-point. But that can lose precision in some cases, and
10518          --  give a wrong result. Converting the operand to Universal_Real is
10519          --  helpful, but still does not catch all cases with 64-bit integers
10520          --  on targets with only 64-bit floats.
10521
10522          --  The above comment seems obsoleted by Apply_Float_Conversion_Check
10523          --  Can this code be removed ???
10524
10525          if Do_Range_Check (Operand) then
10526             Rewrite (Operand,
10527               Make_Type_Conversion (Loc,
10528                 Subtype_Mark =>
10529                   New_Occurrence_Of (Universal_Real, Loc),
10530                 Expression =>
10531                   Relocate_Node (Operand)));
10532
10533             Set_Etype (Operand, Universal_Real);
10534             Enable_Range_Check (Operand);
10535             Set_Do_Range_Check (Expression (Operand), False);
10536          end if;
10537
10538       --  Case of array conversions
10539
10540       --  Expansion of array conversions, add required length/range checks but
10541       --  only do this if there is no change of representation. For handling of
10542       --  this case, see Handle_Changed_Representation.
10543
10544       elsif Is_Array_Type (Target_Type) then
10545          if Is_Constrained (Target_Type) then
10546             Apply_Length_Check (Operand, Target_Type);
10547          else
10548             Apply_Range_Check (Operand, Target_Type);
10549          end if;
10550
10551          Handle_Changed_Representation;
10552
10553       --  Case of conversions of discriminated types
10554
10555       --  Add required discriminant checks if target is constrained. Again this
10556       --  change is skipped if we have a change of representation.
10557
10558       elsif Has_Discriminants (Target_Type)
10559         and then Is_Constrained (Target_Type)
10560       then
10561          Apply_Discriminant_Check (Operand, Target_Type);
10562          Handle_Changed_Representation;
10563
10564       --  Case of all other record conversions. The only processing required
10565       --  is to check for a change of representation requiring the special
10566       --  assignment processing.
10567
10568       elsif Is_Record_Type (Target_Type) then
10569
10570          --  Ada 2005 (AI-216): Program_Error is raised when converting from
10571          --  a derived Unchecked_Union type to an unconstrained type that is
10572          --  not Unchecked_Union if the operand lacks inferable discriminants.
10573
10574          if Is_Derived_Type (Operand_Type)
10575            and then Is_Unchecked_Union (Base_Type (Operand_Type))
10576            and then not Is_Constrained (Target_Type)
10577            and then not Is_Unchecked_Union (Base_Type (Target_Type))
10578            and then not Has_Inferable_Discriminants (Operand)
10579          then
10580             --  To prevent Gigi from generating illegal code, we generate a
10581             --  Program_Error node, but we give it the target type of the
10582             --  conversion (is this requirement documented somewhere ???)
10583
10584             declare
10585                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
10586                       Reason => PE_Unchecked_Union_Restriction);
10587
10588             begin
10589                Set_Etype (PE, Target_Type);
10590                Rewrite (N, PE);
10591
10592             end;
10593          else
10594             Handle_Changed_Representation;
10595          end if;
10596
10597       --  Case of conversions of enumeration types
10598
10599       elsif Is_Enumeration_Type (Target_Type) then
10600
10601          --  Special processing is required if there is a change of
10602          --  representation (from enumeration representation clauses).
10603
10604          if not Same_Representation (Target_Type, Operand_Type) then
10605
10606             --  Convert: x(y) to x'val (ytyp'val (y))
10607
10608             Rewrite (N,
10609               Make_Attribute_Reference (Loc,
10610                 Prefix         => New_Occurrence_Of (Target_Type, Loc),
10611                 Attribute_Name => Name_Val,
10612                 Expressions    => New_List (
10613                   Make_Attribute_Reference (Loc,
10614                     Prefix         => New_Occurrence_Of (Operand_Type, Loc),
10615                     Attribute_Name => Name_Pos,
10616                     Expressions    => New_List (Operand)))));
10617
10618             Analyze_And_Resolve (N, Target_Type);
10619          end if;
10620
10621       --  Case of conversions to floating-point
10622
10623       elsif Is_Floating_Point_Type (Target_Type) then
10624          Real_Range_Check;
10625       end if;
10626
10627       --  At this stage, either the conversion node has been transformed into
10628       --  some other equivalent expression, or left as a conversion that can be
10629       --  handled by Gigi, in the following cases:
10630
10631       --    Conversions with no change of representation or type
10632
10633       --    Numeric conversions involving integer, floating- and fixed-point
10634       --    values. Fixed-point values are allowed only if Conversion_OK is
10635       --    set, i.e. if the fixed-point values are to be treated as integers.
10636
10637       --  No other conversions should be passed to Gigi
10638
10639       --  Check: are these rules stated in sinfo??? if so, why restate here???
10640
10641       --  The only remaining step is to generate a range check if we still have
10642       --  a type conversion at this stage and Do_Range_Check is set. For now we
10643       --  do this only for conversions of discrete types.
10644
10645       if Nkind (N) = N_Type_Conversion
10646         and then Is_Discrete_Type (Etype (N))
10647       then
10648          declare
10649             Expr : constant Node_Id := Expression (N);
10650             Ftyp : Entity_Id;
10651             Ityp : Entity_Id;
10652
10653          begin
10654             if Do_Range_Check (Expr)
10655               and then Is_Discrete_Type (Etype (Expr))
10656             then
10657                Set_Do_Range_Check (Expr, False);
10658
10659                --  Before we do a range check, we have to deal with treating a
10660                --  fixed-point operand as an integer. The way we do this is
10661                --  simply to do an unchecked conversion to an appropriate
10662                --  integer type large enough to hold the result.
10663
10664                --  This code is not active yet, because we are only dealing
10665                --  with discrete types so far ???
10666
10667                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
10668                  and then Treat_Fixed_As_Integer (Expr)
10669                then
10670                   Ftyp := Base_Type (Etype (Expr));
10671
10672                   if Esize (Ftyp) >= Esize (Standard_Integer) then
10673                      Ityp := Standard_Long_Long_Integer;
10674                   else
10675                      Ityp := Standard_Integer;
10676                   end if;
10677
10678                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
10679                end if;
10680
10681                --  Reset overflow flag, since the range check will include
10682                --  dealing with possible overflow, and generate the check. If
10683                --  Address is either a source type or target type, suppress
10684                --  range check to avoid typing anomalies when it is a visible
10685                --  integer type.
10686
10687                Set_Do_Overflow_Check (N, False);
10688                if not Is_Descendent_Of_Address (Etype (Expr))
10689                  and then not Is_Descendent_Of_Address (Target_Type)
10690                then
10691                   Generate_Range_Check
10692                     (Expr, Target_Type, CE_Range_Check_Failed);
10693                end if;
10694             end if;
10695          end;
10696       end if;
10697
10698       --  Final step, if the result is a type conversion involving Vax_Float
10699       --  types, then it is subject for further special processing.
10700
10701       if Nkind (N) = N_Type_Conversion
10702         and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
10703       then
10704          Expand_Vax_Conversion (N);
10705          goto Done;
10706       end if;
10707
10708       --  Here at end of processing
10709
10710    <<Done>>
10711       --  Apply predicate check if required. Note that we can't just call
10712       --  Apply_Predicate_Check here, because the type looks right after
10713       --  the conversion and it would omit the check. The Comes_From_Source
10714       --  guard is necessary to prevent infinite recursions when we generate
10715       --  internal conversions for the purpose of checking predicates.
10716
10717       if Present (Predicate_Function (Target_Type))
10718         and then Target_Type /= Operand_Type
10719         and then Comes_From_Source (N)
10720       then
10721          declare
10722             New_Expr : constant Node_Id := Duplicate_Subexpr (N);
10723
10724          begin
10725             --  Avoid infinite recursion on the subsequent expansion of
10726             --  of the copy of the original type conversion.
10727
10728             Set_Comes_From_Source (New_Expr, False);
10729             Insert_Action (N, Make_Predicate_Check (Target_Type, New_Expr));
10730          end;
10731       end if;
10732    end Expand_N_Type_Conversion;
10733
10734    -----------------------------------
10735    -- Expand_N_Unchecked_Expression --
10736    -----------------------------------
10737
10738    --  Remove the unchecked expression node from the tree. Its job was simply
10739    --  to make sure that its constituent expression was handled with checks
10740    --  off, and now that that is done, we can remove it from the tree, and
10741    --  indeed must, since Gigi does not expect to see these nodes.
10742
10743    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
10744       Exp : constant Node_Id := Expression (N);
10745    begin
10746       Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
10747       Rewrite (N, Exp);
10748    end Expand_N_Unchecked_Expression;
10749
10750    ----------------------------------------
10751    -- Expand_N_Unchecked_Type_Conversion --
10752    ----------------------------------------
10753
10754    --  If this cannot be handled by Gigi and we haven't already made a
10755    --  temporary for it, do it now.
10756
10757    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
10758       Target_Type  : constant Entity_Id := Etype (N);
10759       Operand      : constant Node_Id   := Expression (N);
10760       Operand_Type : constant Entity_Id := Etype (Operand);
10761
10762    begin
10763       --  Nothing at all to do if conversion is to the identical type so remove
10764       --  the conversion completely, it is useless, except that it may carry
10765       --  an Assignment_OK indication which must be propagated to the operand.
10766
10767       if Operand_Type = Target_Type then
10768
10769          --  Code duplicates Expand_N_Unchecked_Expression above, factor???
10770
10771          if Assignment_OK (N) then
10772             Set_Assignment_OK (Operand);
10773          end if;
10774
10775          Rewrite (N, Relocate_Node (Operand));
10776          return;
10777       end if;
10778
10779       --  If we have a conversion of a compile time known value to a target
10780       --  type and the value is in range of the target type, then we can simply
10781       --  replace the construct by an integer literal of the correct type. We
10782       --  only apply this to integer types being converted. Possibly it may
10783       --  apply in other cases, but it is too much trouble to worry about.
10784
10785       --  Note that we do not do this transformation if the Kill_Range_Check
10786       --  flag is set, since then the value may be outside the expected range.
10787       --  This happens in the Normalize_Scalars case.
10788
10789       --  We also skip this if either the target or operand type is biased
10790       --  because in this case, the unchecked conversion is supposed to
10791       --  preserve the bit pattern, not the integer value.
10792
10793       if Is_Integer_Type (Target_Type)
10794         and then not Has_Biased_Representation (Target_Type)
10795         and then Is_Integer_Type (Operand_Type)
10796         and then not Has_Biased_Representation (Operand_Type)
10797         and then Compile_Time_Known_Value (Operand)
10798         and then not Kill_Range_Check (N)
10799       then
10800          declare
10801             Val : constant Uint := Expr_Value (Operand);
10802
10803          begin
10804             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
10805                  and then
10806                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
10807                  and then
10808                Val >= Expr_Value (Type_Low_Bound (Target_Type))
10809                  and then
10810                Val <= Expr_Value (Type_High_Bound (Target_Type))
10811             then
10812                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
10813
10814                --  If Address is the target type, just set the type to avoid a
10815                --  spurious type error on the literal when Address is a visible
10816                --  integer type.
10817
10818                if Is_Descendent_Of_Address (Target_Type) then
10819                   Set_Etype (N, Target_Type);
10820                else
10821                   Analyze_And_Resolve (N, Target_Type);
10822                end if;
10823
10824                return;
10825             end if;
10826          end;
10827       end if;
10828
10829       --  Nothing to do if conversion is safe
10830
10831       if Safe_Unchecked_Type_Conversion (N) then
10832          return;
10833       end if;
10834
10835       --  Otherwise force evaluation unless Assignment_OK flag is set (this
10836       --  flag indicates ??? More comments needed here)
10837
10838       if Assignment_OK (N) then
10839          null;
10840       else
10841          Force_Evaluation (N);
10842       end if;
10843    end Expand_N_Unchecked_Type_Conversion;
10844
10845    ----------------------------
10846    -- Expand_Record_Equality --
10847    ----------------------------
10848
10849    --  For non-variant records, Equality is expanded when needed into:
10850
10851    --      and then Lhs.Discr1 = Rhs.Discr1
10852    --      and then ...
10853    --      and then Lhs.Discrn = Rhs.Discrn
10854    --      and then Lhs.Cmp1 = Rhs.Cmp1
10855    --      and then ...
10856    --      and then Lhs.Cmpn = Rhs.Cmpn
10857
10858    --  The expression is folded by the back-end for adjacent fields. This
10859    --  function is called for tagged record in only one occasion: for imple-
10860    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
10861    --  otherwise the primitive "=" is used directly.
10862
10863    function Expand_Record_Equality
10864      (Nod    : Node_Id;
10865       Typ    : Entity_Id;
10866       Lhs    : Node_Id;
10867       Rhs    : Node_Id;
10868       Bodies : List_Id) return Node_Id
10869    is
10870       Loc : constant Source_Ptr := Sloc (Nod);
10871
10872       Result : Node_Id;
10873       C      : Entity_Id;
10874
10875       First_Time : Boolean := True;
10876
10877       function Element_To_Compare (C : Entity_Id) return Entity_Id;
10878       --  Return the next discriminant or component to compare, starting with
10879       --  C, skipping inherited components.
10880
10881       ------------------------
10882       -- Element_To_Compare --
10883       ------------------------
10884
10885       function Element_To_Compare (C : Entity_Id) return Entity_Id is
10886          Comp : Entity_Id;
10887
10888       begin
10889          Comp := C;
10890          loop
10891             --  Exit loop when the next element to be compared is found, or
10892             --  there is no more such element.
10893
10894             exit when No (Comp);
10895
10896             exit when Ekind_In (Comp, E_Discriminant, E_Component)
10897               and then not (
10898
10899               --  Skip inherited components
10900
10901               --  Note: for a tagged type, we always generate the "=" primitive
10902               --  for the base type (not on the first subtype), so the test for
10903               --  Comp /= Original_Record_Component (Comp) is True for
10904               --  inherited components only.
10905
10906               (Is_Tagged_Type (Typ)
10907                 and then Comp /= Original_Record_Component (Comp))
10908
10909               --  Skip _Tag
10910
10911               or else Chars (Comp) = Name_uTag
10912
10913               --  The .NET/JVM version of type Root_Controlled contains two
10914               --  fields which should not be considered part of the object. To
10915               --  achieve proper equiality between two controlled objects on
10916               --  .NET/JVM, skip _Parent whenever it has type Root_Controlled.
10917
10918               or else (Chars (Comp) = Name_uParent
10919                         and then VM_Target /= No_VM
10920                         and then Etype (Comp) = RTE (RE_Root_Controlled))
10921
10922               --  Skip interface elements (secondary tags???)
10923
10924               or else Is_Interface (Etype (Comp)));
10925
10926             Next_Entity (Comp);
10927          end loop;
10928
10929          return Comp;
10930       end Element_To_Compare;
10931
10932    --  Start of processing for Expand_Record_Equality
10933
10934    begin
10935       --  Generates the following code: (assuming that Typ has one Discr and
10936       --  component C2 is also a record)
10937
10938       --   True
10939       --     and then Lhs.Discr1 = Rhs.Discr1
10940       --     and then Lhs.C1 = Rhs.C1
10941       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
10942       --     and then ...
10943       --     and then Lhs.Cmpn = Rhs.Cmpn
10944
10945       Result := New_Reference_To (Standard_True, Loc);
10946       C := Element_To_Compare (First_Entity (Typ));
10947       while Present (C) loop
10948          declare
10949             New_Lhs : Node_Id;
10950             New_Rhs : Node_Id;
10951             Check   : Node_Id;
10952
10953          begin
10954             if First_Time then
10955                First_Time := False;
10956                New_Lhs := Lhs;
10957                New_Rhs := Rhs;
10958             else
10959                New_Lhs := New_Copy_Tree (Lhs);
10960                New_Rhs := New_Copy_Tree (Rhs);
10961             end if;
10962
10963             Check :=
10964               Expand_Composite_Equality (Nod, Etype (C),
10965                Lhs =>
10966                  Make_Selected_Component (Loc,
10967                    Prefix => New_Lhs,
10968                    Selector_Name => New_Reference_To (C, Loc)),
10969                Rhs =>
10970                  Make_Selected_Component (Loc,
10971                    Prefix => New_Rhs,
10972                    Selector_Name => New_Reference_To (C, Loc)),
10973                Bodies => Bodies);
10974
10975             --  If some (sub)component is an unchecked_union, the whole
10976             --  operation will raise program error.
10977
10978             if Nkind (Check) = N_Raise_Program_Error then
10979                Result := Check;
10980                Set_Etype (Result, Standard_Boolean);
10981                exit;
10982             else
10983                Result :=
10984                  Make_And_Then (Loc,
10985                    Left_Opnd  => Result,
10986                    Right_Opnd => Check);
10987             end if;
10988          end;
10989
10990          C := Element_To_Compare (Next_Entity (C));
10991       end loop;
10992
10993       return Result;
10994    end Expand_Record_Equality;
10995
10996    ---------------------------
10997    -- Expand_Set_Membership --
10998    ---------------------------
10999
11000    procedure Expand_Set_Membership (N : Node_Id) is
11001       Lop : constant Node_Id := Left_Opnd (N);
11002       Alt : Node_Id;
11003       Res : Node_Id;
11004
11005       function Make_Cond (Alt : Node_Id) return Node_Id;
11006       --  If the alternative is a subtype mark, create a simple membership
11007       --  test. Otherwise create an equality test for it.
11008
11009       ---------------
11010       -- Make_Cond --
11011       ---------------
11012
11013       function Make_Cond (Alt : Node_Id) return Node_Id is
11014          Cond : Node_Id;
11015          L    : constant Node_Id := New_Copy (Lop);
11016          R    : constant Node_Id := Relocate_Node (Alt);
11017
11018       begin
11019          if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
11020            or else Nkind (Alt) = N_Range
11021          then
11022             Cond :=
11023               Make_In (Sloc (Alt),
11024                 Left_Opnd  => L,
11025                 Right_Opnd => R);
11026          else
11027             Cond :=
11028               Make_Op_Eq (Sloc (Alt),
11029                 Left_Opnd  => L,
11030                 Right_Opnd => R);
11031          end if;
11032
11033          return Cond;
11034       end Make_Cond;
11035
11036    --  Start of processing for Expand_Set_Membership
11037
11038    begin
11039       Remove_Side_Effects (Lop);
11040
11041       Alt := Last (Alternatives (N));
11042       Res := Make_Cond (Alt);
11043
11044       Prev (Alt);
11045       while Present (Alt) loop
11046          Res :=
11047            Make_Or_Else (Sloc (Alt),
11048              Left_Opnd  => Make_Cond (Alt),
11049              Right_Opnd => Res);
11050          Prev (Alt);
11051       end loop;
11052
11053       Rewrite (N, Res);
11054       Analyze_And_Resolve (N, Standard_Boolean);
11055    end Expand_Set_Membership;
11056
11057    -----------------------------------
11058    -- Expand_Short_Circuit_Operator --
11059    -----------------------------------
11060
11061    --  Deal with special expansion if actions are present for the right operand
11062    --  and deal with optimizing case of arguments being True or False. We also
11063    --  deal with the special case of non-standard boolean values.
11064
11065    procedure Expand_Short_Circuit_Operator (N : Node_Id) is
11066       Loc     : constant Source_Ptr := Sloc (N);
11067       Typ     : constant Entity_Id  := Etype (N);
11068       Left    : constant Node_Id    := Left_Opnd (N);
11069       Right   : constant Node_Id    := Right_Opnd (N);
11070       LocR    : constant Source_Ptr := Sloc (Right);
11071       Actlist : List_Id;
11072
11073       Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
11074       Shortcut_Ent   : constant Entity_Id := Boolean_Literals (Shortcut_Value);
11075       --  If Left = Shortcut_Value then Right need not be evaluated
11076
11077       function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
11078       --  For Opnd a boolean expression, return a Boolean expression equivalent
11079       --  to Opnd /= Shortcut_Value.
11080
11081       --------------------
11082       -- Make_Test_Expr --
11083       --------------------
11084
11085       function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
11086       begin
11087          if Shortcut_Value then
11088             return Make_Op_Not (Sloc (Opnd), Opnd);
11089          else
11090             return Opnd;
11091          end if;
11092       end Make_Test_Expr;
11093
11094       Op_Var : Entity_Id;
11095       --  Entity for a temporary variable holding the value of the operator,
11096       --  used for expansion in the case where actions are present.
11097
11098    --  Start of processing for Expand_Short_Circuit_Operator
11099
11100    begin
11101       --  Deal with non-standard booleans
11102
11103       if Is_Boolean_Type (Typ) then
11104          Adjust_Condition (Left);
11105          Adjust_Condition (Right);
11106          Set_Etype (N, Standard_Boolean);
11107       end if;
11108
11109       --  Check for cases where left argument is known to be True or False
11110
11111       if Compile_Time_Known_Value (Left) then
11112
11113          --  Mark SCO for left condition as compile time known
11114
11115          if Generate_SCO and then Comes_From_Source (Left) then
11116             Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
11117          end if;
11118
11119          --  Rewrite True AND THEN Right / False OR ELSE Right to Right.
11120          --  Any actions associated with Right will be executed unconditionally
11121          --  and can thus be inserted into the tree unconditionally.
11122
11123          if Expr_Value_E (Left) /= Shortcut_Ent then
11124             if Present (Actions (N)) then
11125                Insert_Actions (N, Actions (N));
11126             end if;
11127
11128             Rewrite (N, Right);
11129
11130          --  Rewrite False AND THEN Right / True OR ELSE Right to Left.
11131          --  In this case we can forget the actions associated with Right,
11132          --  since they will never be executed.
11133
11134          else
11135             Kill_Dead_Code (Right);
11136             Kill_Dead_Code (Actions (N));
11137             Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11138          end if;
11139
11140          Adjust_Result_Type (N, Typ);
11141          return;
11142       end if;
11143
11144       --  If Actions are present for the right operand, we have to do some
11145       --  special processing. We can't just let these actions filter back into
11146       --  code preceding the short circuit (which is what would have happened
11147       --  if we had not trapped them in the short-circuit form), since they
11148       --  must only be executed if the right operand of the short circuit is
11149       --  executed and not otherwise.
11150
11151       --  the temporary variable C.
11152
11153       if Present (Actions (N)) then
11154          Actlist := Actions (N);
11155
11156          --  The old approach is to expand:
11157
11158          --     left AND THEN right
11159
11160          --  into
11161
11162          --     C : Boolean := False;
11163          --     IF left THEN
11164          --        Actions;
11165          --        IF right THEN
11166          --           C := True;
11167          --        END IF;
11168          --     END IF;
11169
11170          --  and finally rewrite the operator into a reference to C. Similarly
11171          --  for left OR ELSE right, with negated values. Note that this
11172          --  rewrite causes some difficulties for coverage analysis because
11173          --  of the introduction of the new variable C, which obscures the
11174          --  structure of the test.
11175
11176          --  We use this "old approach" if use of N_Expression_With_Actions
11177          --  is False (see description in Opt of when this is or is not set).
11178
11179          if not Use_Expression_With_Actions then
11180             Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
11181
11182             Insert_Action (N,
11183               Make_Object_Declaration (Loc,
11184                 Defining_Identifier =>
11185                   Op_Var,
11186                 Object_Definition   =>
11187                   New_Occurrence_Of (Standard_Boolean, Loc),
11188                 Expression          =>
11189                   New_Occurrence_Of (Shortcut_Ent, Loc)));
11190
11191             Append_To (Actlist,
11192               Make_Implicit_If_Statement (Right,
11193                 Condition       => Make_Test_Expr (Right),
11194                 Then_Statements => New_List (
11195                   Make_Assignment_Statement (LocR,
11196                     Name       => New_Occurrence_Of (Op_Var, LocR),
11197                     Expression =>
11198                       New_Occurrence_Of
11199                         (Boolean_Literals (not Shortcut_Value), LocR)))));
11200
11201             Insert_Action (N,
11202               Make_Implicit_If_Statement (Left,
11203                 Condition       => Make_Test_Expr (Left),
11204                 Then_Statements => Actlist));
11205
11206             Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
11207             Analyze_And_Resolve (N, Standard_Boolean);
11208
11209          --  The new approach, activated for now by the use of debug flag
11210          --  -gnatd.X is to use the new Expression_With_Actions node for the
11211          --  right operand of the short-circuit form. This should solve the
11212          --  traceability problems for coverage analysis.
11213
11214          else
11215             Rewrite (Right,
11216               Make_Expression_With_Actions (LocR,
11217                 Expression => Relocate_Node (Right),
11218                 Actions    => Actlist));
11219             Set_Actions (N, No_List);
11220             Analyze_And_Resolve (Right, Standard_Boolean);
11221          end if;
11222
11223          Adjust_Result_Type (N, Typ);
11224          return;
11225       end if;
11226
11227       --  No actions present, check for cases of right argument True/False
11228
11229       if Compile_Time_Known_Value (Right) then
11230
11231          --  Mark SCO for left condition as compile time known
11232
11233          if Generate_SCO and then Comes_From_Source (Right) then
11234             Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
11235          end if;
11236
11237          --  Change (Left and then True), (Left or else False) to Left.
11238          --  Note that we know there are no actions associated with the right
11239          --  operand, since we just checked for this case above.
11240
11241          if Expr_Value_E (Right) /= Shortcut_Ent then
11242             Rewrite (N, Left);
11243
11244          --  Change (Left and then False), (Left or else True) to Right,
11245          --  making sure to preserve any side effects associated with the Left
11246          --  operand.
11247
11248          else
11249             Remove_Side_Effects (Left);
11250             Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
11251          end if;
11252       end if;
11253
11254       Adjust_Result_Type (N, Typ);
11255    end Expand_Short_Circuit_Operator;
11256
11257    -------------------------------------
11258    -- Fixup_Universal_Fixed_Operation --
11259    -------------------------------------
11260
11261    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
11262       Conv : constant Node_Id := Parent (N);
11263
11264    begin
11265       --  We must have a type conversion immediately above us
11266
11267       pragma Assert (Nkind (Conv) = N_Type_Conversion);
11268
11269       --  Normally the type conversion gives our target type. The exception
11270       --  occurs in the case of the Round attribute, where the conversion
11271       --  will be to universal real, and our real type comes from the Round
11272       --  attribute (as well as an indication that we must round the result)
11273
11274       if Nkind (Parent (Conv)) = N_Attribute_Reference
11275         and then Attribute_Name (Parent (Conv)) = Name_Round
11276       then
11277          Set_Etype (N, Etype (Parent (Conv)));
11278          Set_Rounded_Result (N);
11279
11280       --  Normal case where type comes from conversion above us
11281
11282       else
11283          Set_Etype (N, Etype (Conv));
11284       end if;
11285    end Fixup_Universal_Fixed_Operation;
11286
11287    ---------------------------------
11288    -- Has_Inferable_Discriminants --
11289    ---------------------------------
11290
11291    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
11292
11293       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
11294       --  Determines whether the left-most prefix of a selected component is a
11295       --  formal parameter in a subprogram. Assumes N is a selected component.
11296
11297       --------------------------------
11298       -- Prefix_Is_Formal_Parameter --
11299       --------------------------------
11300
11301       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
11302          Sel_Comp : Node_Id;
11303
11304       begin
11305          --  Move to the left-most prefix by climbing up the tree
11306
11307          Sel_Comp := N;
11308          while Present (Parent (Sel_Comp))
11309            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
11310          loop
11311             Sel_Comp := Parent (Sel_Comp);
11312          end loop;
11313
11314          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
11315       end Prefix_Is_Formal_Parameter;
11316
11317    --  Start of processing for Has_Inferable_Discriminants
11318
11319    begin
11320       --  For selected components, the subtype of the selector must be a
11321       --  constrained Unchecked_Union. If the component is subject to a
11322       --  per-object constraint, then the enclosing object must have inferable
11323       --  discriminants.
11324
11325       if Nkind (N) = N_Selected_Component then
11326          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
11327
11328             --  A small hack. If we have a per-object constrained selected
11329             --  component of a formal parameter, return True since we do not
11330             --  know the actual parameter association yet.
11331
11332             if Prefix_Is_Formal_Parameter (N) then
11333                return True;
11334
11335             --  Otherwise, check the enclosing object and the selector
11336
11337             else
11338                return Has_Inferable_Discriminants (Prefix (N))
11339                  and then Has_Inferable_Discriminants (Selector_Name (N));
11340             end if;
11341
11342          --  The call to Has_Inferable_Discriminants will determine whether
11343          --  the selector has a constrained Unchecked_Union nominal type.
11344
11345          else
11346             return Has_Inferable_Discriminants (Selector_Name (N));
11347          end if;
11348
11349       --  A qualified expression has inferable discriminants if its subtype
11350       --  mark is a constrained Unchecked_Union subtype.
11351
11352       elsif Nkind (N) = N_Qualified_Expression then
11353          return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
11354            and then Is_Constrained (Etype (Subtype_Mark (N)));
11355
11356       --  For all other names, it is sufficient to have a constrained
11357       --  Unchecked_Union nominal subtype.
11358
11359       else
11360          return Is_Unchecked_Union (Base_Type (Etype (N)))
11361            and then Is_Constrained (Etype (N));
11362       end if;
11363    end Has_Inferable_Discriminants;
11364
11365    -------------------------------
11366    -- Insert_Dereference_Action --
11367    -------------------------------
11368
11369    procedure Insert_Dereference_Action (N : Node_Id) is
11370
11371       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
11372       --  Return true if type of P is derived from Checked_Pool;
11373
11374       -----------------------------
11375       -- Is_Checked_Storage_Pool --
11376       -----------------------------
11377
11378       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
11379          T : Entity_Id;
11380       begin
11381          if No (P) then
11382             return False;
11383          end if;
11384
11385          T := Etype (P);
11386          while T /= Etype (T) loop
11387             if Is_RTE (T, RE_Checked_Pool) then
11388                return True;
11389             else
11390                T := Etype (T);
11391             end if;
11392          end loop;
11393
11394          return False;
11395       end Is_Checked_Storage_Pool;
11396
11397       --  Local variables
11398
11399       Typ   : constant Entity_Id  := Etype (N);
11400       Desig : constant Entity_Id  := Available_View (Designated_Type (Typ));
11401       Loc   : constant Source_Ptr := Sloc (N);
11402       Pool  : constant Entity_Id  := Associated_Storage_Pool (Typ);
11403       Pnod  : constant Node_Id    := Parent (N);
11404
11405       Addr  : Entity_Id;
11406       Alig  : Entity_Id;
11407       Deref : Node_Id;
11408       Size  : Entity_Id;
11409       Stmt  : Node_Id;
11410
11411    --  Start of processing for Insert_Dereference_Action
11412
11413    begin
11414       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
11415
11416       --  Do not re-expand a dereference which has already been processed by
11417       --  this routine.
11418
11419       if Has_Dereference_Action (Pnod) then
11420          return;
11421
11422       --  Do not perform this type of expansion for internally-generated
11423       --  dereferences.
11424
11425       elsif not Comes_From_Source (Original_Node (Pnod)) then
11426          return;
11427
11428       --  A dereference action is only applicable to objects which have been
11429       --  allocated on a checked pool.
11430
11431       elsif not Is_Checked_Storage_Pool (Pool) then
11432          return;
11433       end if;
11434
11435       --  Extract the address of the dereferenced object. Generate:
11436
11437       --    Addr : System.Address := <N>'Pool_Address;
11438
11439       Addr := Make_Temporary (Loc, 'P');
11440
11441       Insert_Action (N,
11442         Make_Object_Declaration (Loc,
11443           Defining_Identifier => Addr,
11444           Object_Definition   =>
11445             New_Reference_To (RTE (RE_Address), Loc),
11446           Expression          =>
11447             Make_Attribute_Reference (Loc,
11448               Prefix         => Duplicate_Subexpr_Move_Checks (N),
11449               Attribute_Name => Name_Pool_Address)));
11450
11451       --  Calculate the size of the dereferenced object. Generate:
11452
11453       --    Size : Storage_Count := <N>.all'Size / Storage_Unit;
11454
11455       Deref :=
11456         Make_Explicit_Dereference (Loc,
11457           Prefix => Duplicate_Subexpr_Move_Checks (N));
11458       Set_Has_Dereference_Action (Deref);
11459
11460       Size := Make_Temporary (Loc, 'S');
11461
11462       Insert_Action (N,
11463         Make_Object_Declaration (Loc,
11464           Defining_Identifier => Size,
11465
11466           Object_Definition   =>
11467             New_Reference_To (RTE (RE_Storage_Count), Loc),
11468
11469           Expression          =>
11470             Make_Op_Divide (Loc,
11471               Left_Opnd   =>
11472                 Make_Attribute_Reference (Loc,
11473                   Prefix         => Deref,
11474                   Attribute_Name => Name_Size),
11475                Right_Opnd =>
11476                  Make_Integer_Literal (Loc, System_Storage_Unit))));
11477
11478       --  Calculate the alignment of the dereferenced object. Generate:
11479       --    Alig : constant Storage_Count := <N>.all'Alignment;
11480
11481       Deref :=
11482         Make_Explicit_Dereference (Loc,
11483           Prefix => Duplicate_Subexpr_Move_Checks (N));
11484       Set_Has_Dereference_Action (Deref);
11485
11486       Alig := Make_Temporary (Loc, 'A');
11487
11488       Insert_Action (N,
11489         Make_Object_Declaration (Loc,
11490           Defining_Identifier => Alig,
11491           Object_Definition   =>
11492             New_Reference_To (RTE (RE_Storage_Count), Loc),
11493           Expression          =>
11494             Make_Attribute_Reference (Loc,
11495               Prefix         => Deref,
11496               Attribute_Name => Name_Alignment)));
11497
11498       --  A dereference of a controlled object requires special processing. The
11499       --  finalization machinery requests additional space from the underlying
11500       --  pool to allocate and hide two pointers. As a result, a checked pool
11501       --  may mark the wrong memory as valid. Since checked pools do not have
11502       --  knowledge of hidden pointers, we have to bring the two pointers back
11503       --  in view in order to restore the original state of the object.
11504
11505       if Needs_Finalization (Desig) then
11506
11507          --  Adjust the address and size of the dereferenced object. Generate:
11508          --    Adjust_Controlled_Dereference (Addr, Size, Alig);
11509
11510          Stmt :=
11511            Make_Procedure_Call_Statement (Loc,
11512              Name                   =>
11513                New_Reference_To (RTE (RE_Adjust_Controlled_Dereference), Loc),
11514              Parameter_Associations => New_List (
11515                New_Reference_To (Addr, Loc),
11516                New_Reference_To (Size, Loc),
11517                New_Reference_To (Alig, Loc)));
11518
11519          --  Class-wide types complicate things because we cannot determine
11520          --  statically whether the actual object is truly controlled. We must
11521          --  generate a runtime check to detect this property. Generate:
11522          --
11523          --    if Needs_Finalization (<N>.all'Tag) then
11524          --       <Stmt>;
11525          --    end if;
11526
11527          if Is_Class_Wide_Type (Desig) then
11528             Deref :=
11529               Make_Explicit_Dereference (Loc,
11530                 Prefix => Duplicate_Subexpr_Move_Checks (N));
11531             Set_Has_Dereference_Action (Deref);
11532
11533             Stmt :=
11534               Make_Implicit_If_Statement (N,
11535                 Condition       =>
11536                   Make_Function_Call (Loc,
11537                     Name                   =>
11538                       New_Reference_To (RTE (RE_Needs_Finalization), Loc),
11539                     Parameter_Associations => New_List (
11540                       Make_Attribute_Reference (Loc,
11541                         Prefix         => Deref,
11542                         Attribute_Name => Name_Tag))),
11543                 Then_Statements => New_List (Stmt));
11544          end if;
11545
11546          Insert_Action (N, Stmt);
11547       end if;
11548
11549       --  Generate:
11550       --    Dereference (Pool, Addr, Size, Alig);
11551
11552       Insert_Action (N,
11553         Make_Procedure_Call_Statement (Loc,
11554           Name                   =>
11555             New_Reference_To
11556               (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
11557           Parameter_Associations => New_List (
11558             New_Reference_To (Pool, Loc),
11559             New_Reference_To (Addr, Loc),
11560             New_Reference_To (Size, Loc),
11561             New_Reference_To (Alig, Loc))));
11562
11563       --  Mark the explicit dereference as processed to avoid potential
11564       --  infinite expansion.
11565
11566       Set_Has_Dereference_Action (Pnod);
11567
11568    exception
11569       when RE_Not_Available =>
11570          return;
11571    end Insert_Dereference_Action;
11572
11573    --------------------------------
11574    -- Integer_Promotion_Possible --
11575    --------------------------------
11576
11577    function Integer_Promotion_Possible (N : Node_Id) return Boolean is
11578       Operand           : constant Node_Id   := Expression (N);
11579       Operand_Type      : constant Entity_Id := Etype (Operand);
11580       Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
11581
11582    begin
11583       pragma Assert (Nkind (N) = N_Type_Conversion);
11584
11585       return
11586
11587            --  We only do the transformation for source constructs. We assume
11588            --  that the expander knows what it is doing when it generates code.
11589
11590            Comes_From_Source (N)
11591
11592            --  If the operand type is Short_Integer or Short_Short_Integer,
11593            --  then we will promote to Integer, which is available on all
11594            --  targets, and is sufficient to ensure no intermediate overflow.
11595            --  Furthermore it is likely to be as efficient or more efficient
11596            --  than using the smaller type for the computation so we do this
11597            --  unconditionally.
11598
11599            and then
11600              (Root_Operand_Type = Base_Type (Standard_Short_Integer)
11601                or else
11602               Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
11603
11604            --  Test for interesting operation, which includes addition,
11605            --  division, exponentiation, multiplication, subtraction, absolute
11606            --  value and unary negation. Unary "+" is omitted since it is a
11607            --  no-op and thus can't overflow.
11608
11609            and then Nkind_In (Operand, N_Op_Abs,
11610                                        N_Op_Add,
11611                                        N_Op_Divide,
11612                                        N_Op_Expon,
11613                                        N_Op_Minus,
11614                                        N_Op_Multiply,
11615                                        N_Op_Subtract);
11616    end Integer_Promotion_Possible;
11617
11618    ------------------------------
11619    -- Make_Array_Comparison_Op --
11620    ------------------------------
11621
11622    --  This is a hand-coded expansion of the following generic function:
11623
11624    --  generic
11625    --    type elem is  (<>);
11626    --    type index is (<>);
11627    --    type a is array (index range <>) of elem;
11628
11629    --  function Gnnn (X : a; Y: a) return boolean is
11630    --    J : index := Y'first;
11631
11632    --  begin
11633    --    if X'length = 0 then
11634    --       return false;
11635
11636    --    elsif Y'length = 0 then
11637    --       return true;
11638
11639    --    else
11640    --      for I in X'range loop
11641    --        if X (I) = Y (J) then
11642    --          if J = Y'last then
11643    --            exit;
11644    --          else
11645    --            J := index'succ (J);
11646    --          end if;
11647
11648    --        else
11649    --           return X (I) > Y (J);
11650    --        end if;
11651    --      end loop;
11652
11653    --      return X'length > Y'length;
11654    --    end if;
11655    --  end Gnnn;
11656
11657    --  Note that since we are essentially doing this expansion by hand, we
11658    --  do not need to generate an actual or formal generic part, just the
11659    --  instantiated function itself.
11660
11661    function Make_Array_Comparison_Op
11662      (Typ : Entity_Id;
11663       Nod : Node_Id) return Node_Id
11664    is
11665       Loc : constant Source_Ptr := Sloc (Nod);
11666
11667       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
11668       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
11669       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
11670       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
11671
11672       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
11673
11674       Loop_Statement : Node_Id;
11675       Loop_Body      : Node_Id;
11676       If_Stat        : Node_Id;
11677       Inner_If       : Node_Id;
11678       Final_Expr     : Node_Id;
11679       Func_Body      : Node_Id;
11680       Func_Name      : Entity_Id;
11681       Formals        : List_Id;
11682       Length1        : Node_Id;
11683       Length2        : Node_Id;
11684
11685    begin
11686       --  if J = Y'last then
11687       --     exit;
11688       --  else
11689       --     J := index'succ (J);
11690       --  end if;
11691
11692       Inner_If :=
11693         Make_Implicit_If_Statement (Nod,
11694           Condition =>
11695             Make_Op_Eq (Loc,
11696               Left_Opnd => New_Reference_To (J, Loc),
11697               Right_Opnd =>
11698                 Make_Attribute_Reference (Loc,
11699                   Prefix => New_Reference_To (Y, Loc),
11700                   Attribute_Name => Name_Last)),
11701
11702           Then_Statements => New_List (
11703                 Make_Exit_Statement (Loc)),
11704
11705           Else_Statements =>
11706             New_List (
11707               Make_Assignment_Statement (Loc,
11708                 Name => New_Reference_To (J, Loc),
11709                 Expression =>
11710                   Make_Attribute_Reference (Loc,
11711                     Prefix => New_Reference_To (Index, Loc),
11712                     Attribute_Name => Name_Succ,
11713                     Expressions => New_List (New_Reference_To (J, Loc))))));
11714
11715       --  if X (I) = Y (J) then
11716       --     if ... end if;
11717       --  else
11718       --     return X (I) > Y (J);
11719       --  end if;
11720
11721       Loop_Body :=
11722         Make_Implicit_If_Statement (Nod,
11723           Condition =>
11724             Make_Op_Eq (Loc,
11725               Left_Opnd =>
11726                 Make_Indexed_Component (Loc,
11727                   Prefix      => New_Reference_To (X, Loc),
11728                   Expressions => New_List (New_Reference_To (I, Loc))),
11729
11730               Right_Opnd =>
11731                 Make_Indexed_Component (Loc,
11732                   Prefix      => New_Reference_To (Y, Loc),
11733                   Expressions => New_List (New_Reference_To (J, Loc)))),
11734
11735           Then_Statements => New_List (Inner_If),
11736
11737           Else_Statements => New_List (
11738             Make_Simple_Return_Statement (Loc,
11739               Expression =>
11740                 Make_Op_Gt (Loc,
11741                   Left_Opnd =>
11742                     Make_Indexed_Component (Loc,
11743                       Prefix      => New_Reference_To (X, Loc),
11744                       Expressions => New_List (New_Reference_To (I, Loc))),
11745
11746                   Right_Opnd =>
11747                     Make_Indexed_Component (Loc,
11748                       Prefix      => New_Reference_To (Y, Loc),
11749                       Expressions => New_List (
11750                         New_Reference_To (J, Loc)))))));
11751
11752       --  for I in X'range loop
11753       --     if ... end if;
11754       --  end loop;
11755
11756       Loop_Statement :=
11757         Make_Implicit_Loop_Statement (Nod,
11758           Identifier => Empty,
11759
11760           Iteration_Scheme =>
11761             Make_Iteration_Scheme (Loc,
11762               Loop_Parameter_Specification =>
11763                 Make_Loop_Parameter_Specification (Loc,
11764                   Defining_Identifier => I,
11765                   Discrete_Subtype_Definition =>
11766                     Make_Attribute_Reference (Loc,
11767                       Prefix => New_Reference_To (X, Loc),
11768                       Attribute_Name => Name_Range))),
11769
11770           Statements => New_List (Loop_Body));
11771
11772       --    if X'length = 0 then
11773       --       return false;
11774       --    elsif Y'length = 0 then
11775       --       return true;
11776       --    else
11777       --      for ... loop ... end loop;
11778       --      return X'length > Y'length;
11779       --    end if;
11780
11781       Length1 :=
11782         Make_Attribute_Reference (Loc,
11783           Prefix => New_Reference_To (X, Loc),
11784           Attribute_Name => Name_Length);
11785
11786       Length2 :=
11787         Make_Attribute_Reference (Loc,
11788           Prefix => New_Reference_To (Y, Loc),
11789           Attribute_Name => Name_Length);
11790
11791       Final_Expr :=
11792         Make_Op_Gt (Loc,
11793           Left_Opnd  => Length1,
11794           Right_Opnd => Length2);
11795
11796       If_Stat :=
11797         Make_Implicit_If_Statement (Nod,
11798           Condition =>
11799             Make_Op_Eq (Loc,
11800               Left_Opnd =>
11801                 Make_Attribute_Reference (Loc,
11802                   Prefix => New_Reference_To (X, Loc),
11803                   Attribute_Name => Name_Length),
11804               Right_Opnd =>
11805                 Make_Integer_Literal (Loc, 0)),
11806
11807           Then_Statements =>
11808             New_List (
11809               Make_Simple_Return_Statement (Loc,
11810                 Expression => New_Reference_To (Standard_False, Loc))),
11811
11812           Elsif_Parts => New_List (
11813             Make_Elsif_Part (Loc,
11814               Condition =>
11815                 Make_Op_Eq (Loc,
11816                   Left_Opnd =>
11817                     Make_Attribute_Reference (Loc,
11818                       Prefix => New_Reference_To (Y, Loc),
11819                       Attribute_Name => Name_Length),
11820                   Right_Opnd =>
11821                     Make_Integer_Literal (Loc, 0)),
11822
11823               Then_Statements =>
11824                 New_List (
11825                   Make_Simple_Return_Statement (Loc,
11826                      Expression => New_Reference_To (Standard_True, Loc))))),
11827
11828           Else_Statements => New_List (
11829             Loop_Statement,
11830             Make_Simple_Return_Statement (Loc,
11831               Expression => Final_Expr)));
11832
11833       --  (X : a; Y: a)
11834
11835       Formals := New_List (
11836         Make_Parameter_Specification (Loc,
11837           Defining_Identifier => X,
11838           Parameter_Type      => New_Reference_To (Typ, Loc)),
11839
11840         Make_Parameter_Specification (Loc,
11841           Defining_Identifier => Y,
11842           Parameter_Type      => New_Reference_To (Typ, Loc)));
11843
11844       --  function Gnnn (...) return boolean is
11845       --    J : index := Y'first;
11846       --  begin
11847       --    if ... end if;
11848       --  end Gnnn;
11849
11850       Func_Name := Make_Temporary (Loc, 'G');
11851
11852       Func_Body :=
11853         Make_Subprogram_Body (Loc,
11854           Specification =>
11855             Make_Function_Specification (Loc,
11856               Defining_Unit_Name       => Func_Name,
11857               Parameter_Specifications => Formals,
11858               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
11859
11860           Declarations => New_List (
11861             Make_Object_Declaration (Loc,
11862               Defining_Identifier => J,
11863               Object_Definition   => New_Reference_To (Index, Loc),
11864               Expression =>
11865                 Make_Attribute_Reference (Loc,
11866                   Prefix => New_Reference_To (Y, Loc),
11867                   Attribute_Name => Name_First))),
11868
11869           Handled_Statement_Sequence =>
11870             Make_Handled_Sequence_Of_Statements (Loc,
11871               Statements => New_List (If_Stat)));
11872
11873       return Func_Body;
11874    end Make_Array_Comparison_Op;
11875
11876    ---------------------------
11877    -- Make_Boolean_Array_Op --
11878    ---------------------------
11879
11880    --  For logical operations on boolean arrays, expand in line the following,
11881    --  replacing 'and' with 'or' or 'xor' where needed:
11882
11883    --    function Annn (A : typ; B: typ) return typ is
11884    --       C : typ;
11885    --    begin
11886    --       for J in A'range loop
11887    --          C (J) := A (J) op B (J);
11888    --       end loop;
11889    --       return C;
11890    --    end Annn;
11891
11892    --  Here typ is the boolean array type
11893
11894    function Make_Boolean_Array_Op
11895      (Typ : Entity_Id;
11896       N   : Node_Id) return Node_Id
11897    is
11898       Loc : constant Source_Ptr := Sloc (N);
11899
11900       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
11901       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
11902       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
11903       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
11904
11905       A_J : Node_Id;
11906       B_J : Node_Id;
11907       C_J : Node_Id;
11908       Op  : Node_Id;
11909
11910       Formals        : List_Id;
11911       Func_Name      : Entity_Id;
11912       Func_Body      : Node_Id;
11913       Loop_Statement : Node_Id;
11914
11915    begin
11916       A_J :=
11917         Make_Indexed_Component (Loc,
11918           Prefix      => New_Reference_To (A, Loc),
11919           Expressions => New_List (New_Reference_To (J, Loc)));
11920
11921       B_J :=
11922         Make_Indexed_Component (Loc,
11923           Prefix      => New_Reference_To (B, Loc),
11924           Expressions => New_List (New_Reference_To (J, Loc)));
11925
11926       C_J :=
11927         Make_Indexed_Component (Loc,
11928           Prefix      => New_Reference_To (C, Loc),
11929           Expressions => New_List (New_Reference_To (J, Loc)));
11930
11931       if Nkind (N) = N_Op_And then
11932          Op :=
11933            Make_Op_And (Loc,
11934              Left_Opnd  => A_J,
11935              Right_Opnd => B_J);
11936
11937       elsif Nkind (N) = N_Op_Or then
11938          Op :=
11939            Make_Op_Or (Loc,
11940              Left_Opnd  => A_J,
11941              Right_Opnd => B_J);
11942
11943       else
11944          Op :=
11945            Make_Op_Xor (Loc,
11946              Left_Opnd  => A_J,
11947              Right_Opnd => B_J);
11948       end if;
11949
11950       Loop_Statement :=
11951         Make_Implicit_Loop_Statement (N,
11952           Identifier => Empty,
11953
11954           Iteration_Scheme =>
11955             Make_Iteration_Scheme (Loc,
11956               Loop_Parameter_Specification =>
11957                 Make_Loop_Parameter_Specification (Loc,
11958                   Defining_Identifier => J,
11959                   Discrete_Subtype_Definition =>
11960                     Make_Attribute_Reference (Loc,
11961                       Prefix => New_Reference_To (A, Loc),
11962                       Attribute_Name => Name_Range))),
11963
11964           Statements => New_List (
11965             Make_Assignment_Statement (Loc,
11966               Name       => C_J,
11967               Expression => Op)));
11968
11969       Formals := New_List (
11970         Make_Parameter_Specification (Loc,
11971           Defining_Identifier => A,
11972           Parameter_Type      => New_Reference_To (Typ, Loc)),
11973
11974         Make_Parameter_Specification (Loc,
11975           Defining_Identifier => B,
11976           Parameter_Type      => New_Reference_To (Typ, Loc)));
11977
11978       Func_Name := Make_Temporary (Loc, 'A');
11979       Set_Is_Inlined (Func_Name);
11980
11981       Func_Body :=
11982         Make_Subprogram_Body (Loc,
11983           Specification =>
11984             Make_Function_Specification (Loc,
11985               Defining_Unit_Name       => Func_Name,
11986               Parameter_Specifications => Formals,
11987               Result_Definition        => New_Reference_To (Typ, Loc)),
11988
11989           Declarations => New_List (
11990             Make_Object_Declaration (Loc,
11991               Defining_Identifier => C,
11992               Object_Definition   => New_Reference_To (Typ, Loc))),
11993
11994           Handled_Statement_Sequence =>
11995             Make_Handled_Sequence_Of_Statements (Loc,
11996               Statements => New_List (
11997                 Loop_Statement,
11998                 Make_Simple_Return_Statement (Loc,
11999                   Expression => New_Reference_To (C, Loc)))));
12000
12001       return Func_Body;
12002    end Make_Boolean_Array_Op;
12003
12004    -----------------------------------------
12005    -- Minimized_Eliminated_Overflow_Check --
12006    -----------------------------------------
12007
12008    function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
12009    begin
12010       return
12011         Is_Signed_Integer_Type (Etype (N))
12012           and then Overflow_Check_Mode in Minimized_Or_Eliminated;
12013    end Minimized_Eliminated_Overflow_Check;
12014
12015    --------------------------------
12016    -- Optimize_Length_Comparison --
12017    --------------------------------
12018
12019    procedure Optimize_Length_Comparison (N : Node_Id) is
12020       Loc    : constant Source_Ptr := Sloc (N);
12021       Typ    : constant Entity_Id  := Etype (N);
12022       Result : Node_Id;
12023
12024       Left  : Node_Id;
12025       Right : Node_Id;
12026       --  First and Last attribute reference nodes, which end up as left and
12027       --  right operands of the optimized result.
12028
12029       Is_Zero : Boolean;
12030       --  True for comparison operand of zero
12031
12032       Comp : Node_Id;
12033       --  Comparison operand, set only if Is_Zero is false
12034
12035       Ent : Entity_Id;
12036       --  Entity whose length is being compared
12037
12038       Index : Node_Id;
12039       --  Integer_Literal node for length attribute expression, or Empty
12040       --  if there is no such expression present.
12041
12042       Ityp  : Entity_Id;
12043       --  Type of array index to which 'Length is applied
12044
12045       Op : Node_Kind := Nkind (N);
12046       --  Kind of comparison operator, gets flipped if operands backwards
12047
12048       function Is_Optimizable (N : Node_Id) return Boolean;
12049       --  Tests N to see if it is an optimizable comparison value (defined as
12050       --  constant zero or one, or something else where the value is known to
12051       --  be positive and in the range of 32-bits, and where the corresponding
12052       --  Length value is also known to be 32-bits. If result is true, sets
12053       --  Is_Zero, Ityp, and Comp accordingly.
12054
12055       function Is_Entity_Length (N : Node_Id) return Boolean;
12056       --  Tests if N is a length attribute applied to a simple entity. If so,
12057       --  returns True, and sets Ent to the entity, and Index to the integer
12058       --  literal provided as an attribute expression, or to Empty if none.
12059       --  Also returns True if the expression is a generated type conversion
12060       --  whose expression is of the desired form. This latter case arises
12061       --  when Apply_Universal_Integer_Attribute_Check installs a conversion
12062       --  to check for being in range, which is not needed in this context.
12063       --  Returns False if neither condition holds.
12064
12065       function Prepare_64 (N : Node_Id) return Node_Id;
12066       --  Given a discrete expression, returns a Long_Long_Integer typed
12067       --  expression representing the underlying value of the expression.
12068       --  This is done with an unchecked conversion to the result type. We
12069       --  use unchecked conversion to handle the enumeration type case.
12070
12071       ----------------------
12072       -- Is_Entity_Length --
12073       ----------------------
12074
12075       function Is_Entity_Length (N : Node_Id) return Boolean is
12076       begin
12077          if Nkind (N) = N_Attribute_Reference
12078            and then Attribute_Name (N) = Name_Length
12079            and then Is_Entity_Name (Prefix (N))
12080          then
12081             Ent := Entity (Prefix (N));
12082
12083             if Present (Expressions (N)) then
12084                Index := First (Expressions (N));
12085             else
12086                Index := Empty;
12087             end if;
12088
12089             return True;
12090
12091          elsif Nkind (N) = N_Type_Conversion
12092            and then not Comes_From_Source (N)
12093          then
12094             return Is_Entity_Length (Expression (N));
12095
12096          else
12097             return False;
12098          end if;
12099       end Is_Entity_Length;
12100
12101       --------------------
12102       -- Is_Optimizable --
12103       --------------------
12104
12105       function Is_Optimizable (N : Node_Id) return Boolean is
12106          Val  : Uint;
12107          OK   : Boolean;
12108          Lo   : Uint;
12109          Hi   : Uint;
12110          Indx : Node_Id;
12111
12112       begin
12113          if Compile_Time_Known_Value (N) then
12114             Val := Expr_Value (N);
12115
12116             if Val = Uint_0 then
12117                Is_Zero := True;
12118                Comp    := Empty;
12119                return True;
12120
12121             elsif Val = Uint_1 then
12122                Is_Zero := False;
12123                Comp    := Empty;
12124                return True;
12125             end if;
12126          end if;
12127
12128          --  Here we have to make sure of being within 32-bits
12129
12130          Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
12131
12132          if not OK
12133            or else Lo < Uint_1
12134            or else Hi > UI_From_Int (Int'Last)
12135          then
12136             return False;
12137          end if;
12138
12139          --  Comparison value was within range, so now we must check the index
12140          --  value to make sure it is also within 32-bits.
12141
12142          Indx := First_Index (Etype (Ent));
12143
12144          if Present (Index) then
12145             for J in 2 .. UI_To_Int (Intval (Index)) loop
12146                Next_Index (Indx);
12147             end loop;
12148          end if;
12149
12150          Ityp := Etype (Indx);
12151
12152          if Esize (Ityp) > 32 then
12153             return False;
12154          end if;
12155
12156          Is_Zero := False;
12157          Comp := N;
12158          return True;
12159       end Is_Optimizable;
12160
12161       ----------------
12162       -- Prepare_64 --
12163       ----------------
12164
12165       function Prepare_64 (N : Node_Id) return Node_Id is
12166       begin
12167          return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
12168       end Prepare_64;
12169
12170    --  Start of processing for Optimize_Length_Comparison
12171
12172    begin
12173       --  Nothing to do if not a comparison
12174
12175       if Op not in N_Op_Compare then
12176          return;
12177       end if;
12178
12179       --  Nothing to do if special -gnatd.P debug flag set
12180
12181       if Debug_Flag_Dot_PP then
12182          return;
12183       end if;
12184
12185       --  Ent'Length op 0/1
12186
12187       if Is_Entity_Length (Left_Opnd (N))
12188         and then Is_Optimizable (Right_Opnd (N))
12189       then
12190          null;
12191
12192       --  0/1 op Ent'Length
12193
12194       elsif Is_Entity_Length (Right_Opnd (N))
12195         and then Is_Optimizable (Left_Opnd (N))
12196       then
12197          --  Flip comparison to opposite sense
12198
12199          case Op is
12200             when N_Op_Lt => Op := N_Op_Gt;
12201             when N_Op_Le => Op := N_Op_Ge;
12202             when N_Op_Gt => Op := N_Op_Lt;
12203             when N_Op_Ge => Op := N_Op_Le;
12204             when others  => null;
12205          end case;
12206
12207       --  Else optimization not possible
12208
12209       else
12210          return;
12211       end if;
12212
12213       --  Fall through if we will do the optimization
12214
12215       --  Cases to handle:
12216
12217       --    X'Length = 0  => X'First > X'Last
12218       --    X'Length = 1  => X'First = X'Last
12219       --    X'Length = n  => X'First + (n - 1) = X'Last
12220
12221       --    X'Length /= 0 => X'First <= X'Last
12222       --    X'Length /= 1 => X'First /= X'Last
12223       --    X'Length /= n => X'First + (n - 1) /= X'Last
12224
12225       --    X'Length >= 0 => always true, warn
12226       --    X'Length >= 1 => X'First <= X'Last
12227       --    X'Length >= n => X'First + (n - 1) <= X'Last
12228
12229       --    X'Length > 0  => X'First <= X'Last
12230       --    X'Length > 1  => X'First < X'Last
12231       --    X'Length > n  => X'First + (n - 1) < X'Last
12232
12233       --    X'Length <= 0 => X'First > X'Last (warn, could be =)
12234       --    X'Length <= 1 => X'First >= X'Last
12235       --    X'Length <= n => X'First + (n - 1) >= X'Last
12236
12237       --    X'Length < 0  => always false (warn)
12238       --    X'Length < 1  => X'First > X'Last
12239       --    X'Length < n  => X'First + (n - 1) > X'Last
12240
12241       --  Note: for the cases of n (not constant 0,1), we require that the
12242       --  corresponding index type be integer or shorter (i.e. not 64-bit),
12243       --  and the same for the comparison value. Then we do the comparison
12244       --  using 64-bit arithmetic (actually long long integer), so that we
12245       --  cannot have overflow intefering with the result.
12246
12247       --  First deal with warning cases
12248
12249       if Is_Zero then
12250          case Op is
12251
12252             --  X'Length >= 0
12253
12254             when N_Op_Ge =>
12255                Rewrite (N,
12256                  Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
12257                Analyze_And_Resolve (N, Typ);
12258                Warn_On_Known_Condition (N);
12259                return;
12260
12261             --  X'Length < 0
12262
12263             when N_Op_Lt =>
12264                Rewrite (N,
12265                  Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
12266                Analyze_And_Resolve (N, Typ);
12267                Warn_On_Known_Condition (N);
12268                return;
12269
12270             when N_Op_Le =>
12271                if Constant_Condition_Warnings
12272                  and then Comes_From_Source (Original_Node (N))
12273                then
12274                   Error_Msg_N ("could replace by ""'=""?c?", N);
12275                end if;
12276
12277                Op := N_Op_Eq;
12278
12279             when others =>
12280                null;
12281          end case;
12282       end if;
12283
12284       --  Build the First reference we will use
12285
12286       Left :=
12287         Make_Attribute_Reference (Loc,
12288           Prefix         => New_Occurrence_Of (Ent, Loc),
12289           Attribute_Name => Name_First);
12290
12291       if Present (Index) then
12292          Set_Expressions (Left, New_List (New_Copy (Index)));
12293       end if;
12294
12295       --  If general value case, then do the addition of (n - 1), and
12296       --  also add the needed conversions to type Long_Long_Integer.
12297
12298       if Present (Comp) then
12299          Left :=
12300            Make_Op_Add (Loc,
12301              Left_Opnd  => Prepare_64 (Left),
12302              Right_Opnd =>
12303                Make_Op_Subtract (Loc,
12304                  Left_Opnd  => Prepare_64 (Comp),
12305                  Right_Opnd => Make_Integer_Literal (Loc, 1)));
12306       end if;
12307
12308       --  Build the Last reference we will use
12309
12310       Right :=
12311         Make_Attribute_Reference (Loc,
12312           Prefix         => New_Occurrence_Of (Ent, Loc),
12313           Attribute_Name => Name_Last);
12314
12315       if Present (Index) then
12316          Set_Expressions (Right, New_List (New_Copy (Index)));
12317       end if;
12318
12319       --  If general operand, convert Last reference to Long_Long_Integer
12320
12321       if Present (Comp) then
12322          Right := Prepare_64 (Right);
12323       end if;
12324
12325       --  Check for cases to optimize
12326
12327       --  X'Length = 0  => X'First > X'Last
12328       --  X'Length < 1  => X'First > X'Last
12329       --  X'Length < n  => X'First + (n - 1) > X'Last
12330
12331       if (Is_Zero and then Op = N_Op_Eq)
12332         or else (not Is_Zero and then Op = N_Op_Lt)
12333       then
12334          Result :=
12335            Make_Op_Gt (Loc,
12336              Left_Opnd  => Left,
12337              Right_Opnd => Right);
12338
12339       --  X'Length = 1  => X'First = X'Last
12340       --  X'Length = n  => X'First + (n - 1) = X'Last
12341
12342       elsif not Is_Zero and then Op = N_Op_Eq then
12343          Result :=
12344            Make_Op_Eq (Loc,
12345              Left_Opnd  => Left,
12346              Right_Opnd => Right);
12347
12348       --  X'Length /= 0 => X'First <= X'Last
12349       --  X'Length > 0  => X'First <= X'Last
12350
12351       elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
12352          Result :=
12353            Make_Op_Le (Loc,
12354              Left_Opnd  => Left,
12355              Right_Opnd => Right);
12356
12357       --  X'Length /= 1 => X'First /= X'Last
12358       --  X'Length /= n => X'First + (n - 1) /= X'Last
12359
12360       elsif not Is_Zero and then Op = N_Op_Ne then
12361          Result :=
12362            Make_Op_Ne (Loc,
12363              Left_Opnd  => Left,
12364              Right_Opnd => Right);
12365
12366       --  X'Length >= 1 => X'First <= X'Last
12367       --  X'Length >= n => X'First + (n - 1) <= X'Last
12368
12369       elsif not Is_Zero and then Op = N_Op_Ge then
12370          Result :=
12371            Make_Op_Le (Loc,
12372              Left_Opnd  => Left,
12373                        Right_Opnd => Right);
12374
12375       --  X'Length > 1  => X'First < X'Last
12376       --  X'Length > n  => X'First + (n = 1) < X'Last
12377
12378       elsif not Is_Zero and then Op = N_Op_Gt then
12379          Result :=
12380            Make_Op_Lt (Loc,
12381              Left_Opnd  => Left,
12382              Right_Opnd => Right);
12383
12384       --  X'Length <= 1 => X'First >= X'Last
12385       --  X'Length <= n => X'First + (n - 1) >= X'Last
12386
12387       elsif not Is_Zero and then Op = N_Op_Le then
12388          Result :=
12389            Make_Op_Ge (Loc,
12390              Left_Opnd  => Left,
12391              Right_Opnd => Right);
12392
12393       --  Should not happen at this stage
12394
12395       else
12396          raise Program_Error;
12397       end if;
12398
12399       --  Rewrite and finish up
12400
12401       Rewrite (N, Result);
12402       Analyze_And_Resolve (N, Typ);
12403       return;
12404    end Optimize_Length_Comparison;
12405
12406    ------------------------
12407    -- Rewrite_Comparison --
12408    ------------------------
12409
12410    procedure Rewrite_Comparison (N : Node_Id) is
12411       Warning_Generated : Boolean := False;
12412       --  Set to True if first pass with Assume_Valid generates a warning in
12413       --  which case we skip the second pass to avoid warning overloaded.
12414
12415       Result : Node_Id;
12416       --  Set to Standard_True or Standard_False
12417
12418    begin
12419       if Nkind (N) = N_Type_Conversion then
12420          Rewrite_Comparison (Expression (N));
12421          return;
12422
12423       elsif Nkind (N) not in N_Op_Compare then
12424          return;
12425       end if;
12426
12427       --  Now start looking at the comparison in detail. We potentially go
12428       --  through this loop twice. The first time, Assume_Valid is set False
12429       --  in the call to Compile_Time_Compare. If this call results in a
12430       --  clear result of always True or Always False, that's decisive and
12431       --  we are done. Otherwise we repeat the processing with Assume_Valid
12432       --  set to True to generate additional warnings. We can skip that step
12433       --  if Constant_Condition_Warnings is False.
12434
12435       for AV in False .. True loop
12436          declare
12437             Typ : constant Entity_Id := Etype (N);
12438             Op1 : constant Node_Id   := Left_Opnd (N);
12439             Op2 : constant Node_Id   := Right_Opnd (N);
12440
12441             Res : constant Compare_Result :=
12442                     Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
12443             --  Res indicates if compare outcome can be compile time determined
12444
12445             True_Result  : Boolean;
12446             False_Result : Boolean;
12447
12448          begin
12449             case N_Op_Compare (Nkind (N)) is
12450             when N_Op_Eq =>
12451                True_Result  := Res = EQ;
12452                False_Result := Res = LT or else Res = GT or else Res = NE;
12453
12454             when N_Op_Ge =>
12455                True_Result  := Res in Compare_GE;
12456                False_Result := Res = LT;
12457
12458                if Res = LE
12459                  and then Constant_Condition_Warnings
12460                  and then Comes_From_Source (Original_Node (N))
12461                  and then Nkind (Original_Node (N)) = N_Op_Ge
12462                  and then not In_Instance
12463                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
12464                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
12465                then
12466                   Error_Msg_N
12467                     ("can never be greater than, could replace by ""'=""?c?",
12468                      N);
12469                   Warning_Generated := True;
12470                end if;
12471
12472             when N_Op_Gt =>
12473                True_Result  := Res = GT;
12474                False_Result := Res in Compare_LE;
12475
12476             when N_Op_Lt =>
12477                True_Result  := Res = LT;
12478                False_Result := Res in Compare_GE;
12479
12480             when N_Op_Le =>
12481                True_Result  := Res in Compare_LE;
12482                False_Result := Res = GT;
12483
12484                if Res = GE
12485                  and then Constant_Condition_Warnings
12486                  and then Comes_From_Source (Original_Node (N))
12487                  and then Nkind (Original_Node (N)) = N_Op_Le
12488                  and then not In_Instance
12489                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
12490                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
12491                then
12492                   Error_Msg_N
12493                     ("can never be less than, could replace by ""'=""?c?", N);
12494                   Warning_Generated := True;
12495                end if;
12496
12497             when N_Op_Ne =>
12498                True_Result  := Res = NE or else Res = GT or else Res = LT;
12499                False_Result := Res = EQ;
12500             end case;
12501
12502             --  If this is the first iteration, then we actually convert the
12503             --  comparison into True or False, if the result is certain.
12504
12505             if AV = False then
12506                if True_Result or False_Result then
12507                   Result := Boolean_Literals (True_Result);
12508                   Rewrite (N,
12509                     Convert_To (Typ,
12510                       New_Occurrence_Of (Result, Sloc (N))));
12511                   Analyze_And_Resolve (N, Typ);
12512                   Warn_On_Known_Condition (N);
12513                   return;
12514                end if;
12515
12516             --  If this is the second iteration (AV = True), and the original
12517             --  node comes from source and we are not in an instance, then give
12518             --  a warning if we know result would be True or False. Note: we
12519             --  know Constant_Condition_Warnings is set if we get here.
12520
12521             elsif Comes_From_Source (Original_Node (N))
12522               and then not In_Instance
12523             then
12524                if True_Result then
12525                   Error_Msg_N
12526                     ("condition can only be False if invalid values present??",
12527                      N);
12528                elsif False_Result then
12529                   Error_Msg_N
12530                     ("condition can only be True if invalid values present??",
12531                      N);
12532                end if;
12533             end if;
12534          end;
12535
12536          --  Skip second iteration if not warning on constant conditions or
12537          --  if the first iteration already generated a warning of some kind or
12538          --  if we are in any case assuming all values are valid (so that the
12539          --  first iteration took care of the valid case).
12540
12541          exit when not Constant_Condition_Warnings;
12542          exit when Warning_Generated;
12543          exit when Assume_No_Invalid_Values;
12544       end loop;
12545    end Rewrite_Comparison;
12546
12547    ----------------------------
12548    -- Safe_In_Place_Array_Op --
12549    ----------------------------
12550
12551    function Safe_In_Place_Array_Op
12552      (Lhs : Node_Id;
12553       Op1 : Node_Id;
12554       Op2 : Node_Id) return Boolean
12555    is
12556       Target : Entity_Id;
12557
12558       function Is_Safe_Operand (Op : Node_Id) return Boolean;
12559       --  Operand is safe if it cannot overlap part of the target of the
12560       --  operation. If the operand and the target are identical, the operand
12561       --  is safe. The operand can be empty in the case of negation.
12562
12563       function Is_Unaliased (N : Node_Id) return Boolean;
12564       --  Check that N is a stand-alone entity
12565
12566       ------------------
12567       -- Is_Unaliased --
12568       ------------------
12569
12570       function Is_Unaliased (N : Node_Id) return Boolean is
12571       begin
12572          return
12573            Is_Entity_Name (N)
12574              and then No (Address_Clause (Entity (N)))
12575              and then No (Renamed_Object (Entity (N)));
12576       end Is_Unaliased;
12577
12578       ---------------------
12579       -- Is_Safe_Operand --
12580       ---------------------
12581
12582       function Is_Safe_Operand (Op : Node_Id) return Boolean is
12583       begin
12584          if No (Op) then
12585             return True;
12586
12587          elsif Is_Entity_Name (Op) then
12588             return Is_Unaliased (Op);
12589
12590          elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
12591             return Is_Unaliased (Prefix (Op));
12592
12593          elsif Nkind (Op) = N_Slice then
12594             return
12595               Is_Unaliased (Prefix (Op))
12596                 and then Entity (Prefix (Op)) /= Target;
12597
12598          elsif Nkind (Op) = N_Op_Not then
12599             return Is_Safe_Operand (Right_Opnd (Op));
12600
12601          else
12602             return False;
12603          end if;
12604       end Is_Safe_Operand;
12605
12606    --  Start of processing for Safe_In_Place_Array_Op
12607
12608    begin
12609       --  Skip this processing if the component size is different from system
12610       --  storage unit (since at least for NOT this would cause problems).
12611
12612       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
12613          return False;
12614
12615       --  Cannot do in place stuff on VM_Target since cannot pass addresses
12616
12617       elsif VM_Target /= No_VM then
12618          return False;
12619
12620       --  Cannot do in place stuff if non-standard Boolean representation
12621
12622       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
12623          return False;
12624
12625       elsif not Is_Unaliased (Lhs) then
12626          return False;
12627
12628       else
12629          Target := Entity (Lhs);
12630          return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
12631       end if;
12632    end Safe_In_Place_Array_Op;
12633
12634    -----------------------
12635    -- Tagged_Membership --
12636    -----------------------
12637
12638    --  There are two different cases to consider depending on whether the right
12639    --  operand is a class-wide type or not. If not we just compare the actual
12640    --  tag of the left expr to the target type tag:
12641    --
12642    --     Left_Expr.Tag = Right_Type'Tag;
12643    --
12644    --  If it is a class-wide type we use the RT function CW_Membership which is
12645    --  usually implemented by looking in the ancestor tables contained in the
12646    --  dispatch table pointed by Left_Expr.Tag for Typ'Tag
12647
12648    --  Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
12649    --  function IW_Membership which is usually implemented by looking in the
12650    --  table of abstract interface types plus the ancestor table contained in
12651    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
12652
12653    procedure Tagged_Membership
12654      (N         : Node_Id;
12655       SCIL_Node : out Node_Id;
12656       Result    : out Node_Id)
12657    is
12658       Left  : constant Node_Id    := Left_Opnd  (N);
12659       Right : constant Node_Id    := Right_Opnd (N);
12660       Loc   : constant Source_Ptr := Sloc (N);
12661
12662       Full_R_Typ : Entity_Id;
12663       Left_Type  : Entity_Id;
12664       New_Node   : Node_Id;
12665       Right_Type : Entity_Id;
12666       Obj_Tag    : Node_Id;
12667
12668    begin
12669       SCIL_Node := Empty;
12670
12671       --  Handle entities from the limited view
12672
12673       Left_Type  := Available_View (Etype (Left));
12674       Right_Type := Available_View (Etype (Right));
12675
12676       --  In the case where the type is an access type, the test is applied
12677       --  using the designated types (needed in Ada 2012 for implicit anonymous
12678       --  access conversions, for AI05-0149).
12679
12680       if Is_Access_Type (Right_Type) then
12681          Left_Type  := Designated_Type (Left_Type);
12682          Right_Type := Designated_Type (Right_Type);
12683       end if;
12684
12685       if Is_Class_Wide_Type (Left_Type) then
12686          Left_Type := Root_Type (Left_Type);
12687       end if;
12688
12689       if Is_Class_Wide_Type (Right_Type) then
12690          Full_R_Typ := Underlying_Type (Root_Type (Right_Type));
12691       else
12692          Full_R_Typ := Underlying_Type (Right_Type);
12693       end if;
12694
12695       Obj_Tag :=
12696         Make_Selected_Component (Loc,
12697           Prefix        => Relocate_Node (Left),
12698           Selector_Name =>
12699             New_Reference_To (First_Tag_Component (Left_Type), Loc));
12700
12701       if Is_Class_Wide_Type (Right_Type) then
12702
12703          --  No need to issue a run-time check if we statically know that the
12704          --  result of this membership test is always true. For example,
12705          --  considering the following declarations:
12706
12707          --    type Iface is interface;
12708          --    type T     is tagged null record;
12709          --    type DT    is new T and Iface with null record;
12710
12711          --    Obj1 : T;
12712          --    Obj2 : DT;
12713
12714          --  These membership tests are always true:
12715
12716          --    Obj1 in T'Class
12717          --    Obj2 in T'Class;
12718          --    Obj2 in Iface'Class;
12719
12720          --  We do not need to handle cases where the membership is illegal.
12721          --  For example:
12722
12723          --    Obj1 in DT'Class;     --  Compile time error
12724          --    Obj1 in Iface'Class;  --  Compile time error
12725
12726          if not Is_Class_Wide_Type (Left_Type)
12727            and then (Is_Ancestor (Etype (Right_Type), Left_Type,
12728                                   Use_Full_View => True)
12729                       or else (Is_Interface (Etype (Right_Type))
12730                                 and then Interface_Present_In_Ancestor
12731                                           (Typ   => Left_Type,
12732                                            Iface => Etype (Right_Type))))
12733          then
12734             Result := New_Reference_To (Standard_True, Loc);
12735             return;
12736          end if;
12737
12738          --  Ada 2005 (AI-251): Class-wide applied to interfaces
12739
12740          if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
12741
12742             --   Support to: "Iface_CW_Typ in Typ'Class"
12743
12744            or else Is_Interface (Left_Type)
12745          then
12746             --  Issue error if IW_Membership operation not available in a
12747             --  configurable run time setting.
12748
12749             if not RTE_Available (RE_IW_Membership) then
12750                Error_Msg_CRT
12751                  ("dynamic membership test on interface types", N);
12752                Result := Empty;
12753                return;
12754             end if;
12755
12756             Result :=
12757               Make_Function_Call (Loc,
12758                  Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
12759                  Parameter_Associations => New_List (
12760                    Make_Attribute_Reference (Loc,
12761                      Prefix => Obj_Tag,
12762                      Attribute_Name => Name_Address),
12763                    New_Reference_To (
12764                      Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),
12765                      Loc)));
12766
12767          --  Ada 95: Normal case
12768
12769          else
12770             Build_CW_Membership (Loc,
12771               Obj_Tag_Node => Obj_Tag,
12772               Typ_Tag_Node =>
12773                  New_Reference_To (
12774                    Node (First_Elmt (Access_Disp_Table (Full_R_Typ))),  Loc),
12775               Related_Nod => N,
12776               New_Node    => New_Node);
12777
12778             --  Generate the SCIL node for this class-wide membership test.
12779             --  Done here because the previous call to Build_CW_Membership
12780             --  relocates Obj_Tag.
12781
12782             if Generate_SCIL then
12783                SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
12784                Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
12785                Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
12786             end if;
12787
12788             Result := New_Node;
12789          end if;
12790
12791       --  Right_Type is not a class-wide type
12792
12793       else
12794          --  No need to check the tag of the object if Right_Typ is abstract
12795
12796          if Is_Abstract_Type (Right_Type) then
12797             Result := New_Reference_To (Standard_False, Loc);
12798
12799          else
12800             Result :=
12801               Make_Op_Eq (Loc,
12802                 Left_Opnd  => Obj_Tag,
12803                 Right_Opnd =>
12804                   New_Reference_To
12805                     (Node (First_Elmt (Access_Disp_Table (Full_R_Typ))), Loc));
12806          end if;
12807       end if;
12808    end Tagged_Membership;
12809
12810    ------------------------------
12811    -- Unary_Op_Validity_Checks --
12812    ------------------------------
12813
12814    procedure Unary_Op_Validity_Checks (N : Node_Id) is
12815    begin
12816       if Validity_Checks_On and Validity_Check_Operands then
12817          Ensure_Valid (Right_Opnd (N));
12818       end if;
12819    end Unary_Op_Validity_Checks;
12820
12821 end Exp_Ch4;