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