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