gcc/ada/exp_ch4.adb

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