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