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