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-2004, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  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_Ch3;  use Exp_Ch3;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Exp_Ch9;  use Exp_Ch9;
  36 with Exp_Disp; use Exp_Disp;
  37 with Exp_Fixd; use Exp_Fixd;
  38 with Exp_Pakd; use Exp_Pakd;
  39 with Exp_Tss;  use Exp_Tss;
  40 with Exp_Util; use Exp_Util;
  41 with Exp_VFpt; use Exp_VFpt;
  42 with Hostparm; use Hostparm;
  43 with Inline;   use Inline;
  44 with Nlists;   use Nlists;
  45 with Nmake;    use Nmake;
  46 with Opt;      use Opt;
  47 with Rtsfind;  use Rtsfind;
  48 with Sem;      use Sem;
  49 with Sem_Cat;  use Sem_Cat;
  50 with Sem_Ch3;  use Sem_Ch3;
  51 with Sem_Ch13; use Sem_Ch13;
  52 with Sem_Eval; use Sem_Eval;
  53 with Sem_Res;  use Sem_Res;
  54 with Sem_Type; use Sem_Type;
  55 with Sem_Util; use Sem_Util;
  56 with Sem_Warn; use Sem_Warn;
  57 with Sinfo;    use Sinfo;
  58 with Snames;   use Snames;
  59 with Stand;    use Stand;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Ttypes;   use Ttypes;
  63 with Uintp;    use Uintp;
  64 with Urealp;   use Urealp;
  65 with Validsw;  use Validsw;
  66
  67 package body Exp_Ch4 is
  68
  69    -----------------------
  70    -- Local Subprograms --
  71    -----------------------
  72
  73    procedure Binary_Op_Validity_Checks (N : Node_Id);
  74    pragma Inline (Binary_Op_Validity_Checks);
  75    --  Performs validity checks for a binary operator
  76
  77    procedure Build_Boolean_Array_Proc_Call
  78      (N   : Node_Id;
  79       Op1 : Node_Id;
  80       Op2 : Node_Id);
  81    --  If an boolean array assignment can be done in place, build call to
  82    --  corresponding library procedure.
  83
  84    procedure Expand_Allocator_Expression (N : Node_Id);
  85    --  Subsidiary to Expand_N_Allocator, for the case when the expression
  86    --  is a qualified expression or an aggregate.
  87
  88    procedure Expand_Array_Comparison (N : Node_Id);
  89    --  This routine handles expansion of the comparison operators (N_Op_Lt,
  90    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
  91    --  code for these operators is similar, differing only in the details of
  92    --  the actual comparison call that is made. Special processing (call a
  93    --  run-time routine)
  94
  95    function Expand_Array_Equality
  96      (Nod    : Node_Id;
  97       Lhs    : Node_Id;
  98       Rhs    : Node_Id;
  99       Bodies : List_Id;
 100       Typ    : Entity_Id) return Node_Id;
 101    --  Expand an array equality into a call to a function implementing this
 102    --  equality, and a call to it. Loc is the location for the generated
 103    --  nodes. Lhs and Rhs are the array expressions to be compared.
 104    --  Bodies is a list on which to attach bodies of local functions that
 105    --  are created in the process. It is the responsibility of the
 106    --  caller to insert those bodies at the right place. Nod provides
 107    --  the Sloc value for the generated code. Normally the types used
 108    --  for the generated equality routine are taken from Lhs and Rhs.
 109    --  However, in some situations of generated code, the Etype fields
 110    --  of Lhs and Rhs are not set yet. In such cases, Typ supplies the
 111    --  type to be used for the formal parameters.
 112
 113    procedure Expand_Boolean_Operator (N : Node_Id);
 114    --  Common expansion processing for Boolean operators (And, Or, Xor)
 115    --  for the case of array type arguments.
 116
 117    function Expand_Composite_Equality
 118      (Nod    : Node_Id;
 119       Typ    : Entity_Id;
 120       Lhs    : Node_Id;
 121       Rhs    : Node_Id;
 122       Bodies : List_Id) return Node_Id;
 123    --  Local recursive function used to expand equality for nested
 124    --  composite types. Used by Expand_Record/Array_Equality, Bodies
 125    --  is a list on which to attach bodies of local functions that are
 126    --  created in the process. This is the responsability of the caller
 127    --  to insert those bodies at the right place. Nod provides the Sloc
 128    --  value for generated code. Lhs and Rhs are the left and right sides
 129    --  for the comparison, and Typ is the type of the arrays to compare.
 130
 131    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
 132    --  This routine handles expansion of concatenation operations, where
 133    --  N is the N_Op_Concat node being expanded and Operands is the list
 134    --  of operands (at least two are present). The caller has dealt with
 135    --  converting any singleton operands into singleton aggregates.
 136
 137    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
 138    --  Routine to expand concatenation of 2-5 operands (in the list Operands)
 139    --  and replace node Cnode with the result of the contatenation. If there
 140    --  are two operands, they can be string or character. If there are more
 141    --  than two operands, then are always of type string (i.e. the caller has
 142    --  already converted character operands to strings in this case).
 143
 144    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
 145    --  N is either an N_Op_Divide or N_Op_Multiply node whose result is
 146    --  universal fixed. We do not have such a type at runtime, so the
 147    --  purpose of this routine is to find the real type by looking up
 148    --  the tree. We also determine if the operation must be rounded.
 149
 150    function Get_Allocator_Final_List
 151      (N    : Node_Id;
 152       T    : Entity_Id;
 153       PtrT : Entity_Id) return Entity_Id;
 154    --  If the designated type is controlled, build final_list expression
 155    --  for created object. If context is an access parameter, create a
 156    --  local access type to have a usable finalization list.
 157
 158    function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
 159    --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
 160    --  discriminants if it has a constrained nominal type, unless the object
 161    --  is a component of an enclosing Unchecked_Union object that is subject
 162    --  to a per-object constraint and the enclosing object lacks inferable
 163    --  discriminants.
 164    --
 165    --  An expression of an Unchecked_Union type has inferable discriminants
 166    --  if it is either a name of an object with inferable discriminants or a
 167    --  qualified expression whose subtype mark denotes a constrained subtype.
 168
 169    procedure Insert_Dereference_Action (N : Node_Id);
 170    --  N is an expression whose type is an access. When the type of the
 171    --  associated storage pool is derived from Checked_Pool, generate a
 172    --  call to the 'Dereference' primitive operation.
 173
 174    function Make_Array_Comparison_Op
 175      (Typ : Entity_Id;
 176       Nod : Node_Id) return Node_Id;
 177    --  Comparisons between arrays are expanded in line. This function
 178    --  produces the body of the implementation of (a > b), where a and b
 179    --  are one-dimensional arrays of some discrete type. The original
 180    --  node is then expanded into the appropriate call to this function.
 181    --  Nod provides the Sloc value for the generated code.
 182
 183    function Make_Boolean_Array_Op
 184      (Typ : Entity_Id;
 185       N   : Node_Id) return Node_Id;
 186    --  Boolean operations on boolean arrays are expanded in line. This
 187    --  function produce the body for the node N, which is (a and b),
 188    --  (a or b), or (a xor b). It is used only the normal case and not
 189    --  the packed case. The type involved, Typ, is the Boolean array type,
 190    --  and the logical operations in the body are simple boolean operations.
 191    --  Note that Typ is always a constrained type (the caller has ensured
 192    --  this by using Convert_To_Actual_Subtype if necessary).
 193
 194    procedure Rewrite_Comparison (N : Node_Id);
 195    --  N is the node for a compile time comparison. If this outcome of this
 196    --  comparison can be determined at compile time, then the node N can be
 197    --  rewritten with True or False. If the outcome cannot be determined at
 198    --  compile time, the call has no effect.
 199
 200    function Tagged_Membership (N : Node_Id) return Node_Id;
 201    --  Construct the expression corresponding to the tagged membership test.
 202    --  Deals with a second operand being (or not) a class-wide type.
 203
 204    function Safe_In_Place_Array_Op
 205      (Lhs : Node_Id;
 206       Op1 : Node_Id;
 207       Op2 : Node_Id) return Boolean;
 208    --  In the context of an assignment, where the right-hand side is a
 209    --  boolean operation on arrays, check whether operation can be performed
 210    --  in place.
 211
 212    procedure Unary_Op_Validity_Checks (N : Node_Id);
 213    pragma Inline (Unary_Op_Validity_Checks);
 214    --  Performs validity checks for a unary operator
 215
 216    -------------------------------
 217    -- Binary_Op_Validity_Checks --
 218    -------------------------------
 219
 220    procedure Binary_Op_Validity_Checks (N : Node_Id) is
 221    begin
 222       if Validity_Checks_On and Validity_Check_Operands then
 223          Ensure_Valid (Left_Opnd (N));
 224          Ensure_Valid (Right_Opnd (N));
 225       end if;
 226    end Binary_Op_Validity_Checks;
 227
 228    ------------------------------------
 229    -- Build_Boolean_Array_Proc_Call --
 230    ------------------------------------
 231
 232    procedure Build_Boolean_Array_Proc_Call
 233      (N   : Node_Id;
 234       Op1 : Node_Id;
 235       Op2 : Node_Id)
 236    is
 237       Loc       : constant Source_Ptr := Sloc (N);
 238       Kind      : constant Node_Kind := Nkind (Expression (N));
 239       Target    : constant Node_Id   :=
 240                     Make_Attribute_Reference (Loc,
 241                       Prefix         => Name (N),
 242                       Attribute_Name => Name_Address);
 243
 244       Arg1      : constant Node_Id := Op1;
 245       Arg2      : Node_Id := Op2;
 246       Call_Node : Node_Id;
 247       Proc_Name : Entity_Id;
 248
 249    begin
 250       if Kind = N_Op_Not then
 251          if Nkind (Op1) in N_Binary_Op then
 252
 253             --  Use negated version of the binary operators
 254
 255             if Nkind (Op1) = N_Op_And then
 256                Proc_Name := RTE (RE_Vector_Nand);
 257
 258             elsif Nkind (Op1) = N_Op_Or then
 259                Proc_Name := RTE (RE_Vector_Nor);
 260
 261             else pragma Assert (Nkind (Op1) = N_Op_Xor);
 262                Proc_Name := RTE (RE_Vector_Xor);
 263             end if;
 264
 265             Call_Node :=
 266               Make_Procedure_Call_Statement (Loc,
 267                 Name => New_Occurrence_Of (Proc_Name, Loc),
 268
 269                 Parameter_Associations => New_List (
 270                   Target,
 271                   Make_Attribute_Reference (Loc,
 272                     Prefix => Left_Opnd (Op1),
 273                     Attribute_Name => Name_Address),
 274
 275                   Make_Attribute_Reference (Loc,
 276                     Prefix => Right_Opnd (Op1),
 277                     Attribute_Name => Name_Address),
 278
 279                   Make_Attribute_Reference (Loc,
 280                     Prefix => Left_Opnd (Op1),
 281                     Attribute_Name => Name_Length)));
 282
 283          else
 284             Proc_Name := RTE (RE_Vector_Not);
 285
 286             Call_Node :=
 287               Make_Procedure_Call_Statement (Loc,
 288                 Name => New_Occurrence_Of (Proc_Name, Loc),
 289                 Parameter_Associations => New_List (
 290                   Target,
 291
 292                   Make_Attribute_Reference (Loc,
 293                     Prefix => Op1,
 294                     Attribute_Name => Name_Address),
 295
 296                   Make_Attribute_Reference (Loc,
 297                     Prefix => Op1,
 298                      Attribute_Name => Name_Length)));
 299          end if;
 300
 301       else
 302          --  We use the following equivalences:
 303
 304          --   (not X) or  (not Y)  =  not (X and Y)  =  Nand (X, Y)
 305          --   (not X) and (not Y)  =  not (X or Y)   =  Nor  (X, Y)
 306          --   (not X) xor (not Y)  =  X xor Y
 307          --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)
 308
 309          if Nkind (Op1) = N_Op_Not then
 310             if Kind = N_Op_And then
 311                Proc_Name := RTE (RE_Vector_Nor);
 312
 313             elsif Kind = N_Op_Or then
 314                Proc_Name := RTE (RE_Vector_Nand);
 315
 316             else
 317                Proc_Name := RTE (RE_Vector_Xor);
 318             end if;
 319
 320          else
 321             if Kind = N_Op_And then
 322                Proc_Name := RTE (RE_Vector_And);
 323
 324             elsif Kind = N_Op_Or then
 325                Proc_Name := RTE (RE_Vector_Or);
 326
 327             elsif Nkind (Op2) = N_Op_Not then
 328                Proc_Name := RTE (RE_Vector_Nxor);
 329                Arg2 := Right_Opnd (Op2);
 330
 331             else
 332                Proc_Name := RTE (RE_Vector_Xor);
 333             end if;
 334          end if;
 335
 336          Call_Node :=
 337            Make_Procedure_Call_Statement (Loc,
 338              Name => New_Occurrence_Of (Proc_Name, Loc),
 339              Parameter_Associations => New_List (
 340                Target,
 341                   Make_Attribute_Reference (Loc,
 342                     Prefix => Arg1,
 343                     Attribute_Name => Name_Address),
 344                   Make_Attribute_Reference (Loc,
 345                     Prefix => Arg2,
 346                     Attribute_Name => Name_Address),
 347                  Make_Attribute_Reference (Loc,
 348                    Prefix => Op1,
 349                     Attribute_Name => Name_Length)));
 350       end if;
 351
 352       Rewrite (N, Call_Node);
 353       Analyze (N);
 354
 355    exception
 356       when RE_Not_Available =>
 357          return;
 358    end Build_Boolean_Array_Proc_Call;
 359
 360    ---------------------------------
 361    -- Expand_Allocator_Expression --
 362    ---------------------------------
 363
 364    procedure Expand_Allocator_Expression (N : Node_Id) is
 365       Loc   : constant Source_Ptr := Sloc (N);
 366       Exp   : constant Node_Id    := Expression (Expression (N));
 367       Indic : constant Node_Id    := Subtype_Mark (Expression (N));
 368       PtrT  : constant Entity_Id  := Etype (N);
 369       T     : constant Entity_Id  := Entity (Indic);
 370       Flist : Node_Id;
 371       Node  : Node_Id;
 372       Temp  : Entity_Id;
 373
 374       Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
 375
 376       Tag_Assign : Node_Id;
 377       Tmp_Node   : Node_Id;
 378
 379    begin
 380       if Is_Tagged_Type (T) or else Controlled_Type (T) then
 381
 382          --    Actions inserted before:
 383          --              Temp : constant ptr_T := new T'(Expression);
 384          --   <no CW>    Temp._tag := T'tag;
 385          --   <CTRL>     Adjust (Finalizable (Temp.all));
 386          --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
 387
 388          --  We analyze by hand the new internal allocator to avoid
 389          --  any recursion and inappropriate call to Initialize
 390
 391          if not Aggr_In_Place then
 392             Remove_Side_Effects (Exp);
 393          end if;
 394
 395          Temp :=
 396            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 397
 398          --  For a class wide allocation generate the following code:
 399
 400          --    type Equiv_Record is record ... end record;
 401          --    implicit subtype CW is <Class_Wide_Subytpe>;
 402          --    temp : PtrT := new CW'(CW!(expr));
 403
 404          if Is_Class_Wide_Type (T) then
 405             Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
 406
 407             Set_Expression (Expression (N),
 408               Unchecked_Convert_To (Entity (Indic), Exp));
 409
 410             Analyze_And_Resolve (Expression (N), Entity (Indic));
 411          end if;
 412
 413          if Aggr_In_Place then
 414             Tmp_Node :=
 415               Make_Object_Declaration (Loc,
 416                 Defining_Identifier => Temp,
 417                 Object_Definition   => New_Reference_To (PtrT, Loc),
 418                 Expression          =>
 419                   Make_Allocator (Loc,
 420                     New_Reference_To (Etype (Exp), Loc)));
 421
 422             Set_Comes_From_Source
 423               (Expression (Tmp_Node), Comes_From_Source (N));
 424
 425             Set_No_Initialization (Expression (Tmp_Node));
 426             Insert_Action (N, Tmp_Node);
 427
 428             if Controlled_Type (T)
 429               and then Ekind (PtrT) = E_Anonymous_Access_Type
 430             then
 431                --  Create local finalization list for access parameter
 432
 433                Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 434             end if;
 435
 436             Convert_Aggr_In_Allocator (Tmp_Node, Exp);
 437          else
 438             Node := Relocate_Node (N);
 439             Set_Analyzed (Node);
 440             Insert_Action (N,
 441               Make_Object_Declaration (Loc,
 442                 Defining_Identifier => Temp,
 443                 Constant_Present    => True,
 444                 Object_Definition   => New_Reference_To (PtrT, Loc),
 445                 Expression          => Node));
 446          end if;
 447
 448          --  Suppress the tag assignment when Java_VM because JVM tags
 449          --  are represented implicitly in objects.
 450
 451          if Is_Tagged_Type (T)
 452            and then not Is_Class_Wide_Type (T)
 453            and then not Java_VM
 454          then
 455             Tag_Assign :=
 456               Make_Assignment_Statement (Loc,
 457                 Name =>
 458                   Make_Selected_Component (Loc,
 459                     Prefix => New_Reference_To (Temp, Loc),
 460                     Selector_Name =>
 461                       New_Reference_To (Tag_Component (T), Loc)),
 462
 463                 Expression =>
 464                   Unchecked_Convert_To (RTE (RE_Tag),
 465                     New_Reference_To (Access_Disp_Table (T), Loc)));
 466
 467             --  The previous assignment has to be done in any case
 468
 469             Set_Assignment_OK (Name (Tag_Assign));
 470             Insert_Action (N, Tag_Assign);
 471
 472          elsif Is_Private_Type (T)
 473            and then Is_Tagged_Type (Underlying_Type (T))
 474            and then not Java_VM
 475          then
 476             declare
 477                Utyp : constant Entity_Id := Underlying_Type (T);
 478                Ref  : constant Node_Id :=
 479                         Unchecked_Convert_To (Utyp,
 480                           Make_Explicit_Dereference (Loc,
 481                             New_Reference_To (Temp, Loc)));
 482
 483             begin
 484                Tag_Assign :=
 485                  Make_Assignment_Statement (Loc,
 486                    Name =>
 487                      Make_Selected_Component (Loc,
 488                        Prefix => Ref,
 489                        Selector_Name =>
 490                          New_Reference_To (Tag_Component (Utyp), Loc)),
 491
 492                    Expression =>
 493                      Unchecked_Convert_To (RTE (RE_Tag),
 494                        New_Reference_To (
 495                          Access_Disp_Table (Utyp), Loc)));
 496
 497                Set_Assignment_OK (Name (Tag_Assign));
 498                Insert_Action (N, Tag_Assign);
 499             end;
 500          end if;
 501
 502          if Controlled_Type (Designated_Type (PtrT))
 503             and then Controlled_Type (T)
 504          then
 505             declare
 506                Attach : Node_Id;
 507                Apool  : constant Entity_Id :=
 508                           Associated_Storage_Pool (PtrT);
 509
 510             begin
 511                --  If it is an allocation on the secondary stack
 512                --  (i.e. a value returned from a function), the object
 513                --  is attached on the caller side as soon as the call
 514                --  is completed (see Expand_Ctrl_Function_Call)
 515
 516                if Is_RTE (Apool, RE_SS_Pool) then
 517                   declare
 518                      F : constant Entity_Id :=
 519                            Make_Defining_Identifier (Loc,
 520                              New_Internal_Name ('F'));
 521                   begin
 522                      Insert_Action (N,
 523                        Make_Object_Declaration (Loc,
 524                          Defining_Identifier => F,
 525                          Object_Definition   => New_Reference_To (RTE
 526                           (RE_Finalizable_Ptr), Loc)));
 527
 528                      Flist := New_Reference_To (F, Loc);
 529                      Attach :=  Make_Integer_Literal (Loc, 1);
 530                   end;
 531
 532                --  Normal case, not a secondary stack allocation
 533
 534                else
 535                   if Controlled_Type (T)
 536                     and then Ekind (PtrT) = E_Anonymous_Access_Type
 537                   then
 538                      --  Create local finalization list for access parameter
 539
 540                      Flist :=
 541                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
 542                   else
 543                      Flist := Find_Final_List (PtrT);
 544                   end if;
 545
 546                   Attach :=  Make_Integer_Literal (Loc, 2);
 547                end if;
 548
 549                if not Aggr_In_Place then
 550                   Insert_Actions (N,
 551                     Make_Adjust_Call (
 552                       Ref          =>
 553
 554                      --  An unchecked conversion is needed in the
 555                      --  classwide case because the designated type
 556                      --  can be an ancestor of the subtype mark of
 557                      --  the allocator.
 558
 559                       Unchecked_Convert_To (T,
 560                         Make_Explicit_Dereference (Loc,
 561                           New_Reference_To (Temp, Loc))),
 562
 563                       Typ          => T,
 564                       Flist_Ref    => Flist,
 565                       With_Attach  => Attach));
 566                end if;
 567             end;
 568          end if;
 569
 570          Rewrite (N, New_Reference_To (Temp, Loc));
 571          Analyze_And_Resolve (N, PtrT);
 572
 573       elsif Aggr_In_Place then
 574          Temp :=
 575            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 576          Tmp_Node :=
 577            Make_Object_Declaration (Loc,
 578              Defining_Identifier => Temp,
 579              Object_Definition   => New_Reference_To (PtrT, Loc),
 580              Expression          => Make_Allocator (Loc,
 581                  New_Reference_To (Etype (Exp), Loc)));
 582
 583          Set_Comes_From_Source
 584            (Expression (Tmp_Node), Comes_From_Source (N));
 585
 586          Set_No_Initialization (Expression (Tmp_Node));
 587          Insert_Action (N, Tmp_Node);
 588          Convert_Aggr_In_Allocator (Tmp_Node, Exp);
 589          Rewrite (N, New_Reference_To (Temp, Loc));
 590          Analyze_And_Resolve (N, PtrT);
 591
 592       elsif Is_Access_Type (Designated_Type (PtrT))
 593         and then Nkind (Exp) = N_Allocator
 594         and then Nkind (Expression (Exp)) /= N_Qualified_Expression
 595       then
 596          --  Apply constraint to designated subtype indication
 597
 598          Apply_Constraint_Check (Expression (Exp),
 599            Designated_Type (Designated_Type (PtrT)),
 600            No_Sliding => True);
 601
 602          if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
 603
 604             --  Propagate constraint_error to enclosing allocator
 605
 606             Rewrite (Exp, New_Copy (Expression (Exp)));
 607          end if;
 608       else
 609          --  First check against the type of the qualified expression
 610          --
 611          --  NOTE: The commented call should be correct, but for
 612          --  some reason causes the compiler to bomb (sigsegv) on
 613          --  ACVC test c34007g, so for now we just perform the old
 614          --  (incorrect) test against the designated subtype with
 615          --  no sliding in the else part of the if statement below.
 616          --  ???
 617          --
 618          --  Apply_Constraint_Check (Exp, T, No_Sliding => True);
 619
 620          --  A check is also needed in cases where the designated
 621          --  subtype is constrained and differs from the subtype
 622          --  given in the qualified expression. Note that the check
 623          --  on the qualified expression does not allow sliding,
 624          --  but this check does (a relaxation from Ada 83).
 625
 626          if Is_Constrained (Designated_Type (PtrT))
 627            and then not Subtypes_Statically_Match
 628                           (T, Designated_Type (PtrT))
 629          then
 630             Apply_Constraint_Check
 631               (Exp, Designated_Type (PtrT), No_Sliding => False);
 632
 633          --  The nonsliding check should really be performed
 634          --  (unconditionally) against the subtype of the
 635          --  qualified expression, but that causes a problem
 636          --  with c34007g (see above), so for now we retain this.
 637
 638          else
 639             Apply_Constraint_Check
 640               (Exp, Designated_Type (PtrT), No_Sliding => True);
 641          end if;
 642       end if;
 643
 644    exception
 645       when RE_Not_Available =>
 646          return;
 647    end Expand_Allocator_Expression;
 648
 649    -----------------------------
 650    -- Expand_Array_Comparison --
 651    -----------------------------
 652
 653    --  Expansion is only required in the case of array types. For the
 654    --  unpacked case, an appropriate runtime routine is called. For
 655    --  packed cases, and also in some other cases where a runtime
 656    --  routine cannot be called, the form of the expansion is:
 657
 658    --     [body for greater_nn; boolean_expression]
 659
 660    --  The body is built by Make_Array_Comparison_Op, and the form of the
 661    --  Boolean expression depends on the operator involved.
 662
 663    procedure Expand_Array_Comparison (N : Node_Id) is
 664       Loc  : constant Source_Ptr := Sloc (N);
 665       Op1  : Node_Id             := Left_Opnd (N);
 666       Op2  : Node_Id             := Right_Opnd (N);
 667       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
 668       Ctyp : constant Entity_Id  := Component_Type (Typ1);
 669
 670       Expr      : Node_Id;
 671       Func_Body : Node_Id;
 672       Func_Name : Entity_Id;
 673
 674       Comp : RE_Id;
 675
 676       Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
 677       --  True for byte addressable target
 678
 679       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
 680       --  Returns True if the length of the given operand is known to be
 681       --  less than 4. Returns False if this length is known to be four
 682       --  or greater or is not known at compile time.
 683
 684       ------------------------
 685       -- Length_Less_Than_4 --
 686       ------------------------
 687
 688       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
 689          Otyp : constant Entity_Id := Etype (Opnd);
 690
 691       begin
 692          if Ekind (Otyp) = E_String_Literal_Subtype then
 693             return String_Literal_Length (Otyp) < 4;
 694
 695          else
 696             declare
 697                Ityp : constant Entity_Id := Etype (First_Index (Otyp));
 698                Lo   : constant Node_Id   := Type_Low_Bound (Ityp);
 699                Hi   : constant Node_Id   := Type_High_Bound (Ityp);
 700                Lov  : Uint;
 701                Hiv  : Uint;
 702
 703             begin
 704                if Compile_Time_Known_Value (Lo) then
 705                   Lov := Expr_Value (Lo);
 706                else
 707                   return False;
 708                end if;
 709
 710                if Compile_Time_Known_Value (Hi) then
 711                   Hiv := Expr_Value (Hi);
 712                else
 713                   return False;
 714                end if;
 715
 716                return Hiv < Lov + 3;
 717             end;
 718          end if;
 719       end Length_Less_Than_4;
 720
 721    --  Start of processing for Expand_Array_Comparison
 722
 723    begin
 724       --  Deal first with unpacked case, where we can call a runtime routine
 725       --  except that we avoid this for targets for which are not addressable
 726       --  by bytes, and for the JVM, since the JVM does not support direct
 727       --  addressing of array components.
 728
 729       if not Is_Bit_Packed_Array (Typ1)
 730         and then Byte_Addressable
 731         and then not Java_VM
 732       then
 733          --  The call we generate is:
 734
 735          --  Compare_Array_xn[_Unaligned]
 736          --    (left'address, right'address, left'length, right'length) <op> 0
 737
 738          --  x = U for unsigned, S for signed
 739          --  n = 8,16,32,64 for component size
 740          --  Add _Unaligned if length < 4 and component size is 8.
 741          --  <op> is the standard comparison operator
 742
 743          if Component_Size (Typ1) = 8 then
 744             if Length_Less_Than_4 (Op1)
 745                  or else
 746                Length_Less_Than_4 (Op2)
 747             then
 748                if Is_Unsigned_Type (Ctyp) then
 749                   Comp := RE_Compare_Array_U8_Unaligned;
 750                else
 751                   Comp := RE_Compare_Array_S8_Unaligned;
 752                end if;
 753
 754             else
 755                if Is_Unsigned_Type (Ctyp) then
 756                   Comp := RE_Compare_Array_U8;
 757                else
 758                   Comp := RE_Compare_Array_S8;
 759                end if;
 760             end if;
 761
 762          elsif Component_Size (Typ1) = 16 then
 763             if Is_Unsigned_Type (Ctyp) then
 764                Comp := RE_Compare_Array_U16;
 765             else
 766                Comp := RE_Compare_Array_S16;
 767             end if;
 768
 769          elsif Component_Size (Typ1) = 32 then
 770             if Is_Unsigned_Type (Ctyp) then
 771                Comp := RE_Compare_Array_U32;
 772             else
 773                Comp := RE_Compare_Array_S32;
 774             end if;
 775
 776          else pragma Assert (Component_Size (Typ1) = 64);
 777             if Is_Unsigned_Type (Ctyp) then
 778                Comp := RE_Compare_Array_U64;
 779             else
 780                Comp := RE_Compare_Array_S64;
 781             end if;
 782          end if;
 783
 784          Remove_Side_Effects (Op1, Name_Req => True);
 785          Remove_Side_Effects (Op2, Name_Req => True);
 786
 787          Rewrite (Op1,
 788            Make_Function_Call (Sloc (Op1),
 789              Name => New_Occurrence_Of (RTE (Comp), Loc),
 790
 791              Parameter_Associations => New_List (
 792                Make_Attribute_Reference (Loc,
 793                  Prefix         => Relocate_Node (Op1),
 794                  Attribute_Name => Name_Address),
 795
 796                Make_Attribute_Reference (Loc,
 797                  Prefix         => Relocate_Node (Op2),
 798                  Attribute_Name => Name_Address),
 799
 800                Make_Attribute_Reference (Loc,
 801                  Prefix         => Relocate_Node (Op1),
 802                  Attribute_Name => Name_Length),
 803
 804                Make_Attribute_Reference (Loc,
 805                  Prefix         => Relocate_Node (Op2),
 806                  Attribute_Name => Name_Length))));
 807
 808          Rewrite (Op2,
 809            Make_Integer_Literal (Sloc (Op2),
 810              Intval => Uint_0));
 811
 812          Analyze_And_Resolve (Op1, Standard_Integer);
 813          Analyze_And_Resolve (Op2, Standard_Integer);
 814          return;
 815       end if;
 816
 817       --  Cases where we cannot make runtime call
 818
 819       --  For (a <= b) we convert to not (a > b)
 820
 821       if Chars (N) = Name_Op_Le then
 822          Rewrite (N,
 823            Make_Op_Not (Loc,
 824              Right_Opnd =>
 825                 Make_Op_Gt (Loc,
 826                  Left_Opnd  => Op1,
 827                  Right_Opnd => Op2)));
 828          Analyze_And_Resolve (N, Standard_Boolean);
 829          return;
 830
 831       --  For < the Boolean expression is
 832       --    greater__nn (op2, op1)
 833
 834       elsif Chars (N) = Name_Op_Lt then
 835          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 836
 837          --  Switch operands
 838
 839          Op1 := Right_Opnd (N);
 840          Op2 := Left_Opnd  (N);
 841
 842       --  For (a >= b) we convert to not (a < b)
 843
 844       elsif Chars (N) = Name_Op_Ge then
 845          Rewrite (N,
 846            Make_Op_Not (Loc,
 847              Right_Opnd =>
 848                Make_Op_Lt (Loc,
 849                  Left_Opnd  => Op1,
 850                  Right_Opnd => Op2)));
 851          Analyze_And_Resolve (N, Standard_Boolean);
 852          return;
 853
 854       --  For > the Boolean expression is
 855       --    greater__nn (op1, op2)
 856
 857       else
 858          pragma Assert (Chars (N) = Name_Op_Gt);
 859          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 860       end if;
 861
 862       Func_Name := Defining_Unit_Name (Specification (Func_Body));
 863       Expr :=
 864         Make_Function_Call (Loc,
 865           Name => New_Reference_To (Func_Name, Loc),
 866           Parameter_Associations => New_List (Op1, Op2));
 867
 868       Insert_Action (N, Func_Body);
 869       Rewrite (N, Expr);
 870       Analyze_And_Resolve (N, Standard_Boolean);
 871
 872    exception
 873       when RE_Not_Available =>
 874          return;
 875    end Expand_Array_Comparison;
 876
 877    ---------------------------
 878    -- Expand_Array_Equality --
 879    ---------------------------
 880
 881    --  Expand an equality function for multi-dimensional arrays. Here is
 882    --  an example of such a function for Nb_Dimension = 2
 883
 884    --  function Enn (A : atyp; B : btyp) return boolean is
 885    --  begin
 886    --     if (A'length (1) = 0 or else A'length (2) = 0)
 887    --          and then
 888    --        (B'length (1) = 0 or else B'length (2) = 0)
 889    --     then
 890    --        return True;    -- RM 4.5.2(22)
 891    --     end if;
 892
 893    --     if A'length (1) /= B'length (1)
 894    --               or else
 895    --           A'length (2) /= B'length (2)
 896    --     then
 897    --        return False;   -- RM 4.5.2(23)
 898    --     end if;
 899
 900    --     declare
 901    --        A1 : Index_T1 := A'first (1);
 902    --        B1 : Index_T1 := B'first (1);
 903    --     begin
 904    --        loop
 905    --           declare
 906    --              A2 : Index_T2 := A'first (2);
 907    --              B2 : Index_T2 := B'first (2);
 908    --           begin
 909    --              loop
 910    --                 if A (A1, A2) /= B (B1, B2) then
 911    --                    return False;
 912    --                 end if;
 913
 914    --                 exit when A2 = A'last (2);
 915    --                 A2 := Index_T2'succ (A2);
 916    --                 B2 := Index_T2'succ (B2);
 917    --              end loop;
 918    --           end;
 919
 920    --           exit when A1 = A'last (1);
 921    --           A1 := Index_T1'succ (A1);
 922    --           B1 := Index_T1'succ (B1);
 923    --        end loop;
 924    --     end;
 925
 926    --     return true;
 927    --  end Enn;
 928
 929    --  Note on the formal types used (atyp and btyp). If either of the
 930    --  arrays is of a private type, we use the underlying type, and
 931    --  do an unchecked conversion of the actual. If either of the arrays
 932    --  has a bound depending on a discriminant, then we use the base type
 933    --  since otherwise we have an escaped discriminant in the function.
 934
 935    --  If both arrays are constrained and have the same bounds, we can
 936    --  generate a loop with an explicit iteration scheme using a 'Range
 937    --  attribute over the first array.
 938
 939    function Expand_Array_Equality
 940      (Nod    : Node_Id;
 941       Lhs    : Node_Id;
 942       Rhs    : Node_Id;
 943       Bodies : List_Id;
 944       Typ    : Entity_Id) return Node_Id
 945    is
 946       Loc         : constant Source_Ptr := Sloc (Nod);
 947       Decls       : constant List_Id    := New_List;
 948       Index_List1 : constant List_Id    := New_List;
 949       Index_List2 : constant List_Id    := New_List;
 950
 951       Actuals   : List_Id;
 952       Formals   : List_Id;
 953       Func_Name : Entity_Id;
 954       Func_Body : Node_Id;
 955
 956       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
 957       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
 958
 959       Ltyp : Entity_Id;
 960       Rtyp : Entity_Id;
 961       --  The parameter types to be used for the formals
 962
 963       function Arr_Attr
 964         (Arr : Entity_Id;
 965          Nam : Name_Id;
 966          Num : Int) return Node_Id;
 967       --  This builds the attribute reference Arr'Nam (Expr)
 968
 969       function Component_Equality (Typ : Entity_Id) return Node_Id;
 970       --  Create one statement to compare corresponding components,
 971       --  designated by a full set of indices.
 972
 973       function Get_Arg_Type (N : Node_Id) return Entity_Id;
 974       --  Given one of the arguments, computes the appropriate type to
 975       --  be used for that argument in the corresponding function formal
 976
 977       function Handle_One_Dimension
 978         (N     : Int;
 979          Index : Node_Id) return Node_Id;
 980       --  This procedure returns the following code
 981       --
 982       --    declare
 983       --       Bn : Index_T := B'First (N);
 984       --    begin
 985       --       loop
 986       --          xxx
 987       --          exit when An = A'Last (N);
 988       --          An := Index_T'Succ (An)
 989       --          Bn := Index_T'Succ (Bn)
 990       --       end loop;
 991       --    end;
 992       --
 993       --  If both indices are constrained and identical, the procedure
 994       --  returns a simpler loop:
 995       --
 996       --      for An in A'Range (N) loop
 997       --         xxx
 998       --      end loop
 999       --
1000       --  N is the dimension for which we are generating a loop. Index is the
1001       --  N'th index node, whose Etype is Index_Type_n in the above code.
1002       --  The xxx statement is either the loop or declare for the next
1003       --  dimension or if this is the last dimension the comparison
1004       --  of corresponding components of the arrays.
1005       --
1006       --  The actual way the code works is to return the comparison
1007       --  of corresponding components for the N+1 call. That's neater!
1008
1009       function Test_Empty_Arrays return Node_Id;
1010       --  This function constructs the test for both arrays being empty
1011       --    (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1012       --      and then
1013       --    (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1014
1015       function Test_Lengths_Correspond return Node_Id;
1016       --  This function constructs the test for arrays having different
1017       --  lengths in at least one index position, in which case resull
1018
1019       --     A'length (1) /= B'length (1)
1020       --       or else
1021       --     A'length (2) /= B'length (2)
1022       --       or else
1023       --       ...
1024
1025       --------------
1026       -- Arr_Attr --
1027       --------------
1028
1029       function Arr_Attr
1030         (Arr : Entity_Id;
1031          Nam : Name_Id;
1032          Num : Int) return Node_Id
1033       is
1034       begin
1035          return
1036            Make_Attribute_Reference (Loc,
1037             Attribute_Name => Nam,
1038             Prefix => New_Reference_To (Arr, Loc),
1039             Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1040       end Arr_Attr;
1041
1042       ------------------------
1043       -- Component_Equality --
1044       ------------------------
1045
1046       function Component_Equality (Typ : Entity_Id) return Node_Id is
1047          Test : Node_Id;
1048          L, R : Node_Id;
1049
1050       begin
1051          --  if a(i1...) /= b(j1...) then return false; end if;
1052
1053          L :=
1054            Make_Indexed_Component (Loc,
1055              Prefix => Make_Identifier (Loc, Chars (A)),
1056              Expressions => Index_List1);
1057
1058          R :=
1059            Make_Indexed_Component (Loc,
1060              Prefix => Make_Identifier (Loc, Chars (B)),
1061              Expressions => Index_List2);
1062
1063          Test := Expand_Composite_Equality
1064                    (Nod, Component_Type (Typ), L, R, Decls);
1065
1066          return
1067            Make_Implicit_If_Statement (Nod,
1068              Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1069              Then_Statements => New_List (
1070                Make_Return_Statement (Loc,
1071                  Expression => New_Occurrence_Of (Standard_False, Loc))));
1072       end Component_Equality;
1073
1074       ------------------
1075       -- Get_Arg_Type --
1076       ------------------
1077
1078       function Get_Arg_Type (N : Node_Id) return Entity_Id is
1079          T : Entity_Id;
1080          X : Node_Id;
1081
1082       begin
1083          T := Etype (N);
1084
1085          if No (T) then
1086             return Typ;
1087
1088          else
1089             T := Underlying_Type (T);
1090
1091             X := First_Index (T);
1092             while Present (X) loop
1093                if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1094                  or else
1095                    Denotes_Discriminant (Type_High_Bound (Etype (X)))
1096                then
1097                   T := Base_Type (T);
1098                   exit;
1099                end if;
1100
1101                Next_Index (X);
1102             end loop;
1103
1104             return T;
1105          end if;
1106       end Get_Arg_Type;
1107
1108       --------------------------
1109       -- Handle_One_Dimension --
1110       ---------------------------
1111
1112       function Handle_One_Dimension
1113         (N     : Int;
1114          Index : Node_Id) return Node_Id
1115       is
1116          Need_Separate_Indexes : constant Boolean :=
1117                                    Ltyp /= Rtyp
1118                                      or else not Is_Constrained (Ltyp);
1119          --  If the index types are identical, and we are working with
1120          --  constrained types, then we can use the same index for both of
1121          --  the arrays.
1122
1123          An : constant Entity_Id := Make_Defining_Identifier (Loc,
1124                                       Chars => New_Internal_Name ('A'));
1125
1126          Bn       : Entity_Id;
1127          Index_T  : Entity_Id;
1128          Stm_List : List_Id;
1129          Loop_Stm : Node_Id;
1130
1131       begin
1132          if N > Number_Dimensions (Ltyp) then
1133             return Component_Equality (Ltyp);
1134          end if;
1135
1136          --  Case where we generate a loop
1137
1138          Index_T := Base_Type (Etype (Index));
1139
1140          if Need_Separate_Indexes then
1141             Bn :=
1142               Make_Defining_Identifier (Loc,
1143                 Chars => New_Internal_Name ('B'));
1144          else
1145             Bn := An;
1146          end if;
1147
1148          Append (New_Reference_To (An, Loc), Index_List1);
1149          Append (New_Reference_To (Bn, Loc), Index_List2);
1150
1151          Stm_List := New_List (
1152            Handle_One_Dimension (N + 1, Next_Index (Index)));
1153
1154          if Need_Separate_Indexes then
1155             --  Generate guard for loop, followed by increments of indices
1156
1157             Append_To (Stm_List,
1158                Make_Exit_Statement (Loc,
1159                  Condition =>
1160                    Make_Op_Eq (Loc,
1161                       Left_Opnd => New_Reference_To (An, Loc),
1162                       Right_Opnd => Arr_Attr (A, Name_Last, N))));
1163
1164             Append_To (Stm_List,
1165               Make_Assignment_Statement (Loc,
1166                 Name       => New_Reference_To (An, Loc),
1167                 Expression =>
1168                   Make_Attribute_Reference (Loc,
1169                     Prefix         => New_Reference_To (Index_T, Loc),
1170                     Attribute_Name => Name_Succ,
1171                     Expressions    => New_List (New_Reference_To (An, Loc)))));
1172
1173             Append_To (Stm_List,
1174               Make_Assignment_Statement (Loc,
1175                 Name       => New_Reference_To (Bn, Loc),
1176                 Expression =>
1177                   Make_Attribute_Reference (Loc,
1178                     Prefix         => New_Reference_To (Index_T, Loc),
1179                     Attribute_Name => Name_Succ,
1180                     Expressions    => New_List (New_Reference_To (Bn, Loc)))));
1181          end if;
1182
1183          --  If separate indexes, we need a declare block for An and Bn,
1184          --  and a loop without an iteration scheme.
1185
1186          if Need_Separate_Indexes then
1187             Loop_Stm :=
1188               Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1189
1190             return
1191               Make_Block_Statement (Loc,
1192                 Declarations => New_List (
1193                   Make_Object_Declaration (Loc,
1194                     Defining_Identifier => An,
1195                     Object_Definition   => New_Reference_To (Index_T, Loc),
1196                     Expression          => Arr_Attr (A, Name_First, N)),
1197
1198                   Make_Object_Declaration (Loc,
1199                     Defining_Identifier => Bn,
1200                     Object_Definition   => New_Reference_To (Index_T, Loc),
1201                     Expression          => Arr_Attr (B, Name_First, N))),
1202
1203                 Handled_Statement_Sequence =>
1204                   Make_Handled_Sequence_Of_Statements (Loc,
1205                     Statements => New_List (Loop_Stm)));
1206
1207          --  If no separate indexes, return loop statement with explicit
1208          --  iteration scheme on its own
1209
1210          else
1211             Loop_Stm :=
1212               Make_Implicit_Loop_Statement (Nod,
1213                 Statements       => Stm_List,
1214                 Iteration_Scheme =>
1215                   Make_Iteration_Scheme (Loc,
1216                     Loop_Parameter_Specification =>
1217                       Make_Loop_Parameter_Specification (Loc,
1218                         Defining_Identifier         => An,
1219                         Discrete_Subtype_Definition =>
1220                           Arr_Attr (A, Name_Range, N))));
1221             return Loop_Stm;
1222          end if;
1223       end Handle_One_Dimension;
1224
1225       -----------------------
1226       -- Test_Empty_Arrays --
1227       -----------------------
1228
1229       function Test_Empty_Arrays return Node_Id is
1230          Alist : Node_Id;
1231          Blist : Node_Id;
1232
1233          Atest : Node_Id;
1234          Btest : Node_Id;
1235
1236       begin
1237          Alist := Empty;
1238          Blist := Empty;
1239          for J in 1 .. Number_Dimensions (Ltyp) loop
1240             Atest :=
1241               Make_Op_Eq (Loc,
1242                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1243                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1244
1245             Btest :=
1246               Make_Op_Eq (Loc,
1247                 Left_Opnd  => Arr_Attr (B, Name_Length, J),
1248                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1249
1250             if No (Alist) then
1251                Alist := Atest;
1252                Blist := Btest;
1253
1254             else
1255                Alist :=
1256                  Make_Or_Else (Loc,
1257                    Left_Opnd  => Relocate_Node (Alist),
1258                    Right_Opnd => Atest);
1259
1260                Blist :=
1261                  Make_Or_Else (Loc,
1262                    Left_Opnd  => Relocate_Node (Blist),
1263                    Right_Opnd => Btest);
1264             end if;
1265          end loop;
1266
1267          return
1268            Make_And_Then (Loc,
1269              Left_Opnd  => Alist,
1270              Right_Opnd => Blist);
1271       end Test_Empty_Arrays;
1272
1273       -----------------------------
1274       -- Test_Lengths_Correspond --
1275       -----------------------------
1276
1277       function Test_Lengths_Correspond return Node_Id is
1278          Result : Node_Id;
1279          Rtest  : Node_Id;
1280
1281       begin
1282          Result := Empty;
1283          for J in 1 .. Number_Dimensions (Ltyp) loop
1284             Rtest :=
1285               Make_Op_Ne (Loc,
1286                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1287                 Right_Opnd => Arr_Attr (B, Name_Length, J));
1288
1289             if No (Result) then
1290                Result := Rtest;
1291             else
1292                Result :=
1293                  Make_Or_Else (Loc,
1294                    Left_Opnd  => Relocate_Node (Result),
1295                    Right_Opnd => Rtest);
1296             end if;
1297          end loop;
1298
1299          return Result;
1300       end Test_Lengths_Correspond;
1301
1302    --  Start of processing for Expand_Array_Equality
1303
1304    begin
1305       Ltyp := Get_Arg_Type (Lhs);
1306       Rtyp := Get_Arg_Type (Rhs);
1307
1308       --  For now, if the argument types are not the same, go to the
1309       --  base type, since the code assumes that the formals have the
1310       --  same type. This is fixable in future ???
1311
1312       if Ltyp /= Rtyp then
1313          Ltyp := Base_Type (Ltyp);
1314          Rtyp := Base_Type (Rtyp);
1315          pragma Assert (Ltyp = Rtyp);
1316       end if;
1317
1318       --  Build list of formals for function
1319
1320       Formals := New_List (
1321         Make_Parameter_Specification (Loc,
1322           Defining_Identifier => A,
1323           Parameter_Type      => New_Reference_To (Ltyp, Loc)),
1324
1325         Make_Parameter_Specification (Loc,
1326           Defining_Identifier => B,
1327           Parameter_Type      => New_Reference_To (Rtyp, Loc)));
1328
1329       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
1330
1331       --  Build statement sequence for function
1332
1333       Func_Body :=
1334         Make_Subprogram_Body (Loc,
1335           Specification =>
1336             Make_Function_Specification (Loc,
1337               Defining_Unit_Name       => Func_Name,
1338               Parameter_Specifications => Formals,
1339               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
1340
1341           Declarations =>  Decls,
1342
1343           Handled_Statement_Sequence =>
1344             Make_Handled_Sequence_Of_Statements (Loc,
1345               Statements => New_List (
1346
1347                 Make_Implicit_If_Statement (Nod,
1348                   Condition => Test_Empty_Arrays,
1349                   Then_Statements => New_List (
1350                     Make_Return_Statement (Loc,
1351                       Expression =>
1352                         New_Occurrence_Of (Standard_True, Loc)))),
1353
1354                 Make_Implicit_If_Statement (Nod,
1355                   Condition => Test_Lengths_Correspond,
1356                   Then_Statements => New_List (
1357                     Make_Return_Statement (Loc,
1358                       Expression =>
1359                         New_Occurrence_Of (Standard_False, Loc)))),
1360
1361                 Handle_One_Dimension (1, First_Index (Ltyp)),
1362
1363                 Make_Return_Statement (Loc,
1364                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
1365
1366          Set_Has_Completion (Func_Name, True);
1367          Set_Is_Inlined (Func_Name);
1368
1369          --  If the array type is distinct from the type of the arguments,
1370          --  it is the full view of a private type. Apply an unchecked
1371          --  conversion to insure that analysis of the call succeeds.
1372
1373          declare
1374             L, R : Node_Id;
1375
1376          begin
1377             L := Lhs;
1378             R := Rhs;
1379
1380             if No (Etype (Lhs))
1381               or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1382             then
1383                L := OK_Convert_To (Ltyp, Lhs);
1384             end if;
1385
1386             if No (Etype (Rhs))
1387               or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1388             then
1389                R := OK_Convert_To (Rtyp, Rhs);
1390             end if;
1391
1392             Actuals := New_List (L, R);
1393          end;
1394
1395          Append_To (Bodies, Func_Body);
1396
1397          return
1398            Make_Function_Call (Loc,
1399              Name                   => New_Reference_To (Func_Name, Loc),
1400              Parameter_Associations => Actuals);
1401    end Expand_Array_Equality;
1402
1403    -----------------------------
1404    -- Expand_Boolean_Operator --
1405    -----------------------------
1406
1407    --  Note that we first get the actual subtypes of the operands,
1408    --  since we always want to deal with types that have bounds.
1409
1410    procedure Expand_Boolean_Operator (N : Node_Id) is
1411       Typ : constant Entity_Id  := Etype (N);
1412
1413    begin
1414       if Is_Bit_Packed_Array (Typ) then
1415          Expand_Packed_Boolean_Operator (N);
1416
1417       else
1418          --  For the normal non-packed case, the general expansion is
1419          --  to build a function for carrying out the comparison (using
1420          --  Make_Boolean_Array_Op) and then inserting it into the tree.
1421          --  The original operator node is then rewritten as a call to
1422          --  this function.
1423
1424          declare
1425             Loc       : constant Source_Ptr := Sloc (N);
1426             L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
1427             R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
1428             Func_Body : Node_Id;
1429             Func_Name : Entity_Id;
1430
1431          begin
1432             Convert_To_Actual_Subtype (L);
1433             Convert_To_Actual_Subtype (R);
1434             Ensure_Defined (Etype (L), N);
1435             Ensure_Defined (Etype (R), N);
1436             Apply_Length_Check (R, Etype (L));
1437
1438             if Nkind (Parent (N)) = N_Assignment_Statement
1439                and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
1440             then
1441                Build_Boolean_Array_Proc_Call (Parent (N), L, R);
1442
1443             elsif Nkind (Parent (N)) = N_Op_Not
1444                and then Nkind (N) = N_Op_And
1445                and then
1446                  Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
1447             then
1448                return;
1449             else
1450
1451                Func_Body := Make_Boolean_Array_Op (Etype (L), N);
1452                Func_Name := Defining_Unit_Name (Specification (Func_Body));
1453                Insert_Action (N, Func_Body);
1454
1455                --  Now rewrite the expression with a call
1456
1457                Rewrite (N,
1458                  Make_Function_Call (Loc,
1459                    Name => New_Reference_To (Func_Name, Loc),
1460                    Parameter_Associations =>
1461                      New_List
1462                        (L, Make_Type_Conversion
1463                           (Loc, New_Reference_To (Etype (L), Loc), R))));
1464
1465                Analyze_And_Resolve (N, Typ);
1466             end if;
1467          end;
1468       end if;
1469    end Expand_Boolean_Operator;
1470
1471    -------------------------------
1472    -- Expand_Composite_Equality --
1473    -------------------------------
1474
1475    --  This function is only called for comparing internal fields of composite
1476    --  types when these fields are themselves composites. This is a special
1477    --  case because it is not possible to respect normal Ada visibility rules.
1478
1479    function Expand_Composite_Equality
1480      (Nod    : Node_Id;
1481       Typ    : Entity_Id;
1482       Lhs    : Node_Id;
1483       Rhs    : Node_Id;
1484       Bodies : List_Id) return Node_Id
1485    is
1486       Loc       : constant Source_Ptr := Sloc (Nod);
1487       Full_Type : Entity_Id;
1488       Prim      : Elmt_Id;
1489       Eq_Op     : Entity_Id;
1490
1491    begin
1492       if Is_Private_Type (Typ) then
1493          Full_Type := Underlying_Type (Typ);
1494       else
1495          Full_Type := Typ;
1496       end if;
1497
1498       --  Defense against malformed private types with no completion
1499       --  the error will be diagnosed later by check_completion
1500
1501       if No (Full_Type) then
1502          return New_Reference_To (Standard_False, Loc);
1503       end if;
1504
1505       Full_Type := Base_Type (Full_Type);
1506
1507       if Is_Array_Type (Full_Type) then
1508
1509          --  If the operand is an elementary type other than a floating-point
1510          --  type, then we can simply use the built-in block bitwise equality,
1511          --  since the predefined equality operators always apply and bitwise
1512          --  equality is fine for all these cases.
1513
1514          if Is_Elementary_Type (Component_Type (Full_Type))
1515            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
1516          then
1517             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
1518
1519          --  For composite component types, and floating-point types, use
1520          --  the expansion. This deals with tagged component types (where
1521          --  we use the applicable equality routine) and floating-point,
1522          --  (where we need to worry about negative zeroes), and also the
1523          --  case of any composite type recursively containing such fields.
1524
1525          else
1526             return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
1527          end if;
1528
1529       elsif Is_Tagged_Type (Full_Type) then
1530
1531          --  Call the primitive operation "=" of this type
1532
1533          if Is_Class_Wide_Type (Full_Type) then
1534             Full_Type := Root_Type (Full_Type);
1535          end if;
1536
1537          --  If this is derived from an untagged private type completed
1538          --  with a tagged type, it does not have a full view, so we
1539          --  use the primitive operations of the private type.
1540          --  This check should no longer be necessary when these
1541          --  types receive their full views ???
1542
1543          if Is_Private_Type (Typ)
1544            and then not Is_Tagged_Type (Typ)
1545            and then not Is_Controlled (Typ)
1546            and then Is_Derived_Type (Typ)
1547            and then No (Full_View (Typ))
1548          then
1549             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
1550          else
1551             Prim := First_Elmt (Primitive_Operations (Full_Type));
1552          end if;
1553
1554          loop
1555             Eq_Op := Node (Prim);
1556             exit when Chars (Eq_Op) = Name_Op_Eq
1557               and then Etype (First_Formal (Eq_Op)) =
1558                        Etype (Next_Formal (First_Formal (Eq_Op)))
1559               and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
1560             Next_Elmt (Prim);
1561             pragma Assert (Present (Prim));
1562          end loop;
1563
1564          Eq_Op := Node (Prim);
1565
1566          return
1567            Make_Function_Call (Loc,
1568              Name => New_Reference_To (Eq_Op, Loc),
1569              Parameter_Associations =>
1570                New_List
1571                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
1572                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
1573
1574       elsif Is_Record_Type (Full_Type) then
1575          Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
1576
1577          if Present (Eq_Op) then
1578             if Etype (First_Formal (Eq_Op)) /= Full_Type then
1579
1580                --  Inherited equality from parent type. Convert the actuals
1581                --  to match signature of operation.
1582
1583                declare
1584                   T : constant Entity_Id := Etype (First_Formal (Eq_Op));
1585
1586                begin
1587                   return
1588                     Make_Function_Call (Loc,
1589                       Name => New_Reference_To (Eq_Op, Loc),
1590                       Parameter_Associations =>
1591                         New_List (OK_Convert_To (T, Lhs),
1592                                   OK_Convert_To (T, Rhs)));
1593                end;
1594
1595             else
1596                --  Comparison between Unchecked_Union components
1597
1598                if Is_Unchecked_Union (Full_Type) then
1599                   declare
1600                      Lhs_Type      : Node_Id := Full_Type;
1601                      Rhs_Type      : Node_Id := Full_Type;
1602                      Lhs_Discr_Val : Node_Id;
1603                      Rhs_Discr_Val : Node_Id;
1604
1605                   begin
1606                      --  Lhs subtype
1607
1608                      if Nkind (Lhs) = N_Selected_Component then
1609                         Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
1610                      end if;
1611
1612                      --  Rhs subtype
1613
1614                      if Nkind (Rhs) = N_Selected_Component then
1615                         Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
1616                      end if;
1617
1618                      --  Lhs of the composite equality
1619
1620                      if Is_Constrained (Lhs_Type) then
1621
1622                         --  Since the enclosing record can never be an
1623                         --  Unchecked_Union (this code is executed for records
1624                         --  that do not have variants), we may reference its
1625                         --  discriminant(s).
1626
1627                         if Nkind (Lhs) = N_Selected_Component
1628                           and then Has_Per_Object_Constraint (
1629                                      Entity (Selector_Name (Lhs)))
1630                         then
1631                            Lhs_Discr_Val :=
1632                              Make_Selected_Component (Loc,
1633                                Prefix => Prefix (Lhs),
1634                                Selector_Name =>
1635                                  New_Copy (
1636                                    Get_Discriminant_Value (
1637                                      First_Discriminant (Lhs_Type),
1638                                      Lhs_Type,
1639                                      Stored_Constraint (Lhs_Type))));
1640
1641                         else
1642                            Lhs_Discr_Val := New_Copy (
1643                              Get_Discriminant_Value (
1644                                First_Discriminant (Lhs_Type),
1645                                Lhs_Type,
1646                                Stored_Constraint (Lhs_Type)));
1647
1648                         end if;
1649                      else
1650                         --  It is not possible to infer the discriminant since
1651                         --  the subtype is not constrained.
1652
1653                         Insert_Action (Nod,
1654                           Make_Raise_Program_Error (Loc,
1655                             Reason => PE_Unchecked_Union_Restriction));
1656
1657                         --  Prevent Gigi from generating illegal code, change
1658                         --  the equality to a standard False.
1659
1660                         return New_Occurrence_Of (Standard_False, Loc);
1661                      end if;
1662
1663                      --  Rhs of the composite equality
1664
1665                      if Is_Constrained (Rhs_Type) then
1666                         if Nkind (Rhs) = N_Selected_Component
1667                           and then Has_Per_Object_Constraint (
1668                                      Entity (Selector_Name (Rhs)))
1669                         then
1670                            Rhs_Discr_Val :=
1671                              Make_Selected_Component (Loc,
1672                                Prefix => Prefix (Rhs),
1673                                Selector_Name =>
1674                                  New_Copy (
1675                                    Get_Discriminant_Value (
1676                                      First_Discriminant (Rhs_Type),
1677                                      Rhs_Type,
1678                                      Stored_Constraint (Rhs_Type))));
1679
1680                         else
1681                            Rhs_Discr_Val := New_Copy (
1682                              Get_Discriminant_Value (
1683                                First_Discriminant (Rhs_Type),
1684                                Rhs_Type,
1685                                Stored_Constraint (Rhs_Type)));
1686
1687                         end if;
1688                      else
1689                         Insert_Action (Nod,
1690                           Make_Raise_Program_Error (Loc,
1691                             Reason => PE_Unchecked_Union_Restriction));
1692
1693                         return Empty;
1694                      end if;
1695
1696                      --  Call the TSS equality function with the inferred
1697                      --  discriminant values.
1698
1699                      return
1700                        Make_Function_Call (Loc,
1701                          Name => New_Reference_To (Eq_Op, Loc),
1702                          Parameter_Associations => New_List (
1703                            Lhs,
1704                            Rhs,
1705                            Lhs_Discr_Val,
1706                            Rhs_Discr_Val));
1707                   end;
1708                end if;
1709
1710                --  Shouldn't this be an else, we can't fall through
1711                --  the above IF, right???
1712
1713                return
1714                  Make_Function_Call (Loc,
1715                    Name => New_Reference_To (Eq_Op, Loc),
1716                    Parameter_Associations => New_List (Lhs, Rhs));
1717             end if;
1718
1719          else
1720             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
1721          end if;
1722
1723       else
1724          --  It can be a simple record or the full view of a scalar private
1725
1726          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
1727       end if;
1728    end Expand_Composite_Equality;
1729
1730    ------------------------------
1731    -- Expand_Concatenate_Other --
1732    ------------------------------
1733
1734    --  Let n be the number of array operands to be concatenated, Base_Typ
1735    --  their base type, Ind_Typ their index type, and Arr_Typ the original
1736    --  array type to which the concatenantion operator applies, then the
1737    --  following subprogram is constructed:
1738
1739    --  [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
1740    --      L : Ind_Typ;
1741    --   begin
1742    --      if S1'Length /= 0 then
1743    --         L := XXX;   -->  XXX = S1'First       if Arr_Typ is unconstrained
1744    --                          XXX = Arr_Typ'First  otherwise
1745    --      elsif S2'Length /= 0 then
1746    --         L := YYY;   -->  YYY = S2'First       if Arr_Typ is unconstrained
1747    --                          YYY = Arr_Typ'First  otherwise
1748    --      ...
1749    --      elsif Sn-1'Length /= 0 then
1750    --         L := ZZZ;   -->  ZZZ = Sn-1'First     if Arr_Typ is unconstrained
1751    --                          ZZZ = Arr_Typ'First  otherwise
1752    --      else
1753    --         return Sn;
1754    --      end if;
1755
1756    --      declare
1757    --         P : Ind_Typ;
1758    --         H : Ind_Typ :=
1759    --          Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
1760    --                       + Ind_Typ'Pos (L));
1761    --         R : Base_Typ (L .. H);
1762    --      begin
1763    --         if S1'Length /= 0 then
1764    --            P := S1'First;
1765    --            loop
1766    --               R (L) := S1 (P);
1767    --               L := Ind_Typ'Succ (L);
1768    --               exit when P = S1'Last;
1769    --               P := Ind_Typ'Succ (P);
1770    --            end loop;
1771    --         end if;
1772    --
1773    --         if S2'Length /= 0 then
1774    --            L := Ind_Typ'Succ (L);
1775    --            loop
1776    --               R (L) := S2 (P);
1777    --               L := Ind_Typ'Succ (L);
1778    --               exit when P = S2'Last;
1779    --               P := Ind_Typ'Succ (P);
1780    --            end loop;
1781    --         end if;
1782
1783    --         . . .
1784
1785    --         if Sn'Length /= 0 then
1786    --            P := Sn'First;
1787    --            loop
1788    --               R (L) := Sn (P);
1789    --               L := Ind_Typ'Succ (L);
1790    --               exit when P = Sn'Last;
1791    --               P := Ind_Typ'Succ (P);
1792    --            end loop;
1793    --         end if;
1794
1795    --         return R;
1796    --      end;
1797    --   end Cnn;]
1798
1799    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
1800       Loc      : constant Source_Ptr := Sloc (Cnode);
1801       Nb_Opnds : constant Nat        := List_Length (Opnds);
1802
1803       Arr_Typ  : constant Entity_Id := Etype (Entity (Cnode));
1804       Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
1805       Ind_Typ  : constant Entity_Id := Etype (First_Index (Base_Typ));
1806
1807       Func_Id     : Node_Id;
1808       Func_Spec   : Node_Id;
1809       Param_Specs : List_Id;
1810
1811       Func_Body  : Node_Id;
1812       Func_Decls : List_Id;
1813       Func_Stmts : List_Id;
1814
1815       L_Decl     : Node_Id;
1816
1817       If_Stmt    : Node_Id;
1818       Elsif_List : List_Id;
1819
1820       Declare_Block : Node_Id;
1821       Declare_Decls : List_Id;
1822       Declare_Stmts : List_Id;
1823
1824       H_Decl   : Node_Id;
1825       H_Init   : Node_Id;
1826       P_Decl   : Node_Id;
1827       R_Decl   : Node_Id;
1828       R_Constr : Node_Id;
1829       R_Range  : Node_Id;
1830
1831       Params  : List_Id;
1832       Operand : Node_Id;
1833
1834       function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
1835       --  Builds the sequence of statement:
1836       --    P := Si'First;
1837       --    loop
1838       --       R (L) := Si (P);
1839       --       L := Ind_Typ'Succ (L);
1840       --       exit when P = Si'Last;
1841       --       P := Ind_Typ'Succ (P);
1842       --    end loop;
1843       --
1844       --  where i is the input parameter I given.
1845       --  If the flag Last is true, the exit statement is emitted before
1846       --  incrementing the lower bound, to prevent the creation out of
1847       --  bound values.
1848
1849       function Init_L (I : Nat) return Node_Id;
1850       --  Builds the statement:
1851       --    L := Arr_Typ'First;  If Arr_Typ is constrained
1852       --    L := Si'First;       otherwise (where I is the input param given)
1853
1854       function H return Node_Id;
1855       --  Builds reference to identifier H
1856
1857       function Ind_Val (E : Node_Id) return Node_Id;
1858       --  Builds expression Ind_Typ'Val (E);
1859
1860       function L return Node_Id;
1861       --  Builds reference to identifier L
1862
1863       function L_Pos return Node_Id;
1864       --  Builds expression Integer_Type'(Ind_Typ'Pos (L)). We qualify the
1865       --  expression to avoid universal_integer computations whenever possible,
1866       --  in the expression for the upper bound H.
1867
1868       function L_Succ return Node_Id;
1869       --  Builds expression Ind_Typ'Succ (L)
1870
1871       function One return Node_Id;
1872       --  Builds integer literal one
1873
1874       function P return Node_Id;
1875       --  Builds reference to identifier P
1876
1877       function P_Succ return Node_Id;
1878       --  Builds expression Ind_Typ'Succ (P)
1879
1880       function R return Node_Id;
1881       --  Builds reference to identifier R
1882
1883       function S (I : Nat) return Node_Id;
1884       --  Builds reference to identifier Si, where I is the value given
1885
1886       function S_First (I : Nat) return Node_Id;
1887       --  Builds expression Si'First, where I is the value given
1888
1889       function S_Last (I : Nat) return Node_Id;
1890       --  Builds expression Si'Last, where I is the value given
1891
1892       function S_Length (I : Nat) return Node_Id;
1893       --  Builds expression Si'Length, where I is the value given
1894
1895       function S_Length_Test (I : Nat) return Node_Id;
1896       --  Builds expression Si'Length /= 0, where I is the value given
1897
1898       -------------------
1899       -- Copy_Into_R_S --
1900       -------------------
1901
1902       function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
1903          Stmts     : constant List_Id := New_List;
1904          P_Start   : Node_Id;
1905          Loop_Stmt : Node_Id;
1906          R_Copy    : Node_Id;
1907          Exit_Stmt : Node_Id;
1908          L_Inc     : Node_Id;
1909          P_Inc     : Node_Id;
1910
1911       begin
1912          --  First construct the initializations
1913
1914          P_Start := Make_Assignment_Statement (Loc,
1915                       Name       => P,
1916                       Expression => S_First (I));
1917          Append_To (Stmts, P_Start);
1918
1919          --  Then build the loop
1920
1921          R_Copy := Make_Assignment_Statement (Loc,
1922                      Name       => Make_Indexed_Component (Loc,
1923                                      Prefix      => R,
1924                                      Expressions => New_List (L)),
1925                      Expression => Make_Indexed_Component (Loc,
1926                                      Prefix      => S (I),
1927                                      Expressions => New_List (P)));
1928
1929          L_Inc := Make_Assignment_Statement (Loc,
1930                     Name       => L,
1931                     Expression => L_Succ);
1932
1933          Exit_Stmt := Make_Exit_Statement (Loc,
1934                         Condition => Make_Op_Eq (Loc, P, S_Last (I)));
1935
1936          P_Inc := Make_Assignment_Statement (Loc,
1937                     Name       => P,
1938                     Expression => P_Succ);
1939
1940          if Last then
1941             Loop_Stmt :=
1942               Make_Implicit_Loop_Statement (Cnode,
1943                 Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
1944          else
1945             Loop_Stmt :=
1946               Make_Implicit_Loop_Statement (Cnode,
1947                 Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
1948          end if;
1949
1950          Append_To (Stmts, Loop_Stmt);
1951
1952          return Stmts;
1953       end Copy_Into_R_S;
1954
1955       -------
1956       -- H --
1957       -------
1958
1959       function H return Node_Id is
1960       begin
1961          return Make_Identifier (Loc, Name_uH);
1962       end H;
1963
1964       -------------
1965       -- Ind_Val --
1966       -------------
1967
1968       function Ind_Val (E : Node_Id) return Node_Id is
1969       begin
1970          return
1971            Make_Attribute_Reference (Loc,
1972              Prefix         => New_Reference_To (Ind_Typ, Loc),
1973              Attribute_Name => Name_Val,
1974              Expressions    => New_List (E));
1975       end Ind_Val;
1976
1977       ------------
1978       -- Init_L --
1979       ------------
1980
1981       function Init_L (I : Nat) return Node_Id is
1982          E : Node_Id;
1983
1984       begin
1985          if Is_Constrained (Arr_Typ) then
1986             E := Make_Attribute_Reference (Loc,
1987                    Prefix         => New_Reference_To (Arr_Typ, Loc),
1988                    Attribute_Name => Name_First);
1989
1990          else
1991             E := S_First (I);
1992          end if;
1993
1994          return Make_Assignment_Statement (Loc, Name => L, Expression => E);
1995       end Init_L;
1996
1997       -------
1998       -- L --
1999       -------
2000
2001       function L return Node_Id is
2002       begin
2003          return Make_Identifier (Loc, Name_uL);
2004       end L;
2005
2006       -----------
2007       -- L_Pos --
2008       -----------
2009
2010       function L_Pos return Node_Id is
2011          Target_Type : Entity_Id;
2012
2013       begin
2014          --  If the index type is an enumeration type, the computation
2015          --  can be done in standard integer. Otherwise, choose a large
2016          --  enough integer type.
2017
2018          if Is_Enumeration_Type (Ind_Typ)
2019            or else Root_Type (Ind_Typ) = Standard_Integer
2020            or else Root_Type (Ind_Typ) = Standard_Short_Integer
2021            or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
2022          then
2023             Target_Type := Standard_Integer;
2024          else
2025             Target_Type := Root_Type (Ind_Typ);
2026          end if;
2027
2028          return
2029            Make_Qualified_Expression (Loc,
2030               Subtype_Mark => New_Reference_To (Target_Type, Loc),
2031               Expression   =>
2032                 Make_Attribute_Reference (Loc,
2033                   Prefix         => New_Reference_To (Ind_Typ, Loc),
2034                   Attribute_Name => Name_Pos,
2035                   Expressions    => New_List (L)));
2036       end L_Pos;
2037
2038       ------------
2039       -- L_Succ --
2040       ------------
2041
2042       function L_Succ return Node_Id is
2043       begin
2044          return
2045            Make_Attribute_Reference (Loc,
2046              Prefix         => New_Reference_To (Ind_Typ, Loc),
2047              Attribute_Name => Name_Succ,
2048              Expressions    => New_List (L));
2049       end L_Succ;
2050
2051       ---------
2052       -- One --
2053       ---------
2054
2055       function One return Node_Id is
2056       begin
2057          return Make_Integer_Literal (Loc, 1);
2058       end One;
2059
2060       -------
2061       -- P --
2062       -------
2063
2064       function P return Node_Id is
2065       begin
2066          return Make_Identifier (Loc, Name_uP);
2067       end P;
2068
2069       ------------
2070       -- P_Succ --
2071       ------------
2072
2073       function P_Succ return Node_Id is
2074       begin
2075          return
2076            Make_Attribute_Reference (Loc,
2077              Prefix         => New_Reference_To (Ind_Typ, Loc),
2078              Attribute_Name => Name_Succ,
2079              Expressions    => New_List (P));
2080       end P_Succ;
2081
2082       -------
2083       -- R --
2084       -------
2085
2086       function R return Node_Id is
2087       begin
2088          return Make_Identifier (Loc, Name_uR);
2089       end R;
2090
2091       -------
2092       -- S --
2093       -------
2094
2095       function S (I : Nat) return Node_Id is
2096       begin
2097          return Make_Identifier (Loc, New_External_Name ('S', I));
2098       end S;
2099
2100       -------------
2101       -- S_First --
2102       -------------
2103
2104       function S_First (I : Nat) return Node_Id is
2105       begin
2106          return Make_Attribute_Reference (Loc,
2107                   Prefix         => S (I),
2108                   Attribute_Name => Name_First);
2109       end S_First;
2110
2111       ------------
2112       -- S_Last --
2113       ------------
2114
2115       function S_Last (I : Nat) return Node_Id is
2116       begin
2117          return Make_Attribute_Reference (Loc,
2118                   Prefix         => S (I),
2119                   Attribute_Name => Name_Last);
2120       end S_Last;
2121
2122       --------------
2123       -- S_Length --
2124       --------------
2125
2126       function S_Length (I : Nat) return Node_Id is
2127       begin
2128          return Make_Attribute_Reference (Loc,
2129                   Prefix         => S (I),
2130                   Attribute_Name => Name_Length);
2131       end S_Length;
2132
2133       -------------------
2134       -- S_Length_Test --
2135       -------------------
2136
2137       function S_Length_Test (I : Nat) return Node_Id is
2138       begin
2139          return
2140            Make_Op_Ne (Loc,
2141              Left_Opnd  => S_Length (I),
2142              Right_Opnd => Make_Integer_Literal (Loc, 0));
2143       end S_Length_Test;
2144
2145    --  Start of processing for Expand_Concatenate_Other
2146
2147    begin
2148       --  Construct the parameter specs and the overall function spec
2149
2150       Param_Specs := New_List;
2151       for I in 1 .. Nb_Opnds loop
2152          Append_To
2153            (Param_Specs,
2154             Make_Parameter_Specification (Loc,
2155               Defining_Identifier =>
2156                 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
2157               Parameter_Type      => New_Reference_To (Base_Typ, Loc)));
2158       end loop;
2159
2160       Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2161       Func_Spec :=
2162         Make_Function_Specification (Loc,
2163           Defining_Unit_Name       => Func_Id,
2164           Parameter_Specifications => Param_Specs,
2165           Subtype_Mark             => New_Reference_To (Base_Typ, Loc));
2166
2167       --  Construct L's object declaration
2168
2169       L_Decl :=
2170         Make_Object_Declaration (Loc,
2171           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
2172           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
2173
2174       Func_Decls := New_List (L_Decl);
2175
2176       --  Construct the if-then-elsif statements
2177
2178       Elsif_List := New_List;
2179       for I in 2 .. Nb_Opnds - 1 loop
2180          Append_To (Elsif_List, Make_Elsif_Part (Loc,
2181                                   Condition       => S_Length_Test (I),
2182                                   Then_Statements => New_List (Init_L (I))));
2183       end loop;
2184
2185       If_Stmt :=
2186         Make_Implicit_If_Statement (Cnode,
2187           Condition       => S_Length_Test (1),
2188           Then_Statements => New_List (Init_L (1)),
2189           Elsif_Parts     => Elsif_List,
2190           Else_Statements => New_List (Make_Return_Statement (Loc,
2191                                          Expression => S (Nb_Opnds))));
2192
2193       --  Construct the declaration for H
2194
2195       P_Decl :=
2196         Make_Object_Declaration (Loc,
2197           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
2198           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
2199
2200       H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
2201       for I in 2 .. Nb_Opnds loop
2202          H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
2203       end loop;
2204       H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
2205
2206       H_Decl :=
2207         Make_Object_Declaration (Loc,
2208           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
2209           Object_Definition   => New_Reference_To (Ind_Typ, Loc),
2210           Expression          => H_Init);
2211
2212       --  Construct the declaration for R
2213
2214       R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
2215       R_Constr :=
2216         Make_Index_Or_Discriminant_Constraint (Loc,
2217           Constraints => New_List (R_Range));
2218
2219       R_Decl :=
2220         Make_Object_Declaration (Loc,
2221           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
2222           Object_Definition   =>
2223             Make_Subtype_Indication (Loc,
2224                Subtype_Mark => New_Reference_To (Base_Typ, Loc),
2225                Constraint   => R_Constr));
2226
2227       --  Construct the declarations for the declare block
2228
2229       Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
2230
2231       --  Construct list of statements for the declare block
2232
2233       Declare_Stmts := New_List;
2234       for I in 1 .. Nb_Opnds loop
2235          Append_To (Declare_Stmts,
2236                     Make_Implicit_If_Statement (Cnode,
2237                       Condition       => S_Length_Test (I),
2238                       Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
2239       end loop;
2240
2241       Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
2242
2243       --  Construct the declare block
2244
2245       Declare_Block := Make_Block_Statement (Loc,
2246         Declarations               => Declare_Decls,
2247         Handled_Statement_Sequence =>
2248           Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
2249
2250       --  Construct the list of function statements
2251
2252       Func_Stmts := New_List (If_Stmt, Declare_Block);
2253
2254       --  Construct the function body
2255
2256       Func_Body :=
2257         Make_Subprogram_Body (Loc,
2258           Specification              => Func_Spec,
2259           Declarations               => Func_Decls,
2260           Handled_Statement_Sequence =>
2261             Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
2262
2263       --  Insert the newly generated function in the code. This is analyzed
2264       --  with all checks off, since we have completed all the checks.
2265
2266       --  Note that this does *not* fix the array concatenation bug when the
2267       --  low bound is Integer'first sibce that bug comes from the pointer
2268       --  dereferencing an unconstrained array. An there we need a constraint
2269       --  check to make sure the length of the concatenated array is ok. ???
2270
2271       Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
2272
2273       --  Construct list of arguments for the function call
2274
2275       Params := New_List;
2276       Operand  := First (Opnds);
2277       for I in 1 .. Nb_Opnds loop
2278          Append_To (Params, Relocate_Node (Operand));
2279          Next (Operand);
2280       end loop;
2281
2282       --  Insert the function call
2283
2284       Rewrite
2285         (Cnode,
2286          Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
2287
2288       Analyze_And_Resolve (Cnode, Base_Typ);
2289       Set_Is_Inlined (Func_Id);
2290    end Expand_Concatenate_Other;
2291
2292    -------------------------------
2293    -- Expand_Concatenate_String --
2294    -------------------------------
2295
2296    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
2297       Loc   : constant Source_Ptr := Sloc (Cnode);
2298       Opnd1 : constant Node_Id    := First (Opnds);
2299       Opnd2 : constant Node_Id    := Next (Opnd1);
2300       Typ1  : constant Entity_Id  := Base_Type (Etype (Opnd1));
2301       Typ2  : constant Entity_Id  := Base_Type (Etype (Opnd2));
2302
2303       R : RE_Id;
2304       --  RE_Id value for function to be called
2305
2306    begin
2307       --  In all cases, we build a call to a routine giving the list of
2308       --  arguments as the parameter list to the routine.
2309
2310       case List_Length (Opnds) is
2311          when 2 =>
2312             if Typ1 = Standard_Character then
2313                if Typ2 = Standard_Character then
2314                   R := RE_Str_Concat_CC;
2315
2316                else
2317                   pragma Assert (Typ2 = Standard_String);
2318                   R := RE_Str_Concat_CS;
2319                end if;
2320
2321             elsif Typ1 = Standard_String then
2322                if Typ2 = Standard_Character then
2323                   R := RE_Str_Concat_SC;
2324
2325                else
2326                   pragma Assert (Typ2 = Standard_String);
2327                   R := RE_Str_Concat;
2328                end if;
2329
2330             --  If we have anything other than Standard_Character or
2331             --  Standard_String, then we must have had a serious error
2332             --  earlier, so we just abandon the attempt at expansion.
2333
2334             else
2335                pragma Assert (Serious_Errors_Detected > 0);
2336                return;
2337             end if;
2338
2339          when 3 =>
2340             R := RE_Str_Concat_3;
2341
2342          when 4 =>
2343             R := RE_Str_Concat_4;
2344
2345          when 5 =>
2346             R := RE_Str_Concat_5;
2347
2348          when others =>
2349             R := RE_Null;
2350             raise Program_Error;
2351       end case;
2352
2353       --  Now generate the appropriate call
2354
2355       Rewrite (Cnode,
2356         Make_Function_Call (Sloc (Cnode),
2357           Name => New_Occurrence_Of (RTE (R), Loc),
2358           Parameter_Associations => Opnds));
2359
2360       Analyze_And_Resolve (Cnode, Standard_String);
2361
2362    exception
2363       when RE_Not_Available =>
2364          return;
2365    end Expand_Concatenate_String;
2366
2367    ------------------------
2368    -- Expand_N_Allocator --
2369    ------------------------
2370
2371    procedure Expand_N_Allocator (N : Node_Id) is
2372       PtrT  : constant Entity_Id  := Etype (N);
2373       Dtyp  : constant Entity_Id  := Designated_Type (PtrT);
2374       Desig : Entity_Id;
2375       Loc   : constant Source_Ptr := Sloc (N);
2376       Temp  : Entity_Id;
2377       Node  : Node_Id;
2378
2379    begin
2380       --  RM E.2.3(22). We enforce that the expected type of an allocator
2381       --  shall not be a remote access-to-class-wide-limited-private type
2382
2383       --  Why is this being done at expansion time, seems clearly wrong ???
2384
2385       Validate_Remote_Access_To_Class_Wide_Type (N);
2386
2387       --  Set the Storage Pool
2388
2389       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
2390
2391       if Present (Storage_Pool (N)) then
2392          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
2393             if not Java_VM then
2394                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
2395             end if;
2396
2397          elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
2398             Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
2399
2400          else
2401             Set_Procedure_To_Call (N,
2402               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
2403          end if;
2404       end if;
2405
2406       --  Under certain circumstances we can replace an allocator by an
2407       --  access to statically allocated storage. The conditions, as noted
2408       --  in AARM 3.10 (10c) are as follows:
2409
2410       --    Size and initial value is known at compile time
2411       --    Access type is access-to-constant
2412
2413       --  The allocator is not part of a constraint on a record component,
2414       --  because in that case the inserted actions are delayed until the
2415       --  record declaration is fully analyzed, which is too late for the
2416       --  analysis of the rewritten allocator.
2417
2418       if Is_Access_Constant (PtrT)
2419         and then Nkind (Expression (N)) = N_Qualified_Expression
2420         and then Compile_Time_Known_Value (Expression (Expression (N)))
2421         and then Size_Known_At_Compile_Time (Etype (Expression
2422                                                     (Expression (N))))
2423         and then not Is_Record_Type (Current_Scope)
2424       then
2425          --  Here we can do the optimization. For the allocator
2426
2427          --    new x'(y)
2428
2429          --  We insert an object declaration
2430
2431          --    Tnn : aliased x := y;
2432
2433          --  and replace the allocator by Tnn'Unrestricted_Access.
2434          --  Tnn is marked as requiring static allocation.
2435
2436          Temp :=
2437            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2438
2439          Desig := Subtype_Mark (Expression (N));
2440
2441          --  If context is constrained, use constrained subtype directly,
2442          --  so that the constant is not labelled as having a nomimally
2443          --  unconstrained subtype.
2444
2445          if Entity (Desig) = Base_Type (Dtyp) then
2446             Desig := New_Occurrence_Of (Dtyp, Loc);
2447          end if;
2448
2449          Insert_Action (N,
2450            Make_Object_Declaration (Loc,
2451              Defining_Identifier => Temp,
2452              Aliased_Present     => True,
2453              Constant_Present    => Is_Access_Constant (PtrT),
2454              Object_Definition   => Desig,
2455              Expression          => Expression (Expression (N))));
2456
2457          Rewrite (N,
2458            Make_Attribute_Reference (Loc,
2459              Prefix => New_Occurrence_Of (Temp, Loc),
2460              Attribute_Name => Name_Unrestricted_Access));
2461
2462          Analyze_And_Resolve (N, PtrT);
2463
2464          --  We set the variable as statically allocated, since we don't
2465          --  want it going on the stack of the current procedure!
2466
2467          Set_Is_Statically_Allocated (Temp);
2468          return;
2469       end if;
2470
2471       --  Handle case of qualified expression (other than optimization above)
2472
2473       if Nkind (Expression (N)) = N_Qualified_Expression then
2474          Expand_Allocator_Expression (N);
2475
2476          --  If the allocator is for a type which requires initialization, and
2477          --  there is no initial value (i.e. operand is a subtype indication
2478          --  rather than a qualifed expression), then we must generate a call
2479          --  to the initialization routine. This is done using an expression
2480          --  actions node:
2481          --
2482          --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
2483          --
2484          --  Here ptr_T is the pointer type for the allocator, and T is the
2485          --  subtype of the allocator. A special case arises if the designated
2486          --  type of the access type is a task or contains tasks. In this case
2487          --  the call to Init (Temp.all ...) is replaced by code that ensures
2488          --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
2489          --  for details). In addition, if the type T is a task T, then the
2490          --  first argument to Init must be converted to the task record type.
2491
2492       else
2493          declare
2494             T            : constant Entity_Id  := Entity (Expression (N));
2495             Init         : Entity_Id;
2496             Arg1         : Node_Id;
2497             Args         : List_Id;
2498             Decls        : List_Id;
2499             Decl         : Node_Id;
2500             Discr        : Elmt_Id;
2501             Flist        : Node_Id;
2502             Temp_Decl    : Node_Id;
2503             Temp_Type    : Entity_Id;
2504             Attach_Level : Uint;
2505
2506          begin
2507             if No_Initialization (N) then
2508                null;
2509
2510             --  Case of no initialization procedure present
2511
2512             elsif not Has_Non_Null_Base_Init_Proc (T) then
2513
2514                --  Case of simple initialization required
2515
2516                if Needs_Simple_Initialization (T) then
2517                   Rewrite (Expression (N),
2518                     Make_Qualified_Expression (Loc,
2519                       Subtype_Mark => New_Occurrence_Of (T, Loc),
2520                       Expression   => Get_Simple_Init_Val (T, Loc)));
2521
2522                   Analyze_And_Resolve (Expression (Expression (N)), T);
2523                   Analyze_And_Resolve (Expression (N), T);
2524                   Set_Paren_Count (Expression (Expression (N)), 1);
2525                   Expand_N_Allocator (N);
2526
2527                --  No initialization required
2528
2529                else
2530                   null;
2531                end if;
2532
2533             --  Case of initialization procedure present, must be called
2534
2535             else
2536                Init := Base_Init_Proc (T);
2537                Node := N;
2538                Temp :=
2539                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2540
2541                --  Construct argument list for the initialization routine call
2542                --  The CPP constructor needs the address directly
2543
2544                if Is_CPP_Class (T) then
2545                   Arg1 := New_Reference_To (Temp, Loc);
2546                   Temp_Type := T;
2547
2548                else
2549                   Arg1 :=
2550                     Make_Explicit_Dereference (Loc,
2551                       Prefix => New_Reference_To (Temp, Loc));
2552                   Set_Assignment_OK (Arg1);
2553                   Temp_Type := PtrT;
2554
2555                   --  The initialization procedure expects a specific type.
2556                   --  if the context is access to class wide, indicate that
2557                   --  the object being allocated has the right specific type.
2558
2559                   if Is_Class_Wide_Type (Dtyp) then
2560                      Arg1 := Unchecked_Convert_To (T, Arg1);
2561                   end if;
2562                end if;
2563
2564                --  If designated type is a concurrent type or if it is a
2565                --  private type whose definition is a concurrent type,
2566                --  the first argument in the Init routine has to be
2567                --  unchecked conversion to the corresponding record type.
2568                --  If the designated type is a derived type, we also
2569                --  convert the argument to its root type.
2570
2571                if Is_Concurrent_Type (T) then
2572                   Arg1 :=
2573                     Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
2574
2575                elsif Is_Private_Type (T)
2576                  and then Present (Full_View (T))
2577                  and then Is_Concurrent_Type (Full_View (T))
2578                then
2579                   Arg1 :=
2580                     Unchecked_Convert_To
2581                       (Corresponding_Record_Type (Full_View (T)), Arg1);
2582
2583                elsif Etype (First_Formal (Init)) /= Base_Type (T) then
2584
2585                   declare
2586                      Ftyp : constant Entity_Id := Etype (First_Formal (Init));
2587
2588                   begin
2589                      Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
2590                      Set_Etype (Arg1, Ftyp);
2591                   end;
2592                end if;
2593
2594                Args := New_List (Arg1);
2595
2596                --  For the task case, pass the Master_Id of the access type
2597                --  as the value of the _Master parameter, and _Chain as the
2598                --  value of the _Chain parameter (_Chain will be defined as
2599                --  part of the generated code for the allocator).
2600
2601                if Has_Task (T) then
2602                   if No (Master_Id (Base_Type (PtrT))) then
2603
2604                      --  The designated type was an incomplete type, and
2605                      --  the access type did not get expanded. Salvage
2606                      --  it now.
2607
2608                      Expand_N_Full_Type_Declaration
2609                        (Parent (Base_Type (PtrT)));
2610                   end if;
2611
2612                   --  If the context of the allocator is a declaration or
2613                   --  an assignment, we can generate a meaningful image for
2614                   --  it, even though subsequent assignments might remove
2615                   --  the connection between task and entity. We build this
2616                   --  image when the left-hand side is a simple variable,
2617                   --  a simple indexed assignment or a simple selected
2618                   --  component.
2619
2620                   if Nkind (Parent (N)) = N_Assignment_Statement then
2621                      declare
2622                         Nam : constant Node_Id := Name (Parent (N));
2623
2624                      begin
2625                         if Is_Entity_Name (Nam) then
2626                            Decls :=
2627                              Build_Task_Image_Decls (
2628                                Loc,
2629                                  New_Occurrence_Of
2630                                    (Entity (Nam), Sloc (Nam)), T);
2631
2632                         elsif (Nkind (Nam) = N_Indexed_Component
2633                                 or else Nkind (Nam) = N_Selected_Component)
2634                           and then Is_Entity_Name (Prefix (Nam))
2635                         then
2636                            Decls :=
2637                              Build_Task_Image_Decls
2638                                (Loc, Nam, Etype (Prefix (Nam)));
2639                         else
2640                            Decls := Build_Task_Image_Decls (Loc, T, T);
2641                         end if;
2642                      end;
2643
2644                   elsif Nkind (Parent (N)) = N_Object_Declaration then
2645                      Decls :=
2646                        Build_Task_Image_Decls (
2647                           Loc, Defining_Identifier (Parent (N)), T);
2648
2649                   else
2650                      Decls := Build_Task_Image_Decls (Loc, T, T);
2651                   end if;
2652
2653                   Append_To (Args,
2654                     New_Reference_To
2655                       (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
2656                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
2657
2658                   Decl := Last (Decls);
2659                   Append_To (Args,
2660                     New_Occurrence_Of (Defining_Identifier (Decl), Loc));
2661
2662                --  Has_Task is false, Decls not used
2663
2664                else
2665                   Decls := No_List;
2666                end if;
2667
2668                --  Add discriminants if discriminated type
2669
2670                if Has_Discriminants (T) then
2671                   Discr := First_Elmt (Discriminant_Constraint (T));
2672
2673                   while Present (Discr) loop
2674                      Append (New_Copy_Tree (Elists.Node (Discr)), Args);
2675                      Next_Elmt (Discr);
2676                   end loop;
2677
2678                elsif Is_Private_Type (T)
2679                  and then Present (Full_View (T))
2680                  and then Has_Discriminants (Full_View (T))
2681                then
2682                   Discr :=
2683                     First_Elmt (Discriminant_Constraint (Full_View (T)));
2684
2685                   while Present (Discr) loop
2686                      Append (New_Copy_Tree (Elists.Node (Discr)), Args);
2687                      Next_Elmt (Discr);
2688                   end loop;
2689                end if;
2690
2691                --  We set the allocator as analyzed so that when we analyze the
2692                --  expression actions node, we do not get an unwanted recursive
2693                --  expansion of the allocator expression.
2694
2695                Set_Analyzed (N, True);
2696                Node := Relocate_Node (N);
2697
2698                --  Here is the transformation:
2699                --    input:  new T
2700                --    output: Temp : constant ptr_T := new T;
2701                --            Init (Temp.all, ...);
2702                --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
2703                --    <CTRL>  Initialize (Finalizable (Temp.all));
2704
2705                --  Here ptr_T is the pointer type for the allocator, and T
2706                --  is the subtype of the allocator.
2707
2708                Temp_Decl :=
2709                  Make_Object_Declaration (Loc,
2710                    Defining_Identifier => Temp,
2711                    Constant_Present    => True,
2712                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
2713                    Expression          => Node);
2714
2715                Set_Assignment_OK (Temp_Decl);
2716
2717                if Is_CPP_Class (T) then
2718                   Set_Aliased_Present (Temp_Decl);
2719                end if;
2720
2721                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
2722
2723                --  If the designated type is task type or contains tasks,
2724                --  Create block to activate created tasks, and insert
2725                --  declaration for Task_Image variable ahead of call.
2726
2727                if Has_Task (T) then
2728                   declare
2729                      L   : constant List_Id := New_List;
2730                      Blk : Node_Id;
2731
2732                   begin
2733                      Build_Task_Allocate_Block (L, Node, Args);
2734                      Blk := Last (L);
2735
2736                      Insert_List_Before (First (Declarations (Blk)), Decls);
2737                      Insert_Actions (N, L);
2738                   end;
2739
2740                else
2741                   Insert_Action (N,
2742                     Make_Procedure_Call_Statement (Loc,
2743                       Name => New_Reference_To (Init, Loc),
2744                       Parameter_Associations => Args));
2745                end if;
2746
2747                if Controlled_Type (T) then
2748                   Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
2749                   if Ekind (PtrT) = E_Anonymous_Access_Type then
2750                      Attach_Level := Uint_1;
2751                   else
2752                      Attach_Level := Uint_2;
2753                   end if;
2754                   Insert_Actions (N,
2755                     Make_Init_Call (
2756                       Ref          => New_Copy_Tree (Arg1),
2757                       Typ          => T,
2758                       Flist_Ref    => Flist,
2759                       With_Attach  => Make_Integer_Literal (Loc,
2760                         Attach_Level)));
2761                end if;
2762
2763                if Is_CPP_Class (T) then
2764                   Rewrite (N,
2765                     Make_Attribute_Reference (Loc,
2766                       Prefix => New_Reference_To (Temp, Loc),
2767                       Attribute_Name => Name_Unchecked_Access));
2768                else
2769                   Rewrite (N, New_Reference_To (Temp, Loc));
2770                end if;
2771
2772                Analyze_And_Resolve (N, PtrT);
2773             end if;
2774          end;
2775       end if;
2776
2777    exception
2778       when RE_Not_Available =>
2779          return;
2780    end Expand_N_Allocator;
2781
2782    -----------------------
2783    -- Expand_N_And_Then --
2784    -----------------------
2785
2786    --  Expand into conditional expression if Actions present, and also
2787    --  deal with optimizing case of arguments being True or False.
2788
2789    procedure Expand_N_And_Then (N : Node_Id) is
2790       Loc     : constant Source_Ptr := Sloc (N);
2791       Typ     : constant Entity_Id  := Etype (N);
2792       Left    : constant Node_Id    := Left_Opnd (N);
2793       Right   : constant Node_Id    := Right_Opnd (N);
2794       Actlist : List_Id;
2795
2796    begin
2797       --  Deal with non-standard booleans
2798
2799       if Is_Boolean_Type (Typ) then
2800          Adjust_Condition (Left);
2801          Adjust_Condition (Right);
2802          Set_Etype (N, Standard_Boolean);
2803       end if;
2804
2805       --  Check for cases of left argument is True or False
2806
2807       if Nkind (Left) = N_Identifier then
2808
2809          --  If left argument is True, change (True and then Right) to Right.
2810          --  Any actions associated with Right will be executed unconditionally
2811          --  and can thus be inserted into the tree unconditionally.
2812
2813          if Entity (Left) = Standard_True then
2814             if Present (Actions (N)) then
2815                Insert_Actions (N, Actions (N));
2816             end if;
2817
2818             Rewrite (N, Right);
2819             Adjust_Result_Type (N, Typ);
2820             return;
2821
2822          --  If left argument is False, change (False and then Right) to
2823          --  False. In this case we can forget the actions associated with
2824          --  Right, since they will never be executed.
2825
2826          elsif Entity (Left) = Standard_False then
2827             Kill_Dead_Code (Right);
2828             Kill_Dead_Code (Actions (N));
2829             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2830             Adjust_Result_Type (N, Typ);
2831             return;
2832          end if;
2833       end if;
2834
2835       --  If Actions are present, we expand
2836
2837       --     left and then right
2838
2839       --  into
2840
2841       --     if left then right else false end
2842
2843       --  with the actions becoming the Then_Actions of the conditional
2844       --  expression. This conditional expression is then further expanded
2845       --  (and will eventually disappear)
2846
2847       if Present (Actions (N)) then
2848          Actlist := Actions (N);
2849          Rewrite (N,
2850             Make_Conditional_Expression (Loc,
2851               Expressions => New_List (
2852                 Left,
2853                 Right,
2854                 New_Occurrence_Of (Standard_False, Loc))));
2855
2856          Set_Then_Actions (N, Actlist);
2857          Analyze_And_Resolve (N, Standard_Boolean);
2858          Adjust_Result_Type (N, Typ);
2859          return;
2860       end if;
2861
2862       --  No actions present, check for cases of right argument True/False
2863
2864       if Nkind (Right) = N_Identifier then
2865
2866          --  Change (Left and then True) to Left. Note that we know there
2867          --  are no actions associated with the True operand, since we
2868          --  just checked for this case above.
2869
2870          if Entity (Right) = Standard_True then
2871             Rewrite (N, Left);
2872
2873          --  Change (Left and then False) to False, making sure to preserve
2874          --  any side effects associated with the Left operand.
2875
2876          elsif Entity (Right) = Standard_False then
2877             Remove_Side_Effects (Left);
2878             Rewrite
2879               (N, New_Occurrence_Of (Standard_False, Loc));
2880          end if;
2881       end if;
2882
2883       Adjust_Result_Type (N, Typ);
2884    end Expand_N_And_Then;
2885
2886    -------------------------------------
2887    -- Expand_N_Conditional_Expression --
2888    -------------------------------------
2889
2890    --  Expand into expression actions if then/else actions present
2891
2892    procedure Expand_N_Conditional_Expression (N : Node_Id) is
2893       Loc    : constant Source_Ptr := Sloc (N);
2894       Cond   : constant Node_Id    := First (Expressions (N));
2895       Thenx  : constant Node_Id    := Next (Cond);
2896       Elsex  : constant Node_Id    := Next (Thenx);
2897       Typ    : constant Entity_Id  := Etype (N);
2898       Cnn    : Entity_Id;
2899       New_If : Node_Id;
2900
2901    begin
2902       --  If either then or else actions are present, then given:
2903
2904       --     if cond then then-expr else else-expr end
2905
2906       --  we insert the following sequence of actions (using Insert_Actions):
2907
2908       --      Cnn : typ;
2909       --      if cond then
2910       --         <<then actions>>
2911       --         Cnn := then-expr;
2912       --      else
2913       --         <<else actions>>
2914       --         Cnn := else-expr
2915       --      end if;
2916
2917       --  and replace the conditional expression by a reference to Cnn
2918
2919       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
2920          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2921
2922          New_If :=
2923            Make_Implicit_If_Statement (N,
2924              Condition => Relocate_Node (Cond),
2925
2926              Then_Statements => New_List (
2927                Make_Assignment_Statement (Sloc (Thenx),
2928                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
2929                  Expression => Relocate_Node (Thenx))),
2930
2931              Else_Statements => New_List (
2932                Make_Assignment_Statement (Sloc (Elsex),
2933                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
2934                  Expression => Relocate_Node (Elsex))));
2935
2936          Set_Assignment_OK (Name (First (Then_Statements (New_If))));
2937          Set_Assignment_OK (Name (First (Else_Statements (New_If))));
2938
2939          if Present (Then_Actions (N)) then
2940             Insert_List_Before
2941               (First (Then_Statements (New_If)), Then_Actions (N));
2942          end if;
2943
2944          if Present (Else_Actions (N)) then
2945             Insert_List_Before
2946               (First (Else_Statements (New_If)), Else_Actions (N));
2947          end if;
2948
2949          Rewrite (N, New_Occurrence_Of (Cnn, Loc));
2950
2951          Insert_Action (N,
2952            Make_Object_Declaration (Loc,
2953              Defining_Identifier => Cnn,
2954              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
2955
2956          Insert_Action (N, New_If);
2957          Analyze_And_Resolve (N, Typ);
2958       end if;
2959    end Expand_N_Conditional_Expression;
2960
2961    -----------------------------------
2962    -- Expand_N_Explicit_Dereference --
2963    -----------------------------------
2964
2965    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
2966    begin
2967       --  The only processing required is an insertion of an explicit
2968       --  dereference call for the checked storage pool case.
2969
2970       Insert_Dereference_Action (Prefix (N));
2971    end Expand_N_Explicit_Dereference;
2972
2973    -----------------
2974    -- Expand_N_In --
2975    -----------------
2976
2977    procedure Expand_N_In (N : Node_Id) is
2978       Loc    : constant Source_Ptr := Sloc (N);
2979       Rtyp   : constant Entity_Id  := Etype (N);
2980       Lop    : constant Node_Id    := Left_Opnd (N);
2981       Rop    : constant Node_Id    := Right_Opnd (N);
2982       Static : constant Boolean    := Is_OK_Static_Expression (N);
2983
2984    begin
2985       --  If we have an explicit range, do a bit of optimization based
2986       --  on range analysis (we may be able to kill one or both checks).
2987
2988       if Nkind (Rop) = N_Range then
2989          declare
2990             Lcheck : constant Compare_Result :=
2991                        Compile_Time_Compare (Lop, Low_Bound (Rop));
2992             Ucheck : constant Compare_Result :=
2993                        Compile_Time_Compare (Lop, High_Bound (Rop));
2994
2995          begin
2996             --  If either check is known to fail, replace result
2997             --  by False, since the other check does not matter.
2998             --  Preserve the static flag for legality checks, because
2999             --  we are constant-folding beyond RM 4.9.
3000
3001             if Lcheck = LT or else Ucheck = GT then
3002                Rewrite (N,
3003                  New_Reference_To (Standard_False, Loc));
3004                Analyze_And_Resolve (N, Rtyp);
3005                Set_Is_Static_Expression (N, Static);
3006                return;
3007
3008             --  If both checks are known to succeed, replace result
3009             --  by True, since we know we are in range.
3010
3011             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
3012                Rewrite (N,
3013                  New_Reference_To (Standard_True, Loc));
3014                Analyze_And_Resolve (N, Rtyp);
3015                Set_Is_Static_Expression (N, Static);
3016                return;
3017
3018             --  If lower bound check succeeds and upper bound check is
3019             --  not known to succeed or fail, then replace the range check
3020             --  with a comparison against the upper bound.
3021
3022             elsif Lcheck in Compare_GE then
3023                Rewrite (N,
3024                  Make_Op_Le (Loc,
3025                    Left_Opnd  => Lop,
3026                    Right_Opnd => High_Bound (Rop)));
3027                Analyze_And_Resolve (N, Rtyp);
3028                return;
3029
3030             --  If upper bound check succeeds and lower bound check is
3031             --  not known to succeed or fail, then replace the range check
3032             --  with a comparison against the lower bound.
3033
3034             elsif Ucheck in Compare_LE then
3035                Rewrite (N,
3036                  Make_Op_Ge (Loc,
3037                    Left_Opnd  => Lop,
3038                    Right_Opnd => Low_Bound (Rop)));
3039                Analyze_And_Resolve (N, Rtyp);
3040                return;
3041             end if;
3042          end;
3043
3044          --  For all other cases of an explicit range, nothing to be done
3045
3046          return;
3047
3048       --  Here right operand is a subtype mark
3049
3050       else
3051          declare
3052             Typ    : Entity_Id        := Etype (Rop);
3053             Is_Acc : constant Boolean := Is_Access_Type (Typ);
3054             Obj    : Node_Id          := Lop;
3055             Cond   : Node_Id          := Empty;
3056
3057          begin
3058             Remove_Side_Effects (Obj);
3059
3060             --  For tagged type, do tagged membership operation
3061
3062             if Is_Tagged_Type (Typ) then
3063
3064                --  No expansion will be performed when Java_VM, as the
3065                --  JVM back end will handle the membership tests directly
3066                --  (tags are not explicitly represented in Java objects,
3067                --  so the normal tagged membership expansion is not what
3068                --  we want).
3069
3070                if not Java_VM then
3071                   Rewrite (N, Tagged_Membership (N));
3072                   Analyze_And_Resolve (N, Rtyp);
3073                end if;
3074
3075                return;
3076
3077             --  If type is scalar type, rewrite as x in t'first .. t'last
3078             --  This reason we do this is that the bounds may have the wrong
3079             --  type if they come from the original type definition.
3080
3081             elsif Is_Scalar_Type (Typ) then
3082                Rewrite (Rop,
3083                  Make_Range (Loc,
3084                    Low_Bound =>
3085                      Make_Attribute_Reference (Loc,
3086                        Attribute_Name => Name_First,
3087                        Prefix => New_Reference_To (Typ, Loc)),
3088
3089                    High_Bound =>
3090                      Make_Attribute_Reference (Loc,
3091                        Attribute_Name => Name_Last,
3092                        Prefix => New_Reference_To (Typ, Loc))));
3093                Analyze_And_Resolve (N, Rtyp);
3094                return;
3095
3096             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
3097             --  a membership test if the subtype mark denotes a constrained
3098             --  Unchecked_Union subtype and the expression lacks inferable
3099             --  discriminants.
3100
3101             elsif Is_Unchecked_Union (Base_Type (Typ))
3102               and then Is_Constrained (Typ)
3103               and then not Has_Inferable_Discriminants (Lop)
3104             then
3105                Insert_Action (N,
3106                  Make_Raise_Program_Error (Loc,
3107                    Reason => PE_Unchecked_Union_Restriction));
3108
3109                --  Prevent Gigi from generating incorrect code by rewriting
3110                --  the test as a standard False.
3111
3112                Rewrite (N,
3113                  New_Occurrence_Of (Standard_False, Loc));
3114
3115                return;
3116             end if;
3117
3118             --  Here we have a non-scalar type
3119
3120             if Is_Acc then
3121                Typ := Designated_Type (Typ);
3122             end if;
3123
3124             if not Is_Constrained (Typ) then
3125                Rewrite (N,
3126                  New_Reference_To (Standard_True, Loc));
3127                Analyze_And_Resolve (N, Rtyp);
3128
3129             --  For the constrained array case, we have to check the
3130             --  subscripts for an exact match if the lengths are
3131             --  non-zero (the lengths must match in any case).
3132
3133             elsif Is_Array_Type (Typ) then
3134
3135                Check_Subscripts : declare
3136                   function Construct_Attribute_Reference
3137                     (E   : Node_Id;
3138                      Nam : Name_Id;
3139                      Dim : Nat) return Node_Id;
3140                   --  Build attribute reference E'Nam(Dim)
3141
3142                   -----------------------------------
3143                   -- Construct_Attribute_Reference --
3144                   -----------------------------------
3145
3146                   function Construct_Attribute_Reference
3147                     (E   : Node_Id;
3148                      Nam : Name_Id;
3149                      Dim : Nat) return Node_Id
3150                   is
3151                   begin
3152                      return
3153                        Make_Attribute_Reference (Loc,
3154                          Prefix => E,
3155                          Attribute_Name => Nam,
3156                          Expressions => New_List (
3157                            Make_Integer_Literal (Loc, Dim)));
3158                   end Construct_Attribute_Reference;
3159
3160                --  Start processing for Check_Subscripts
3161
3162                begin
3163                   for J in 1 .. Number_Dimensions (Typ) loop
3164                      Evolve_And_Then (Cond,
3165                        Make_Op_Eq (Loc,
3166                          Left_Opnd  =>
3167                            Construct_Attribute_Reference
3168                              (Duplicate_Subexpr_No_Checks (Obj),
3169                               Name_First, J),
3170                          Right_Opnd =>
3171                            Construct_Attribute_Reference
3172                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
3173
3174                      Evolve_And_Then (Cond,
3175                        Make_Op_Eq (Loc,
3176                          Left_Opnd  =>
3177                            Construct_Attribute_Reference
3178                              (Duplicate_Subexpr_No_Checks (Obj),
3179                               Name_Last, J),
3180                          Right_Opnd =>
3181                            Construct_Attribute_Reference
3182                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
3183                   end loop;
3184
3185                   if Is_Acc then
3186                      Cond :=
3187                        Make_Or_Else (Loc,
3188                          Left_Opnd =>
3189                            Make_Op_Eq (Loc,
3190                              Left_Opnd  => Obj,
3191                              Right_Opnd => Make_Null (Loc)),
3192                          Right_Opnd => Cond);
3193                   end if;
3194
3195                   Rewrite (N, Cond);
3196                   Analyze_And_Resolve (N, Rtyp);
3197                end Check_Subscripts;
3198
3199             --  These are the cases where constraint checks may be
3200             --  required, e.g. records with possible discriminants
3201
3202             else
3203                --  Expand the test into a series of discriminant comparisons.
3204                --  The expression that is built is the negation of the one
3205                --  that is used for checking discriminant constraints.
3206
3207                Obj := Relocate_Node (Left_Opnd (N));
3208
3209                if Has_Discriminants (Typ) then
3210                   Cond := Make_Op_Not (Loc,
3211                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
3212
3213                   if Is_Acc then
3214                      Cond := Make_Or_Else (Loc,
3215                        Left_Opnd =>
3216                          Make_Op_Eq (Loc,
3217                            Left_Opnd  => Obj,
3218                            Right_Opnd => Make_Null (Loc)),
3219                        Right_Opnd => Cond);
3220                   end if;
3221
3222                else
3223                   Cond := New_Occurrence_Of (Standard_True, Loc);
3224                end if;
3225
3226                Rewrite (N, Cond);
3227                Analyze_And_Resolve (N, Rtyp);
3228             end if;
3229          end;
3230       end if;
3231    end Expand_N_In;
3232
3233    --------------------------------
3234    -- Expand_N_Indexed_Component --
3235    --------------------------------
3236
3237    procedure Expand_N_Indexed_Component (N : Node_Id) is
3238       Loc : constant Source_Ptr := Sloc (N);
3239       Typ : constant Entity_Id  := Etype (N);
3240       P   : constant Node_Id    := Prefix (N);
3241       T   : constant Entity_Id  := Etype (P);
3242
3243    begin
3244       --  A special optimization, if we have an indexed component that
3245       --  is selecting from a slice, then we can eliminate the slice,
3246       --  since, for example, x (i .. j)(k) is identical to x(k). The
3247       --  only difference is the range check required by the slice. The
3248       --  range check for the slice itself has already been generated.
3249       --  The range check for the subscripting operation is ensured
3250       --  by converting the subject to the subtype of the slice.
3251
3252       --  This optimization not only generates better code, avoiding
3253       --  slice messing especially in the packed case, but more importantly
3254       --  bypasses some problems in handling this peculiar case, for
3255       --  example, the issue of dealing specially with object renamings.
3256
3257       if Nkind (P) = N_Slice then
3258          Rewrite (N,
3259            Make_Indexed_Component (Loc,
3260              Prefix => Prefix (P),
3261              Expressions => New_List (
3262                Convert_To
3263                  (Etype (First_Index (Etype (P))),
3264                   First (Expressions (N))))));
3265          Analyze_And_Resolve (N, Typ);
3266          return;
3267       end if;
3268
3269       --  If the prefix is an access type, then we unconditionally rewrite
3270       --  if as an explicit deference. This simplifies processing for several
3271       --  cases, including packed array cases and certain cases in which
3272       --  checks must be generated. We used to try to do this only when it
3273       --  was necessary, but it cleans up the code to do it all the time.
3274
3275       if Is_Access_Type (T) then
3276          Insert_Explicit_Dereference (P);
3277          Analyze_And_Resolve (P, Designated_Type (T));
3278       end if;
3279
3280       --  Generate index and validity checks
3281
3282       Generate_Index_Checks (N);
3283
3284       if Validity_Checks_On and then Validity_Check_Subscripts then
3285          Apply_Subscript_Validity_Checks (N);
3286       end if;
3287
3288       --  All done for the non-packed case
3289
3290       if not Is_Packed (Etype (Prefix (N))) then
3291          return;
3292       end if;
3293
3294       --  For packed arrays that are not bit-packed (i.e. the case of an array
3295       --  with one or more index types with a non-coniguous enumeration type),
3296       --  we can always use the normal packed element get circuit.
3297
3298       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
3299          Expand_Packed_Element_Reference (N);
3300          return;
3301       end if;
3302
3303       --  For a reference to a component of a bit packed array, we have to
3304       --  convert it to a reference to the corresponding Packed_Array_Type.
3305       --  We only want to do this for simple references, and not for:
3306
3307       --    Left side of assignment, or prefix of left side of assignment,
3308       --    or prefix of the prefix, to handle packed arrays of packed arrays,
3309       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3310
3311       --    Renaming objects in renaming associations
3312       --      This case is handled when a use of the renamed variable occurs
3313
3314       --    Actual parameters for a procedure call
3315       --      This case is handled in Exp_Ch6.Expand_Actuals
3316
3317       --    The second expression in a 'Read attribute reference
3318
3319       --    The prefix of an address or size attribute reference
3320
3321       --  The following circuit detects these exceptions
3322
3323       declare
3324          Child : Node_Id := N;
3325          Parnt : Node_Id := Parent (N);
3326
3327       begin
3328          loop
3329             if Nkind (Parnt) = N_Unchecked_Expression then
3330                null;
3331
3332             elsif Nkind (Parnt) = N_Object_Renaming_Declaration
3333               or else Nkind (Parnt) = N_Procedure_Call_Statement
3334               or else (Nkind (Parnt) = N_Parameter_Association
3335                         and then
3336                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
3337             then
3338                return;
3339
3340             elsif Nkind (Parnt) = N_Attribute_Reference
3341               and then (Attribute_Name (Parnt) = Name_Address
3342                          or else
3343                         Attribute_Name (Parnt) = Name_Size)
3344               and then Prefix (Parnt) = Child
3345             then
3346                return;
3347
3348             elsif Nkind (Parnt) = N_Assignment_Statement
3349               and then Name (Parnt) = Child
3350             then
3351                return;
3352
3353             --  If the expression is an index of an indexed component,
3354             --  it must be expanded regardless of context.
3355
3356             elsif Nkind (Parnt) = N_Indexed_Component
3357               and then Child /= Prefix (Parnt)
3358             then
3359                Expand_Packed_Element_Reference (N);
3360                return;
3361
3362             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
3363               and then Name (Parent (Parnt)) = Parnt
3364             then
3365                return;
3366
3367             elsif Nkind (Parnt) = N_Attribute_Reference
3368               and then Attribute_Name (Parnt) = Name_Read
3369               and then Next (First (Expressions (Parnt))) = Child
3370             then
3371                return;
3372
3373             elsif (Nkind (Parnt) = N_Indexed_Component
3374                     or else Nkind (Parnt) = N_Selected_Component)
3375                and then Prefix (Parnt) = Child
3376             then
3377                null;
3378
3379             else
3380                Expand_Packed_Element_Reference (N);
3381                return;
3382             end if;
3383
3384             --  Keep looking up tree for unchecked expression, or if we are
3385             --  the prefix of a possible assignment left side.
3386
3387             Child := Parnt;
3388             Parnt := Parent (Child);
3389          end loop;
3390       end;
3391
3392    end Expand_N_Indexed_Component;
3393
3394    ---------------------
3395    -- Expand_N_Not_In --
3396    ---------------------
3397
3398    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
3399    --  can be done. This avoids needing to duplicate this expansion code.
3400
3401    procedure Expand_N_Not_In (N : Node_Id) is
3402       Loc  : constant Source_Ptr := Sloc (N);
3403       Typ  : constant Entity_Id  := Etype (N);
3404
3405    begin
3406       Rewrite (N,
3407         Make_Op_Not (Loc,
3408           Right_Opnd =>
3409             Make_In (Loc,
3410               Left_Opnd  => Left_Opnd (N),
3411               Right_Opnd => Right_Opnd (N))));
3412       Analyze_And_Resolve (N, Typ);
3413    end Expand_N_Not_In;
3414
3415    -------------------
3416    -- Expand_N_Null --
3417    -------------------
3418
3419    --  The only replacement required is for the case of a null of type
3420    --  that is an access to protected subprogram. We represent such
3421    --  access values as a record, and so we must replace the occurrence
3422    --  of null by the equivalent record (with a null address and a null
3423    --  pointer in it), so that the backend creates the proper value.
3424
3425    procedure Expand_N_Null (N : Node_Id) is
3426       Loc : constant Source_Ptr := Sloc (N);
3427       Typ : constant Entity_Id  := Etype (N);
3428       Agg : Node_Id;
3429
3430    begin
3431       if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
3432          Agg :=
3433            Make_Aggregate (Loc,
3434              Expressions => New_List (
3435                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
3436                Make_Null (Loc)));
3437
3438          Rewrite (N, Agg);
3439          Analyze_And_Resolve (N, Equivalent_Type (Typ));
3440
3441          --  For subsequent semantic analysis, the node must retain its
3442          --  type. Gigi in any case replaces this type by the corresponding
3443          --  record type before processing the node.
3444
3445          Set_Etype (N, Typ);
3446       end if;
3447
3448    exception
3449       when RE_Not_Available =>
3450          return;
3451    end Expand_N_Null;
3452
3453    ---------------------
3454    -- Expand_N_Op_Abs --
3455    ---------------------
3456
3457    procedure Expand_N_Op_Abs (N : Node_Id) is
3458       Loc  : constant Source_Ptr := Sloc (N);
3459       Expr : constant Node_Id := Right_Opnd (N);
3460
3461    begin
3462       Unary_Op_Validity_Checks (N);
3463
3464       --  Deal with software overflow checking
3465
3466       if not Backend_Overflow_Checks_On_Target
3467          and then Is_Signed_Integer_Type (Etype (N))
3468          and then Do_Overflow_Check (N)
3469       then
3470          --  The only case to worry about is when the argument is
3471          --  equal to the largest negative number, so what we do is
3472          --  to insert the check:
3473
3474          --     [constraint_error when Expr = typ'Base'First]
3475
3476          --  with the usual Duplicate_Subexpr use coding for expr
3477
3478          Insert_Action (N,
3479            Make_Raise_Constraint_Error (Loc,
3480              Condition =>
3481                Make_Op_Eq (Loc,
3482                  Left_Opnd  => Duplicate_Subexpr (Expr),
3483                  Right_Opnd =>
3484                    Make_Attribute_Reference (Loc,
3485                      Prefix =>
3486                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
3487                      Attribute_Name => Name_First)),
3488              Reason => CE_Overflow_Check_Failed));
3489       end if;
3490
3491       --  Vax floating-point types case
3492
3493       if Vax_Float (Etype (N)) then
3494          Expand_Vax_Arith (N);
3495       end if;
3496    end Expand_N_Op_Abs;
3497
3498    ---------------------
3499    -- Expand_N_Op_Add --
3500    ---------------------
3501
3502    procedure Expand_N_Op_Add (N : Node_Id) is
3503       Typ : constant Entity_Id := Etype (N);
3504
3505    begin
3506       Binary_Op_Validity_Checks (N);
3507
3508       --  N + 0 = 0 + N = N for integer types
3509
3510       if Is_Integer_Type (Typ) then
3511          if Compile_Time_Known_Value (Right_Opnd (N))
3512            and then Expr_Value (Right_Opnd (N)) = Uint_0
3513          then
3514             Rewrite (N, Left_Opnd (N));
3515             return;
3516
3517          elsif Compile_Time_Known_Value (Left_Opnd (N))
3518            and then Expr_Value (Left_Opnd (N)) = Uint_0
3519          then
3520             Rewrite (N, Right_Opnd (N));
3521             return;
3522          end if;
3523       end if;
3524
3525       --  Arithmetic overflow checks for signed integer/fixed point types
3526
3527       if Is_Signed_Integer_Type (Typ)
3528         or else Is_Fixed_Point_Type (Typ)
3529       then
3530          Apply_Arithmetic_Overflow_Check (N);
3531          return;
3532
3533       --  Vax floating-point types case
3534
3535       elsif Vax_Float (Typ) then
3536          Expand_Vax_Arith (N);
3537       end if;
3538    end Expand_N_Op_Add;
3539
3540    ---------------------
3541    -- Expand_N_Op_And --
3542    ---------------------
3543
3544    procedure Expand_N_Op_And (N : Node_Id) is
3545       Typ : constant Entity_Id := Etype (N);
3546
3547    begin
3548       Binary_Op_Validity_Checks (N);
3549
3550       if Is_Array_Type (Etype (N)) then
3551          Expand_Boolean_Operator (N);
3552
3553       elsif Is_Boolean_Type (Etype (N)) then
3554          Adjust_Condition (Left_Opnd (N));
3555          Adjust_Condition (Right_Opnd (N));
3556          Set_Etype (N, Standard_Boolean);
3557          Adjust_Result_Type (N, Typ);
3558       end if;
3559    end Expand_N_Op_And;
3560
3561    ------------------------
3562    -- Expand_N_Op_Concat --
3563    ------------------------
3564
3565    Max_Available_String_Operands : Int := -1;
3566    --  This is initialized the first time this routine is called. It records
3567    --  a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3568    --  available in the run-time:
3569    --
3570    --    0  None available
3571    --    2  RE_Str_Concat available, RE_Str_Concat_3 not available
3572    --    3  RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3573    --    4  RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3574    --    5  All routines including RE_Str_Concat_5 available
3575
3576    Char_Concat_Available : Boolean;
3577    --  Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3578    --  all three are available, False if any one of these is unavailable.
3579
3580    procedure Expand_N_Op_Concat (N : Node_Id) is
3581       Opnds : List_Id;
3582       --  List of operands to be concatenated
3583
3584       Opnd  : Node_Id;
3585       --  Single operand for concatenation
3586
3587       Cnode : Node_Id;
3588       --  Node which is to be replaced by the result of concatenating
3589       --  the nodes in the list Opnds.
3590
3591       Atyp : Entity_Id;
3592       --  Array type of concatenation result type
3593
3594       Ctyp : Entity_Id;
3595       --  Component type of concatenation represented by Cnode
3596
3597    begin
3598       --  Initialize global variables showing run-time status
3599
3600       if Max_Available_String_Operands < 1 then
3601          if not RTE_Available (RE_Str_Concat) then
3602             Max_Available_String_Operands := 0;
3603          elsif not RTE_Available (RE_Str_Concat_3) then
3604             Max_Available_String_Operands := 2;
3605          elsif not RTE_Available (RE_Str_Concat_4) then
3606             Max_Available_String_Operands := 3;
3607          elsif not RTE_Available (RE_Str_Concat_5) then
3608             Max_Available_String_Operands := 4;
3609          else
3610             Max_Available_String_Operands := 5;
3611          end if;
3612
3613          Char_Concat_Available :=
3614            RTE_Available (RE_Str_Concat_CC)
3615              and then
3616            RTE_Available (RE_Str_Concat_CS)
3617              and then
3618            RTE_Available (RE_Str_Concat_SC);
3619       end if;
3620
3621       --  Ensure validity of both operands
3622
3623       Binary_Op_Validity_Checks (N);
3624
3625       --  If we are the left operand of a concatenation higher up the
3626       --  tree, then do nothing for now, since we want to deal with a
3627       --  series of concatenations as a unit.
3628
3629       if Nkind (Parent (N)) = N_Op_Concat
3630         and then N = Left_Opnd (Parent (N))
3631       then
3632          return;
3633       end if;
3634
3635       --  We get here with a concatenation whose left operand may be a
3636       --  concatenation itself with a consistent type. We need to process
3637       --  these concatenation operands from left to right, which means
3638       --  from the deepest node in the tree to the highest node.
3639
3640       Cnode := N;
3641       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
3642          Cnode := Left_Opnd (Cnode);
3643       end loop;
3644
3645       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
3646       --  nodes above, so now we process bottom up, doing the operations. We
3647       --  gather a string that is as long as possible up to five operands
3648
3649       --  The outer loop runs more than once if there are more than five
3650       --  concatenations of type Standard.String, the most we handle for
3651       --  this case, or if more than one concatenation type is involved.
3652
3653       Outer : loop
3654          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
3655          Set_Parent (Opnds, N);
3656
3657          --  The inner loop gathers concatenation operands. We gather any
3658          --  number of these in the non-string case, or if no concatenation
3659          --  routines are available for string (since in that case we will
3660          --  treat string like any other non-string case). Otherwise we only
3661          --  gather as many operands as can be handled by the available
3662          --  procedures in the run-time library (normally 5, but may be
3663          --  less for the configurable run-time case).
3664
3665          Inner : while Cnode /= N
3666                    and then (Base_Type (Etype (Cnode)) /= Standard_String
3667                                or else
3668                              Max_Available_String_Operands = 0
3669                                or else
3670                              List_Length (Opnds) <
3671                                                Max_Available_String_Operands)
3672                    and then Base_Type (Etype (Cnode)) =
3673                             Base_Type (Etype (Parent (Cnode)))
3674          loop
3675             Cnode := Parent (Cnode);
3676             Append (Right_Opnd (Cnode), Opnds);
3677          end loop Inner;
3678
3679          --  Here we process the collected operands. First we convert
3680          --  singleton operands to singleton aggregates. This is skipped
3681          --  however for the case of two operands of type String, since
3682          --  we have special routines for these cases.
3683
3684          Atyp := Base_Type (Etype (Cnode));
3685          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
3686
3687          if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
3688            or else not Char_Concat_Available
3689          then
3690             Opnd := First (Opnds);
3691             loop
3692                if Base_Type (Etype (Opnd)) = Ctyp then
3693                   Rewrite (Opnd,
3694                     Make_Aggregate (Sloc (Cnode),
3695                       Expressions => New_List (Relocate_Node (Opnd))));
3696                   Analyze_And_Resolve (Opnd, Atyp);
3697                end if;
3698
3699                Next (Opnd);
3700                exit when No (Opnd);
3701             end loop;
3702          end if;
3703
3704          --  Now call appropriate continuation routine
3705
3706          if Atyp = Standard_String
3707            and then Max_Available_String_Operands > 0
3708          then
3709             Expand_Concatenate_String (Cnode, Opnds);
3710          else
3711             Expand_Concatenate_Other (Cnode, Opnds);
3712          end if;
3713
3714          exit Outer when Cnode = N;
3715          Cnode := Parent (Cnode);
3716       end loop Outer;
3717    end Expand_N_Op_Concat;
3718
3719    ------------------------
3720    -- Expand_N_Op_Divide --
3721    ------------------------
3722
3723    procedure Expand_N_Op_Divide (N : Node_Id) is
3724       Loc  : constant Source_Ptr := Sloc (N);
3725       Ltyp : constant Entity_Id  := Etype (Left_Opnd (N));
3726       Rtyp : constant Entity_Id  := Etype (Right_Opnd (N));
3727       Typ  : Entity_Id           := Etype (N);
3728
3729    begin
3730       Binary_Op_Validity_Checks (N);
3731
3732       --  Vax_Float is a special case
3733
3734       if Vax_Float (Typ) then
3735          Expand_Vax_Arith (N);
3736          return;
3737       end if;
3738
3739       --  N / 1 = N for integer types
3740
3741       if Is_Integer_Type (Typ)
3742         and then Compile_Time_Known_Value (Right_Opnd (N))
3743         and then Expr_Value (Right_Opnd (N)) = Uint_1
3744       then
3745          Rewrite (N, Left_Opnd (N));
3746          return;
3747       end if;
3748
3749       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3750       --  Is_Power_Of_2_For_Shift is set means that we know that our left
3751       --  operand is an unsigned integer, as required for this to work.
3752
3753       if Nkind (Right_Opnd (N)) = N_Op_Expon
3754         and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
3755
3756       --  We cannot do this transformation in configurable run time mode if we
3757       --  have 64-bit --  integers and long shifts are not available.
3758
3759         and then
3760           (Esize (Ltyp) <= 32
3761              or else Support_Long_Shifts_On_Target)
3762       then
3763          Rewrite (N,
3764            Make_Op_Shift_Right (Loc,
3765              Left_Opnd  => Left_Opnd (N),
3766              Right_Opnd =>
3767                Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
3768          Analyze_And_Resolve (N, Typ);
3769          return;
3770       end if;
3771
3772       --  Do required fixup of universal fixed operation
3773
3774       if Typ = Universal_Fixed then
3775          Fixup_Universal_Fixed_Operation (N);
3776          Typ := Etype (N);
3777       end if;
3778
3779       --  Divisions with fixed-point results
3780
3781       if Is_Fixed_Point_Type (Typ) then
3782
3783          --  No special processing if Treat_Fixed_As_Integer is set,
3784          --  since from a semantic point of view such operations are
3785          --  simply integer operations and will be treated that way.
3786
3787          if not Treat_Fixed_As_Integer (N) then
3788             if Is_Integer_Type (Rtyp) then
3789                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
3790             else
3791                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
3792             end if;
3793          end if;
3794
3795       --  Other cases of division of fixed-point operands. Again we
3796       --  exclude the case where Treat_Fixed_As_Integer is set.
3797
3798       elsif (Is_Fixed_Point_Type (Ltyp) or else
3799              Is_Fixed_Point_Type (Rtyp))
3800         and then not Treat_Fixed_As_Integer (N)
3801       then
3802          if Is_Integer_Type (Typ) then
3803             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
3804          else
3805             pragma Assert (Is_Floating_Point_Type (Typ));
3806             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
3807          end if;
3808
3809       --  Mixed-mode operations can appear in a non-static universal
3810       --  context, in  which case the integer argument must be converted
3811       --  explicitly.
3812
3813       elsif Typ = Universal_Real
3814         and then Is_Integer_Type (Rtyp)
3815       then
3816          Rewrite (Right_Opnd (N),
3817            Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
3818
3819          Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
3820
3821       elsif Typ = Universal_Real
3822         and then Is_Integer_Type (Ltyp)
3823       then
3824          Rewrite (Left_Opnd (N),
3825            Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
3826
3827          Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
3828
3829       --  Non-fixed point cases, do zero divide and overflow checks
3830
3831       elsif Is_Integer_Type (Typ) then
3832          Apply_Divide_Check (N);
3833
3834          --  Check for 64-bit division available
3835
3836          if Esize (Ltyp) > 32
3837            and then not Support_64_Bit_Divides_On_Target
3838          then
3839             Error_Msg_CRT ("64-bit division", N);
3840          end if;
3841       end if;
3842    end Expand_N_Op_Divide;
3843
3844    --------------------
3845    -- Expand_N_Op_Eq --
3846    --------------------
3847
3848    procedure Expand_N_Op_Eq (N : Node_Id) is
3849       Loc    : constant Source_Ptr := Sloc (N);
3850       Typ    : constant Entity_Id  := Etype (N);
3851       Lhs    : constant Node_Id    := Left_Opnd (N);
3852       Rhs    : constant Node_Id    := Right_Opnd (N);
3853       Bodies : constant List_Id    := New_List;
3854       A_Typ  : constant Entity_Id  := Etype (Lhs);
3855
3856       Typl    : Entity_Id := A_Typ;
3857       Op_Name : Entity_Id;
3858       Prim    : Elmt_Id;
3859
3860       procedure Build_Equality_Call (Eq : Entity_Id);
3861       --  If a constructed equality exists for the type or for its parent,
3862       --  build and analyze call, adding conversions if the operation is
3863       --  inherited.
3864
3865       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
3866       --  Determines whether a type has a subcompoment of an unconstrained
3867       --  Unchecked_Union subtype. Typ is a record type.
3868
3869       -------------------------
3870       -- Build_Equality_Call --
3871       -------------------------
3872
3873       procedure Build_Equality_Call (Eq : Entity_Id) is
3874          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
3875          L_Exp   : Node_Id := Relocate_Node (Lhs);
3876          R_Exp   : Node_Id := Relocate_Node (Rhs);
3877
3878       begin
3879          if Base_Type (Op_Type) /= Base_Type (A_Typ)
3880            and then not Is_Class_Wide_Type (A_Typ)
3881          then
3882             L_Exp := OK_Convert_To (Op_Type, L_Exp);
3883             R_Exp := OK_Convert_To (Op_Type, R_Exp);
3884          end if;
3885
3886          --  If we have an Unchecked_Union, we need to add the inferred
3887          --  discriminant values as actuals in the function call. At this
3888          --  point, the expansion has determined that both operands have
3889          --  inferable discriminants.
3890
3891          if Is_Unchecked_Union (Op_Type) then
3892             declare
3893                Lhs_Type      : constant Node_Id := Etype (L_Exp);
3894                Rhs_Type      : constant Node_Id := Etype (R_Exp);
3895                Lhs_Discr_Val : Node_Id;
3896                Rhs_Discr_Val : Node_Id;
3897
3898             begin
3899                --  Per-object constrained selected components require special
3900                --  attention. If the enclosing scope of the component is an
3901                --  Unchecked_Union, we can not reference its discriminants
3902                --  directly. This is why we use the two extra parameters of
3903                --  the equality function of the enclosing Unchecked_Union.
3904
3905                --  type UU_Type (Discr : Integer := 0) is
3906                --     . . .
3907                --  end record;
3908                --  pragma Unchecked_Union (UU_Type);
3909
3910                --  1. Unchecked_Union enclosing record:
3911
3912                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
3913                --        . . .
3914                --        Comp : UU_Type (Discr);
3915                --        . . .
3916                --     end Enclosing_UU_Type;
3917                --     pragma Unchecked_Union (Enclosing_UU_Type);
3918
3919                --     Obj1 : Enclosing_UU_Type;
3920                --     Obj2 : Enclosing_UU_Type (1);
3921
3922                --     [. . .] Obj1 = Obj2 [. . .]
3923
3924                --     Generated code:
3925
3926                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
3927
3928                --  A and B are the formal parameters of the equality function
3929                --  of Enclosing_UU_Type. The function always has two extra
3930                --  formals to capture the inferred discriminant values.
3931
3932                --  2. Non-Unchecked_Union enclosing record:
3933
3934                --     type
3935                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
3936                --     is record
3937                --        . . .
3938                --        Comp : UU_Type (Discr);
3939                --        . . .
3940                --     end Enclosing_Non_UU_Type;
3941
3942                --     Obj1 : Enclosing_Non_UU_Type;
3943                --     Obj2 : Enclosing_Non_UU_Type (1);
3944
3945                --     . . . Obj1 = Obj2 . . .
3946
3947                --     Generated code:
3948
3949                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
3950                --                        obj1.discr, obj2.discr)) then
3951
3952                --  In this case we can directly reference the discriminants of
3953                --  the enclosing record.
3954
3955                --  Lhs of equality
3956
3957                if Nkind (Lhs) = N_Selected_Component
3958                  and then Has_Per_Object_Constraint
3959                             (Entity (Selector_Name (Lhs)))
3960                then
3961                   --  Enclosing record is an Unchecked_Union, use formal A
3962
3963                   if Is_Unchecked_Union (Scope
3964                        (Entity (Selector_Name (Lhs))))
3965                   then
3966                      Lhs_Discr_Val :=
3967                        Make_Identifier (Loc,
3968                          Chars => Name_A);
3969
3970                   --  Enclosing record is of a non-Unchecked_Union type, it is
3971                   --  possible to reference the discriminant.
3972
3973                   else
3974                      Lhs_Discr_Val :=
3975                        Make_Selected_Component (Loc,
3976                          Prefix => Prefix (Lhs),
3977                          Selector_Name =>
3978                            New_Copy
3979                              (Get_Discriminant_Value
3980                                 (First_Discriminant (Lhs_Type),
3981                                  Lhs_Type,
3982                                  Stored_Constraint (Lhs_Type))));
3983                   end if;
3984
3985                --  Comment needed here ???
3986
3987                else
3988                   --  Infer the discriminant value
3989
3990                   Lhs_Discr_Val :=
3991                     New_Copy
3992                       (Get_Discriminant_Value
3993                          (First_Discriminant (Lhs_Type),
3994                           Lhs_Type,
3995                           Stored_Constraint (Lhs_Type)));
3996                end if;
3997
3998                --  Rhs of equality
3999
4000                if Nkind (Rhs) = N_Selected_Component
4001                  and then Has_Per_Object_Constraint
4002                             (Entity (Selector_Name (Rhs)))
4003                then
4004                   if Is_Unchecked_Union
4005                        (Scope (Entity (Selector_Name (Rhs))))
4006                   then
4007                      Rhs_Discr_Val :=
4008                        Make_Identifier (Loc,
4009                          Chars => Name_B);
4010
4011                   else
4012                      Rhs_Discr_Val :=
4013                        Make_Selected_Component (Loc,
4014                          Prefix => Prefix (Rhs),
4015                          Selector_Name =>
4016                            New_Copy (Get_Discriminant_Value (
4017                              First_Discriminant (Rhs_Type),
4018                              Rhs_Type,
4019                              Stored_Constraint (Rhs_Type))));
4020
4021                   end if;
4022                else
4023                   Rhs_Discr_Val :=
4024                     New_Copy (Get_Discriminant_Value (
4025                       First_Discriminant (Rhs_Type),
4026                       Rhs_Type,
4027                       Stored_Constraint (Rhs_Type)));
4028
4029                end if;
4030
4031                Rewrite (N,
4032                  Make_Function_Call (Loc,
4033                    Name => New_Reference_To (Eq, Loc),
4034                    Parameter_Associations => New_List (
4035                      L_Exp,
4036                      R_Exp,
4037                      Lhs_Discr_Val,
4038                      Rhs_Discr_Val)));
4039             end;
4040
4041          --  Normal case, not an unchecked union
4042
4043          else
4044             Rewrite (N,
4045               Make_Function_Call (Loc,
4046                 Name => New_Reference_To (Eq, Loc),
4047                 Parameter_Associations => New_List (L_Exp, R_Exp)));
4048          end if;
4049
4050          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4051       end Build_Equality_Call;
4052
4053       ------------------------------------
4054       -- Has_Unconstrained_UU_Component --
4055       ------------------------------------
4056
4057       function Has_Unconstrained_UU_Component
4058         (Typ : Node_Id) return Boolean
4059       is
4060          Tdef  : constant Node_Id :=
4061                    Type_Definition (Declaration_Node (Typ));
4062          Clist : Node_Id;
4063          Vpart : Node_Id;
4064
4065          function Component_Is_Unconstrained_UU
4066            (Comp : Node_Id) return Boolean;
4067          --  Determines whether the subtype of the component is an
4068          --  unconstrained Unchecked_Union.
4069
4070          function Variant_Is_Unconstrained_UU
4071            (Variant : Node_Id) return Boolean;
4072          --  Determines whether a component of the variant has an unconstrained
4073          --  Unchecked_Union subtype.
4074
4075          -----------------------------------
4076          -- Component_Is_Unconstrained_UU --
4077          -----------------------------------
4078
4079          function Component_Is_Unconstrained_UU
4080            (Comp : Node_Id) return Boolean
4081          is
4082          begin
4083             if Nkind (Comp) /= N_Component_Declaration then
4084                return False;
4085             end if;
4086
4087             declare
4088                Sindic : constant Node_Id :=
4089                           Subtype_Indication (Component_Definition (Comp));
4090
4091             begin
4092                --  Unconstrained nominal type. In the case of a constraint
4093                --  present, the node kind would have been N_Subtype_Indication.
4094
4095                if Nkind (Sindic) = N_Identifier then
4096                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
4097                end if;
4098
4099                return False;
4100             end;
4101          end Component_Is_Unconstrained_UU;
4102
4103          ---------------------------------
4104          -- Variant_Is_Unconstrained_UU --
4105          ---------------------------------
4106
4107          function Variant_Is_Unconstrained_UU
4108            (Variant : Node_Id) return Boolean
4109          is
4110             Clist : constant Node_Id := Component_List (Variant);
4111
4112          begin
4113             if Is_Empty_List (Component_Items (Clist)) then
4114                return False;
4115             end if;
4116
4117             declare
4118                Comp : Node_Id := First (Component_Items (Clist));
4119
4120             begin
4121                while Present (Comp) loop
4122
4123                   --  One component is sufficent
4124
4125                   if Component_Is_Unconstrained_UU (Comp) then
4126                      return True;
4127                   end if;
4128
4129                   Next (Comp);
4130                end loop;
4131             end;
4132
4133             --  None of the components withing the variant were of
4134             --  unconstrained Unchecked_Union type.
4135
4136             return False;
4137          end Variant_Is_Unconstrained_UU;
4138
4139       --  Start of processing for Has_Unconstrained_UU_Component
4140
4141       begin
4142          if Null_Present (Tdef) then
4143             return False;
4144          end if;
4145
4146          Clist := Component_List (Tdef);
4147          Vpart := Variant_Part (Clist);
4148
4149          --  Inspect available components
4150
4151          if Present (Component_Items (Clist)) then
4152             declare
4153                Comp : Node_Id := First (Component_Items (Clist));
4154
4155             begin
4156                while Present (Comp) loop
4157
4158                   --  One component is sufficent
4159
4160                   if Component_Is_Unconstrained_UU (Comp) then
4161                      return True;
4162                   end if;
4163
4164                   Next (Comp);
4165                end loop;
4166             end;
4167          end if;
4168
4169          --  Inspect available components withing variants
4170
4171          if Present (Vpart) then
4172             declare
4173                Variant : Node_Id := First (Variants (Vpart));
4174
4175             begin
4176                while Present (Variant) loop
4177
4178                   --  One component within a variant is sufficent
4179
4180                   if Variant_Is_Unconstrained_UU (Variant) then
4181                      return True;
4182                   end if;
4183
4184                   Next (Variant);
4185                end loop;
4186             end;
4187          end if;
4188
4189          --  Neither the available components, nor the components inside the
4190          --  variant parts were of an unconstrained Unchecked_Union subtype.
4191
4192          return False;
4193       end Has_Unconstrained_UU_Component;
4194
4195    --  Start of processing for Expand_N_Op_Eq
4196
4197    begin
4198       Binary_Op_Validity_Checks (N);
4199
4200       if Ekind (Typl) = E_Private_Type then
4201          Typl := Underlying_Type (Typl);
4202
4203       elsif Ekind (Typl) = E_Private_Subtype then
4204          Typl := Underlying_Type (Base_Type (Typl));
4205       end if;
4206
4207       --  It may happen in error situations that the underlying type is not
4208       --  set. The error will be detected later, here we just defend the
4209       --  expander code.
4210
4211       if No (Typl) then
4212          return;
4213       end if;
4214
4215       Typl := Base_Type (Typl);
4216
4217       --  Vax float types
4218
4219       if Vax_Float (Typl) then
4220          Expand_Vax_Comparison (N);
4221          return;
4222
4223       --  Boolean types (requiring handling of non-standard case)
4224
4225       elsif Is_Boolean_Type (Typl) then
4226          Adjust_Condition (Left_Opnd (N));
4227          Adjust_Condition (Right_Opnd (N));
4228          Set_Etype (N, Standard_Boolean);
4229          Adjust_Result_Type (N, Typ);
4230
4231       --  Array types
4232
4233       elsif Is_Array_Type (Typl) then
4234
4235          --  If we are doing full validity checking, then expand out array
4236          --  comparisons to make sure that we check the array elements.
4237
4238          if Validity_Check_Operands then
4239             declare
4240                Save_Force_Validity_Checks : constant Boolean :=
4241                                               Force_Validity_Checks;
4242             begin
4243                Force_Validity_Checks := True;
4244                Rewrite (N,
4245                  Expand_Array_Equality
4246                   (N,
4247                    Relocate_Node (Lhs),
4248                    Relocate_Node (Rhs),
4249                    Bodies,
4250                    Typl));
4251                Insert_Actions (N, Bodies);
4252                Analyze_And_Resolve (N, Standard_Boolean);
4253                Force_Validity_Checks := Save_Force_Validity_Checks;
4254             end;
4255
4256          --  Packed case
4257
4258          elsif Is_Bit_Packed_Array (Typl) then
4259             Expand_Packed_Eq (N);
4260
4261          --  Where the component type is elementary we can use a block bit
4262          --  comparison (if supported on the target) exception in the case
4263          --  of floating-point (negative zero issues require element by
4264          --  element comparison), and atomic types (where we must be sure
4265          --  to load elements independently).
4266
4267          elsif Is_Elementary_Type (Component_Type (Typl))
4268            and then not Is_Floating_Point_Type (Component_Type (Typl))
4269            and then not Is_Atomic (Component_Type (Typl))
4270            and then Support_Composite_Compare_On_Target
4271          then
4272             null;
4273
4274          --  For composite and floating-point cases, expand equality loop
4275          --  to make sure of using proper comparisons for tagged types,
4276          --  and correctly handling the floating-point case.
4277
4278          else
4279             Rewrite (N,
4280               Expand_Array_Equality
4281                 (N,
4282                  Relocate_Node (Lhs),
4283                  Relocate_Node (Rhs),
4284                  Bodies,
4285                  Typl));
4286             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
4287             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4288          end if;
4289
4290       --  Record Types
4291
4292       elsif Is_Record_Type (Typl) then
4293
4294          --  For tagged types, use the primitive "="
4295
4296          if Is_Tagged_Type (Typl) then
4297
4298             --  If this is derived from an untagged private type completed
4299             --  with a tagged type, it does not have a full view, so we
4300             --  use the primitive operations of the private type.
4301             --  This check should no longer be necessary when these
4302             --  types receive their full views ???
4303
4304             if Is_Private_Type (A_Typ)
4305               and then not Is_Tagged_Type (A_Typ)
4306               and then Is_Derived_Type (A_Typ)
4307               and then No (Full_View (A_Typ))
4308             then
4309                --  Search for equality operation, checking that the
4310                --  operands have the same type. Note that we must find
4311                --  a matching entry, or something is very wrong!
4312
4313                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
4314
4315                while Present (Prim) loop
4316                   exit when Chars (Node (Prim)) = Name_Op_Eq
4317                     and then Etype (First_Formal (Node (Prim))) =
4318                              Etype (Next_Formal (First_Formal (Node (Prim))))
4319                     and then
4320                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
4321
4322                   Next_Elmt (Prim);
4323                end loop;
4324
4325                pragma Assert (Present (Prim));
4326                Op_Name := Node (Prim);
4327
4328             --  Find the type's predefined equality or an overriding
4329             --  user-defined equality. The reason for not simply calling
4330             --  Find_Prim_Op here is that there may be a user-defined
4331             --  overloaded equality op that precedes the equality that
4332             --  we want, so we have to explicitly search (e.g., there
4333             --  could be an equality with two different parameter types).
4334
4335             else
4336                if Is_Class_Wide_Type (Typl) then
4337                   Typl := Root_Type (Typl);
4338                end if;
4339
4340                Prim := First_Elmt (Primitive_Operations (Typl));
4341                while Present (Prim) loop
4342                   exit when Chars (Node (Prim)) = Name_Op_Eq
4343                     and then Etype (First_Formal (Node (Prim))) =
4344                              Etype (Next_Formal (First_Formal (Node (Prim))))
4345                     and then
4346                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
4347
4348                   Next_Elmt (Prim);
4349                end loop;
4350
4351                pragma Assert (Present (Prim));
4352                Op_Name := Node (Prim);
4353             end if;
4354
4355             Build_Equality_Call (Op_Name);
4356
4357          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
4358          --  predefined equality operator for a type which has a subcomponent
4359          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
4360
4361          elsif Has_Unconstrained_UU_Component (Typl) then
4362             Insert_Action (N,
4363               Make_Raise_Program_Error (Loc,
4364                 Reason => PE_Unchecked_Union_Restriction));
4365
4366             --  Prevent Gigi from generating incorrect code by rewriting the
4367             --  equality as a standard False.
4368
4369             Rewrite (N,
4370               New_Occurrence_Of (Standard_False, Loc));
4371
4372          elsif Is_Unchecked_Union (Typl) then
4373
4374             --  If we can infer the discriminants of the operands, we make a
4375             --  call to the TSS equality function.
4376
4377             if Has_Inferable_Discriminants (Lhs)
4378                  and then
4379                Has_Inferable_Discriminants (Rhs)
4380             then
4381                Build_Equality_Call
4382                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
4383
4384             else
4385                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
4386                --  the predefined equality operator for an Unchecked_Union type
4387                --  if either of the operands lack inferable discriminants.
4388
4389                Insert_Action (N,
4390                  Make_Raise_Program_Error (Loc,
4391                    Reason => PE_Unchecked_Union_Restriction));
4392
4393                --  Prevent Gigi from generating incorrect code by rewriting
4394                --  the equality as a standard False.
4395
4396                Rewrite (N,
4397                  New_Occurrence_Of (Standard_False, Loc));
4398
4399             end if;
4400
4401          --  If a type support function is present (for complex cases), use it
4402
4403          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
4404             Build_Equality_Call
4405               (TSS (Root_Type (Typl), TSS_Composite_Equality));
4406
4407          --  Otherwise expand the component by component equality. Note that
4408          --  we never use block-bit coparisons for records, because of the
4409          --  problems with gaps. The backend will often be able to recombine
4410          --  the separate comparisons that we generate here.
4411
4412          else
4413             Remove_Side_Effects (Lhs);
4414             Remove_Side_Effects (Rhs);
4415             Rewrite (N,
4416               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
4417
4418             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
4419             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4420          end if;
4421       end if;
4422
4423       --  If we still have an equality comparison (i.e. it was not rewritten
4424       --  in some way), then we can test if result is needed at compile time).
4425
4426       if Nkind (N) = N_Op_Eq then
4427          Rewrite_Comparison (N);
4428       end if;
4429    end Expand_N_Op_Eq;
4430
4431    -----------------------
4432    -- Expand_N_Op_Expon --
4433    -----------------------
4434
4435    procedure Expand_N_Op_Expon (N : Node_Id) is
4436       Loc    : constant Source_Ptr := Sloc (N);
4437       Typ    : constant Entity_Id  := Etype (N);
4438       Rtyp   : constant Entity_Id  := Root_Type (Typ);
4439       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
4440       Bastyp : constant Node_Id    := Etype (Base);
4441       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
4442       Exptyp : constant Entity_Id  := Etype (Exp);
4443       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
4444       Expv   : Uint;
4445       Xnode  : Node_Id;
4446       Temp   : Node_Id;
4447       Rent   : RE_Id;
4448       Ent    : Entity_Id;
4449       Etyp   : Entity_Id;
4450
4451    begin
4452       Binary_Op_Validity_Checks (N);
4453
4454       --  If either operand is of a private type, then we have the use of
4455       --  an intrinsic operator, and we get rid of the privateness, by using
4456       --  root types of underlying types for the actual operation. Otherwise
4457       --  the private types will cause trouble if we expand multiplications
4458       --  or shifts etc. We also do this transformation if the result type
4459       --  is different from the base type.
4460
4461       if Is_Private_Type (Etype (Base))
4462            or else
4463          Is_Private_Type (Typ)
4464            or else
4465          Is_Private_Type (Exptyp)
4466            or else
4467          Rtyp /= Root_Type (Bastyp)
4468       then
4469          declare
4470             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
4471             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
4472
4473          begin
4474             Rewrite (N,
4475               Unchecked_Convert_To (Typ,
4476                 Make_Op_Expon (Loc,
4477                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
4478                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
4479             Analyze_And_Resolve (N, Typ);
4480             return;
4481          end;
4482       end if;
4483
4484       --  Test for case of known right argument
4485
4486       if Compile_Time_Known_Value (Exp) then
4487          Expv := Expr_Value (Exp);
4488
4489          --  We only fold small non-negative exponents. You might think we
4490          --  could fold small negative exponents for the real case, but we
4491          --  can't because we are required to raise Constraint_Error for
4492          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
4493          --  See ACVC test C4A012B.
4494
4495          if Expv >= 0 and then Expv <= 4 then
4496
4497             --  X ** 0 = 1 (or 1.0)
4498
4499             if Expv = 0 then
4500                if Ekind (Typ) in Integer_Kind then
4501                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
4502                else
4503                   Xnode := Make_Real_Literal (Loc, Ureal_1);
4504                end if;
4505
4506             --  X ** 1 = X
4507
4508             elsif Expv = 1 then
4509                Xnode := Base;
4510
4511             --  X ** 2 = X * X
4512
4513             elsif Expv = 2 then
4514                Xnode :=
4515                  Make_Op_Multiply (Loc,
4516                    Left_Opnd  => Duplicate_Subexpr (Base),
4517                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
4518
4519             --  X ** 3 = X * X * X
4520
4521             elsif Expv = 3 then
4522                Xnode :=
4523                  Make_Op_Multiply (Loc,
4524                    Left_Opnd =>
4525                      Make_Op_Multiply (Loc,
4526                        Left_Opnd  => Duplicate_Subexpr (Base),
4527                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
4528                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
4529
4530             --  X ** 4  ->
4531             --    En : constant base'type := base * base;
4532             --    ...
4533             --    En * En
4534
4535             else -- Expv = 4
4536                Temp :=
4537                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4538
4539                Insert_Actions (N, New_List (
4540                  Make_Object_Declaration (Loc,
4541                    Defining_Identifier => Temp,
4542                    Constant_Present    => True,
4543                    Object_Definition   => New_Reference_To (Typ, Loc),
4544                    Expression =>
4545                      Make_Op_Multiply (Loc,
4546                        Left_Opnd  => Duplicate_Subexpr (Base),
4547                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
4548
4549                Xnode :=
4550                  Make_Op_Multiply (Loc,
4551                    Left_Opnd  => New_Reference_To (Temp, Loc),
4552                    Right_Opnd => New_Reference_To (Temp, Loc));
4553             end if;
4554
4555             Rewrite (N, Xnode);
4556             Analyze_And_Resolve (N, Typ);
4557             return;
4558          end if;
4559       end if;
4560
4561       --  Case of (2 ** expression) appearing as an argument of an integer
4562       --  multiplication, or as the right argument of a division of a non-
4563       --  negative integer. In such cases we leave the node untouched, setting
4564       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4565       --  of the higher level node converts it into a shift.
4566
4567       if Nkind (Base) = N_Integer_Literal
4568         and then Intval (Base) = 2
4569         and then Is_Integer_Type (Root_Type (Exptyp))
4570         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
4571         and then Is_Unsigned_Type (Exptyp)
4572         and then not Ovflo
4573         and then Nkind (Parent (N)) in N_Binary_Op
4574       then
4575          declare
4576             P : constant Node_Id := Parent (N);
4577             L : constant Node_Id := Left_Opnd (P);
4578             R : constant Node_Id := Right_Opnd (P);
4579
4580          begin
4581             if (Nkind (P) = N_Op_Multiply
4582                  and then
4583                    ((Is_Integer_Type (Etype (L)) and then R = N)
4584                        or else
4585                     (Is_Integer_Type (Etype (R)) and then L = N))
4586                  and then not Do_Overflow_Check (P))
4587
4588               or else
4589                 (Nkind (P) = N_Op_Divide
4590                   and then Is_Integer_Type (Etype (L))
4591                   and then Is_Unsigned_Type (Etype (L))
4592                   and then R = N
4593                   and then not Do_Overflow_Check (P))
4594             then
4595                Set_Is_Power_Of_2_For_Shift (N);
4596                return;
4597             end if;
4598          end;
4599       end if;
4600
4601       --  Fall through if exponentiation must be done using a runtime routine
4602
4603       --  First deal with modular case
4604
4605       if Is_Modular_Integer_Type (Rtyp) then
4606
4607          --  Non-binary case, we call the special exponentiation routine for
4608          --  the non-binary case, converting the argument to Long_Long_Integer
4609          --  and passing the modulus value. Then the result is converted back
4610          --  to the base type.
4611
4612          if Non_Binary_Modulus (Rtyp) then
4613             Rewrite (N,
4614               Convert_To (Typ,
4615                 Make_Function_Call (Loc,
4616                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
4617                   Parameter_Associations => New_List (
4618                     Convert_To (Standard_Integer, Base),
4619                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
4620                     Exp))));
4621
4622          --  Binary case, in this case, we call one of two routines, either
4623          --  the unsigned integer case, or the unsigned long long integer
4624          --  case, with a final "and" operation to do the required mod.
4625
4626          else
4627             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
4628                Ent := RTE (RE_Exp_Unsigned);
4629             else
4630                Ent := RTE (RE_Exp_Long_Long_Unsigned);
4631             end if;
4632
4633             Rewrite (N,
4634               Convert_To (Typ,
4635                 Make_Op_And (Loc,
4636                   Left_Opnd =>
4637                     Make_Function_Call (Loc,
4638                       Name => New_Reference_To (Ent, Loc),
4639                       Parameter_Associations => New_List (
4640                         Convert_To (Etype (First_Formal (Ent)), Base),
4641                         Exp)),
4642                    Right_Opnd =>
4643                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
4644
4645          end if;
4646
4647          --  Common exit point for modular type case
4648
4649          Analyze_And_Resolve (N, Typ);
4650          return;
4651
4652       --  Signed integer cases, done using either Integer or Long_Long_Integer.
4653       --  It is not worth having routines for Short_[Short_]Integer, since for
4654       --  most machines it would not help, and it would generate more code that
4655       --  might need certification in the HI-E case.
4656
4657       --  In the integer cases, we have two routines, one for when overflow
4658       --  checks are required, and one when they are not required, since
4659       --  there is a real gain in ommitting checks on many machines.
4660
4661       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
4662         or else (Rtyp = Base_Type (Standard_Long_Integer)
4663                    and then
4664                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
4665         or else (Rtyp = Universal_Integer)
4666       then
4667          Etyp := Standard_Long_Long_Integer;
4668
4669          if Ovflo then
4670             Rent := RE_Exp_Long_Long_Integer;
4671          else
4672             Rent := RE_Exn_Long_Long_Integer;
4673          end if;
4674
4675       elsif Is_Signed_Integer_Type (Rtyp) then
4676          Etyp := Standard_Integer;
4677
4678          if Ovflo then
4679             Rent := RE_Exp_Integer;
4680          else
4681             Rent := RE_Exn_Integer;
4682          end if;
4683
4684       --  Floating-point cases, always done using Long_Long_Float. We do not
4685       --  need separate routines for the overflow case here, since in the case
4686       --  of floating-point, we generate infinities anyway as a rule (either
4687       --  that or we automatically trap overflow), and if there is an infinity
4688       --  generated and a range check is required, the check will fail anyway.
4689
4690       else
4691          pragma Assert (Is_Floating_Point_Type (Rtyp));
4692          Etyp := Standard_Long_Long_Float;
4693          Rent := RE_Exn_Long_Long_Float;
4694       end if;
4695
4696       --  Common processing for integer cases and floating-point cases.
4697       --  If we are in the right type, we can call runtime routine directly
4698
4699       if Typ = Etyp
4700         and then Rtyp /= Universal_Integer
4701         and then Rtyp /= Universal_Real
4702       then
4703          Rewrite (N,
4704            Make_Function_Call (Loc,
4705              Name => New_Reference_To (RTE (Rent), Loc),
4706              Parameter_Associations => New_List (Base, Exp)));
4707
4708       --  Otherwise we have to introduce conversions (conversions are also
4709       --  required in the universal cases, since the runtime routine is
4710       --  typed using one of the standard types.
4711
4712       else
4713          Rewrite (N,
4714            Convert_To (Typ,
4715              Make_Function_Call (Loc,
4716                Name => New_Reference_To (RTE (Rent), Loc),
4717                Parameter_Associations => New_List (
4718                  Convert_To (Etyp, Base),
4719                  Exp))));
4720       end if;
4721
4722       Analyze_And_Resolve (N, Typ);
4723       return;
4724
4725    exception
4726       when RE_Not_Available =>
4727          return;
4728    end Expand_N_Op_Expon;
4729
4730    --------------------
4731    -- Expand_N_Op_Ge --
4732    --------------------
4733
4734    procedure Expand_N_Op_Ge (N : Node_Id) is
4735       Typ  : constant Entity_Id := Etype (N);
4736       Op1  : constant Node_Id   := Left_Opnd (N);
4737       Op2  : constant Node_Id   := Right_Opnd (N);
4738       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4739
4740    begin
4741       Binary_Op_Validity_Checks (N);
4742
4743       if Vax_Float (Typ1) then
4744          Expand_Vax_Comparison (N);
4745          return;
4746
4747       elsif Is_Array_Type (Typ1) then
4748          Expand_Array_Comparison (N);
4749          return;
4750       end if;
4751
4752       if Is_Boolean_Type (Typ1) then
4753          Adjust_Condition (Op1);
4754          Adjust_Condition (Op2);
4755          Set_Etype (N, Standard_Boolean);
4756          Adjust_Result_Type (N, Typ);
4757       end if;
4758
4759       Rewrite_Comparison (N);
4760    end Expand_N_Op_Ge;
4761
4762    --------------------
4763    -- Expand_N_Op_Gt --
4764    --------------------
4765
4766    procedure Expand_N_Op_Gt (N : Node_Id) is
4767       Typ  : constant Entity_Id := Etype (N);
4768       Op1  : constant Node_Id   := Left_Opnd (N);
4769       Op2  : constant Node_Id   := Right_Opnd (N);
4770       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4771
4772    begin
4773       Binary_Op_Validity_Checks (N);
4774
4775       if Vax_Float (Typ1) then
4776          Expand_Vax_Comparison (N);
4777          return;
4778
4779       elsif Is_Array_Type (Typ1) then
4780          Expand_Array_Comparison (N);
4781          return;
4782       end if;
4783
4784       if Is_Boolean_Type (Typ1) then
4785          Adjust_Condition (Op1);
4786          Adjust_Condition (Op2);
4787          Set_Etype (N, Standard_Boolean);
4788          Adjust_Result_Type (N, Typ);
4789       end if;
4790
4791       Rewrite_Comparison (N);
4792    end Expand_N_Op_Gt;
4793
4794    --------------------
4795    -- Expand_N_Op_Le --
4796    --------------------
4797
4798    procedure Expand_N_Op_Le (N : Node_Id) is
4799       Typ  : constant Entity_Id := Etype (N);
4800       Op1  : constant Node_Id   := Left_Opnd (N);
4801       Op2  : constant Node_Id   := Right_Opnd (N);
4802       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4803
4804    begin
4805       Binary_Op_Validity_Checks (N);
4806
4807       if Vax_Float (Typ1) then
4808          Expand_Vax_Comparison (N);
4809          return;
4810
4811       elsif Is_Array_Type (Typ1) then
4812          Expand_Array_Comparison (N);
4813          return;
4814       end if;
4815
4816       if Is_Boolean_Type (Typ1) then
4817          Adjust_Condition (Op1);
4818          Adjust_Condition (Op2);
4819          Set_Etype (N, Standard_Boolean);
4820          Adjust_Result_Type (N, Typ);
4821       end if;
4822
4823       Rewrite_Comparison (N);
4824    end Expand_N_Op_Le;
4825
4826    --------------------
4827    -- Expand_N_Op_Lt --
4828    --------------------
4829
4830    procedure Expand_N_Op_Lt (N : Node_Id) is
4831       Typ  : constant Entity_Id := Etype (N);
4832       Op1  : constant Node_Id   := Left_Opnd (N);
4833       Op2  : constant Node_Id   := Right_Opnd (N);
4834       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4835
4836    begin
4837       Binary_Op_Validity_Checks (N);
4838
4839       if Vax_Float (Typ1) then
4840          Expand_Vax_Comparison (N);
4841          return;
4842
4843       elsif Is_Array_Type (Typ1) then
4844          Expand_Array_Comparison (N);
4845          return;
4846       end if;
4847
4848       if Is_Boolean_Type (Typ1) then
4849          Adjust_Condition (Op1);
4850          Adjust_Condition (Op2);
4851          Set_Etype (N, Standard_Boolean);
4852          Adjust_Result_Type (N, Typ);
4853       end if;
4854
4855       Rewrite_Comparison (N);
4856    end Expand_N_Op_Lt;
4857
4858    -----------------------
4859    -- Expand_N_Op_Minus --
4860    -----------------------
4861
4862    procedure Expand_N_Op_Minus (N : Node_Id) is
4863       Loc : constant Source_Ptr := Sloc (N);
4864       Typ : constant Entity_Id  := Etype (N);
4865
4866    begin
4867       Unary_Op_Validity_Checks (N);
4868
4869       if not Backend_Overflow_Checks_On_Target
4870          and then Is_Signed_Integer_Type (Etype (N))
4871          and then Do_Overflow_Check (N)
4872       then
4873          --  Software overflow checking expands -expr into (0 - expr)
4874
4875          Rewrite (N,
4876            Make_Op_Subtract (Loc,
4877              Left_Opnd  => Make_Integer_Literal (Loc, 0),
4878              Right_Opnd => Right_Opnd (N)));
4879
4880          Analyze_And_Resolve (N, Typ);
4881
4882       --  Vax floating-point types case
4883
4884       elsif Vax_Float (Etype (N)) then
4885          Expand_Vax_Arith (N);
4886       end if;
4887    end Expand_N_Op_Minus;
4888
4889    ---------------------
4890    -- Expand_N_Op_Mod --
4891    ---------------------
4892
4893    procedure Expand_N_Op_Mod (N : Node_Id) is
4894       Loc   : constant Source_Ptr := Sloc (N);
4895       Typ   : constant Entity_Id  := Etype (N);
4896       Left  : constant Node_Id    := Left_Opnd (N);
4897       Right : constant Node_Id    := Right_Opnd (N);
4898       DOC   : constant Boolean    := Do_Overflow_Check (N);
4899       DDC   : constant Boolean    := Do_Division_Check (N);
4900
4901       LLB : Uint;
4902       Llo : Uint;
4903       Lhi : Uint;
4904       LOK : Boolean;
4905       Rlo : Uint;
4906       Rhi : Uint;
4907       ROK : Boolean;
4908
4909    begin
4910       Binary_Op_Validity_Checks (N);
4911
4912       Determine_Range (Right, ROK, Rlo, Rhi);
4913       Determine_Range (Left,  LOK, Llo, Lhi);
4914
4915       --  Convert mod to rem if operands are known non-negative. We do this
4916       --  since it is quite likely that this will improve the quality of code,
4917       --  (the operation now corresponds to the hardware remainder), and it
4918       --  does not seem likely that it could be harmful.
4919
4920       if LOK and then Llo >= 0
4921            and then
4922          ROK and then Rlo >= 0
4923       then
4924          Rewrite (N,
4925            Make_Op_Rem (Sloc (N),
4926              Left_Opnd  => Left_Opnd (N),
4927              Right_Opnd => Right_Opnd (N)));
4928
4929          --  Instead of reanalyzing the node we do the analysis manually.
4930          --  This avoids anomalies when the replacement is done in an
4931          --  instance and is epsilon more efficient.
4932
4933          Set_Entity            (N, Standard_Entity (S_Op_Rem));
4934          Set_Etype             (N, Typ);
4935          Set_Do_Overflow_Check (N, DOC);
4936          Set_Do_Division_Check (N, DDC);
4937          Expand_N_Op_Rem (N);
4938          Set_Analyzed (N);
4939
4940       --  Otherwise, normal mod processing
4941
4942       else
4943          if Is_Integer_Type (Etype (N)) then
4944             Apply_Divide_Check (N);
4945          end if;
4946
4947          --  Apply optimization x mod 1 = 0. We don't really need that with
4948          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
4949          --  certainly harmless.
4950
4951          if Is_Integer_Type (Etype (N))
4952            and then Compile_Time_Known_Value (Right)
4953            and then Expr_Value (Right) = Uint_1
4954          then
4955             Rewrite (N, Make_Integer_Literal (Loc, 0));
4956             Analyze_And_Resolve (N, Typ);
4957             return;
4958          end if;
4959
4960          --  Deal with annoying case of largest negative number remainder
4961          --  minus one. Gigi does not handle this case correctly, because
4962          --  it generates a divide instruction which may trap in this case.
4963
4964          --  In fact the check is quite easy, if the right operand is -1,
4965          --  then the mod value is always 0, and we can just ignore the
4966          --  left operand completely in this case.
4967
4968          --  The operand type may be private (e.g. in the expansion of an
4969          --  an intrinsic operation) so we must use the underlying type to
4970          --  get the bounds, and convert the literals explicitly.
4971
4972          LLB :=
4973            Expr_Value
4974              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
4975
4976          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4977            and then
4978             ((not LOK) or else (Llo = LLB))
4979          then
4980             Rewrite (N,
4981               Make_Conditional_Expression (Loc,
4982                 Expressions => New_List (
4983                   Make_Op_Eq (Loc,
4984                     Left_Opnd => Duplicate_Subexpr (Right),
4985                     Right_Opnd =>
4986                       Unchecked_Convert_To (Typ,
4987                         Make_Integer_Literal (Loc, -1))),
4988                   Unchecked_Convert_To (Typ,
4989                     Make_Integer_Literal (Loc, Uint_0)),
4990                   Relocate_Node (N))));
4991
4992             Set_Analyzed (Next (Next (First (Expressions (N)))));
4993             Analyze_And_Resolve (N, Typ);
4994          end if;
4995       end if;
4996    end Expand_N_Op_Mod;
4997
4998    --------------------------
4999    -- Expand_N_Op_Multiply --
5000    --------------------------
5001
5002    procedure Expand_N_Op_Multiply (N : Node_Id) is
5003       Loc  : constant Source_Ptr := Sloc (N);
5004       Lop  : constant Node_Id    := Left_Opnd (N);
5005       Rop  : constant Node_Id    := Right_Opnd (N);
5006
5007       Lp2  : constant Boolean :=
5008                Nkind (Lop) = N_Op_Expon
5009                  and then Is_Power_Of_2_For_Shift (Lop);
5010
5011       Rp2  : constant Boolean :=
5012                Nkind (Rop) = N_Op_Expon
5013                  and then Is_Power_Of_2_For_Shift (Rop);
5014
5015       Ltyp : constant Entity_Id  := Etype (Lop);
5016       Rtyp : constant Entity_Id  := Etype (Rop);
5017       Typ  : Entity_Id           := Etype (N);
5018
5019    begin
5020       Binary_Op_Validity_Checks (N);
5021
5022       --  Special optimizations for integer types
5023
5024       if Is_Integer_Type (Typ) then
5025
5026          --  N * 0 = 0 * N = 0 for integer types
5027
5028          if (Compile_Time_Known_Value (Rop)
5029               and then Expr_Value (Rop) = Uint_0)
5030            or else
5031             (Compile_Time_Known_Value (Lop)
5032               and then Expr_Value (Lop) = Uint_0)
5033          then
5034             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
5035             Analyze_And_Resolve (N, Typ);
5036             return;
5037          end if;
5038
5039          --  N * 1 = 1 * N = N for integer types
5040
5041          --  This optimisation is not done if we are going to
5042          --  rewrite the product 1 * 2 ** N to a shift.
5043
5044          if Compile_Time_Known_Value (Rop)
5045            and then Expr_Value (Rop) = Uint_1
5046            and then not Lp2
5047          then
5048             Rewrite (N, Lop);
5049             return;
5050
5051          elsif Compile_Time_Known_Value (Lop)
5052            and then Expr_Value (Lop) = Uint_1
5053            and then not Rp2
5054          then
5055             Rewrite (N, Rop);
5056             return;
5057          end if;
5058       end if;
5059
5060       --  Deal with VAX float case
5061
5062       if Vax_Float (Typ) then
5063          Expand_Vax_Arith (N);
5064          return;
5065       end if;
5066
5067       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5068       --  Is_Power_Of_2_For_Shift is set means that we know that our left
5069       --  operand is an integer, as required for this to work.
5070
5071       if Rp2 then
5072          if Lp2 then
5073
5074             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
5075
5076             Rewrite (N,
5077               Make_Op_Expon (Loc,
5078                 Left_Opnd => Make_Integer_Literal (Loc, 2),
5079                 Right_Opnd =>
5080                   Make_Op_Add (Loc,
5081                     Left_Opnd  => Right_Opnd (Lop),
5082                     Right_Opnd => Right_Opnd (Rop))));
5083             Analyze_And_Resolve (N, Typ);
5084             return;
5085
5086          else
5087             Rewrite (N,
5088               Make_Op_Shift_Left (Loc,
5089                 Left_Opnd  => Lop,
5090                 Right_Opnd =>
5091                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
5092             Analyze_And_Resolve (N, Typ);
5093             return;
5094          end if;
5095
5096       --  Same processing for the operands the other way round
5097
5098       elsif Lp2 then
5099          Rewrite (N,
5100            Make_Op_Shift_Left (Loc,
5101              Left_Opnd  => Rop,
5102              Right_Opnd =>
5103                Convert_To (Standard_Natural, Right_Opnd (Lop))));
5104          Analyze_And_Resolve (N, Typ);
5105          return;
5106       end if;
5107
5108       --  Do required fixup of universal fixed operation
5109
5110       if Typ = Universal_Fixed then
5111          Fixup_Universal_Fixed_Operation (N);
5112          Typ := Etype (N);
5113       end if;
5114
5115       --  Multiplications with fixed-point results
5116
5117       if Is_Fixed_Point_Type (Typ) then
5118
5119          --  No special processing if Treat_Fixed_As_Integer is set,
5120          --  since from a semantic point of view such operations are
5121          --  simply integer operations and will be treated that way.
5122
5123          if not Treat_Fixed_As_Integer (N) then
5124
5125             --  Case of fixed * integer => fixed
5126
5127             if Is_Integer_Type (Rtyp) then
5128                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
5129
5130             --  Case of integer * fixed => fixed
5131
5132             elsif Is_Integer_Type (Ltyp) then
5133                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
5134
5135             --  Case of fixed * fixed => fixed
5136
5137             else
5138                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
5139             end if;
5140          end if;
5141
5142       --  Other cases of multiplication of fixed-point operands. Again
5143       --  we exclude the cases where Treat_Fixed_As_Integer flag is set.
5144
5145       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
5146         and then not Treat_Fixed_As_Integer (N)
5147       then
5148          if Is_Integer_Type (Typ) then
5149             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
5150          else
5151             pragma Assert (Is_Floating_Point_Type (Typ));
5152             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
5153          end if;
5154
5155       --  Mixed-mode operations can appear in a non-static universal
5156       --  context, in  which case the integer argument must be converted
5157       --  explicitly.
5158
5159       elsif Typ = Universal_Real
5160         and then Is_Integer_Type (Rtyp)
5161       then
5162          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
5163
5164          Analyze_And_Resolve (Rop, Universal_Real);
5165
5166       elsif Typ = Universal_Real
5167         and then Is_Integer_Type (Ltyp)
5168       then
5169          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
5170
5171          Analyze_And_Resolve (Lop, Universal_Real);
5172
5173       --  Non-fixed point cases, check software overflow checking required
5174
5175       elsif Is_Signed_Integer_Type (Etype (N)) then
5176          Apply_Arithmetic_Overflow_Check (N);
5177       end if;
5178    end Expand_N_Op_Multiply;
5179
5180    --------------------
5181    -- Expand_N_Op_Ne --
5182    --------------------
5183
5184    --  Rewrite node as the negation of an equality operation, and reanalyze.
5185    --  The equality to be used is defined in the same scope and has the same
5186    --  signature. It must be set explicitly because in an instance it may not
5187    --  have the same visibility as in the generic unit.
5188
5189    procedure Expand_N_Op_Ne (N : Node_Id) is
5190       Loc : constant Source_Ptr := Sloc (N);
5191       Neg : Node_Id;
5192       Ne  : constant Entity_Id := Entity (N);
5193
5194    begin
5195       Binary_Op_Validity_Checks (N);
5196
5197       Neg :=
5198         Make_Op_Not (Loc,
5199           Right_Opnd =>
5200             Make_Op_Eq (Loc,
5201               Left_Opnd =>  Left_Opnd (N),
5202               Right_Opnd => Right_Opnd (N)));
5203       Set_Paren_Count (Right_Opnd (Neg), 1);
5204
5205       if Scope (Ne) /= Standard_Standard then
5206          Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
5207       end if;
5208
5209       --  For navigation purposes, the inequality is treated as an implicit
5210       --  reference to the corresponding equality. Preserve the Comes_From_
5211       --  source flag so that the proper Xref entry is generated.
5212
5213       Preserve_Comes_From_Source (Neg, N);
5214       Preserve_Comes_From_Source (Right_Opnd (Neg), N);
5215       Rewrite (N, Neg);
5216       Analyze_And_Resolve (N, Standard_Boolean);
5217    end Expand_N_Op_Ne;
5218
5219    ---------------------
5220    -- Expand_N_Op_Not --
5221    ---------------------
5222
5223    --  If the argument is other than a Boolean array type, there is no
5224    --  special expansion required.
5225
5226    --  For the packed case, we call the special routine in Exp_Pakd, except
5227    --  that if the component size is greater than one, we use the standard
5228    --  routine generating a gruesome loop (it is so peculiar to have packed
5229    --  arrays with non-standard Boolean representations anyway, so it does
5230    --  not matter that we do not handle this case efficiently).
5231
5232    --  For the unpacked case (and for the special packed case where we have
5233    --  non standard Booleans, as discussed above), we generate and insert
5234    --  into the tree the following function definition:
5235
5236    --     function Nnnn (A : arr) is
5237    --       B : arr;
5238    --     begin
5239    --       for J in a'range loop
5240    --          B (J) := not A (J);
5241    --       end loop;
5242    --       return B;
5243    --     end Nnnn;
5244
5245    --  Here arr is the actual subtype of the parameter (and hence always
5246    --  constrained). Then we replace the not with a call to this function.
5247
5248    procedure Expand_N_Op_Not (N : Node_Id) is
5249       Loc  : constant Source_Ptr := Sloc (N);
5250       Typ  : constant Entity_Id  := Etype (N);
5251       Opnd : Node_Id;
5252       Arr  : Entity_Id;
5253       A    : Entity_Id;
5254       B    : Entity_Id;
5255       J    : Entity_Id;
5256       A_J  : Node_Id;
5257       B_J  : Node_Id;
5258
5259       Func_Name      : Entity_Id;
5260       Loop_Statement : Node_Id;
5261
5262    begin
5263       Unary_Op_Validity_Checks (N);
5264
5265       --  For boolean operand, deal with non-standard booleans
5266
5267       if Is_Boolean_Type (Typ) then
5268          Adjust_Condition (Right_Opnd (N));
5269          Set_Etype (N, Standard_Boolean);
5270          Adjust_Result_Type (N, Typ);
5271          return;
5272       end if;
5273
5274       --  Only array types need any other processing
5275
5276       if not Is_Array_Type (Typ) then
5277          return;
5278       end if;
5279
5280       --  Case of array operand. If bit packed, handle it in Exp_Pakd
5281
5282       if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
5283          Expand_Packed_Not (N);
5284          return;
5285       end if;
5286
5287       --  Case of array operand which is not bit-packed. If the context is
5288       --  a safe assignment, call in-place operation, If context is a larger
5289       --  boolean expression in the context of a safe assignment, expansion is
5290       --  done by enclosing operation.
5291
5292       Opnd := Relocate_Node (Right_Opnd (N));
5293       Convert_To_Actual_Subtype (Opnd);
5294       Arr := Etype (Opnd);
5295       Ensure_Defined (Arr, N);
5296
5297       if Nkind (Parent (N)) = N_Assignment_Statement then
5298          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
5299             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
5300             return;
5301
5302          --  Special case the negation of a binary operation
5303
5304          elsif (Nkind (Opnd) = N_Op_And
5305                  or else Nkind (Opnd) = N_Op_Or
5306                  or else Nkind (Opnd) = N_Op_Xor)
5307            and then Safe_In_Place_Array_Op
5308              (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
5309          then
5310             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
5311             return;
5312          end if;
5313
5314       elsif Nkind (Parent (N)) in N_Binary_Op
5315         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
5316       then
5317          declare
5318             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
5319             Op2 : constant Node_Id := Right_Opnd (Parent (N));
5320             Lhs : constant Node_Id := Name (Parent (Parent (N)));
5321
5322          begin
5323             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
5324                if N = Op1
5325                  and then Nkind (Op2) = N_Op_Not
5326                then
5327                   --  (not A) op (not B) can be reduced to a single call
5328
5329                   return;
5330
5331                elsif N = Op2
5332                  and then Nkind (Parent (N)) = N_Op_Xor
5333                then
5334                   --  A xor (not B) can also be special-cased
5335
5336                   return;
5337                end if;
5338             end if;
5339          end;
5340       end if;
5341
5342       A := Make_Defining_Identifier (Loc, Name_uA);
5343       B := Make_Defining_Identifier (Loc, Name_uB);
5344       J := Make_Defining_Identifier (Loc, Name_uJ);
5345
5346       A_J :=
5347         Make_Indexed_Component (Loc,
5348           Prefix      => New_Reference_To (A, Loc),
5349           Expressions => New_List (New_Reference_To (J, Loc)));
5350
5351       B_J :=
5352         Make_Indexed_Component (Loc,
5353           Prefix      => New_Reference_To (B, Loc),
5354           Expressions => New_List (New_Reference_To (J, Loc)));
5355
5356       Loop_Statement :=
5357         Make_Implicit_Loop_Statement (N,
5358           Identifier => Empty,
5359
5360           Iteration_Scheme =>
5361             Make_Iteration_Scheme (Loc,
5362               Loop_Parameter_Specification =>
5363                 Make_Loop_Parameter_Specification (Loc,
5364                   Defining_Identifier => J,
5365                   Discrete_Subtype_Definition =>
5366                     Make_Attribute_Reference (Loc,
5367                       Prefix => Make_Identifier (Loc, Chars (A)),
5368                       Attribute_Name => Name_Range))),
5369
5370           Statements => New_List (
5371             Make_Assignment_Statement (Loc,
5372               Name       => B_J,
5373               Expression => Make_Op_Not (Loc, A_J))));
5374
5375       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
5376       Set_Is_Inlined (Func_Name);
5377
5378       Insert_Action (N,
5379         Make_Subprogram_Body (Loc,
5380           Specification =>
5381             Make_Function_Specification (Loc,
5382               Defining_Unit_Name => Func_Name,
5383               Parameter_Specifications => New_List (
5384                 Make_Parameter_Specification (Loc,
5385                   Defining_Identifier => A,
5386                   Parameter_Type      => New_Reference_To (Typ, Loc))),
5387               Subtype_Mark => New_Reference_To (Typ, Loc)),
5388
5389           Declarations => New_List (
5390             Make_Object_Declaration (Loc,
5391               Defining_Identifier => B,
5392               Object_Definition   => New_Reference_To (Arr, Loc))),
5393
5394           Handled_Statement_Sequence =>
5395             Make_Handled_Sequence_Of_Statements (Loc,
5396               Statements => New_List (
5397                 Loop_Statement,
5398                 Make_Return_Statement (Loc,
5399                   Expression =>
5400                     Make_Identifier (Loc, Chars (B)))))));
5401
5402       Rewrite (N,
5403         Make_Function_Call (Loc,
5404           Name => New_Reference_To (Func_Name, Loc),
5405           Parameter_Associations => New_List (Opnd)));
5406
5407       Analyze_And_Resolve (N, Typ);
5408    end Expand_N_Op_Not;
5409
5410    --------------------
5411    -- Expand_N_Op_Or --
5412    --------------------
5413
5414    procedure Expand_N_Op_Or (N : Node_Id) is
5415       Typ : constant Entity_Id := Etype (N);
5416
5417    begin
5418       Binary_Op_Validity_Checks (N);
5419
5420       if Is_Array_Type (Etype (N)) then
5421          Expand_Boolean_Operator (N);
5422
5423       elsif Is_Boolean_Type (Etype (N)) then
5424          Adjust_Condition (Left_Opnd (N));
5425          Adjust_Condition (Right_Opnd (N));
5426          Set_Etype (N, Standard_Boolean);
5427          Adjust_Result_Type (N, Typ);
5428       end if;
5429    end Expand_N_Op_Or;
5430
5431    ----------------------
5432    -- Expand_N_Op_Plus --
5433    ----------------------
5434
5435    procedure Expand_N_Op_Plus (N : Node_Id) is
5436    begin
5437       Unary_Op_Validity_Checks (N);
5438    end Expand_N_Op_Plus;
5439
5440    ---------------------
5441    -- Expand_N_Op_Rem --
5442    ---------------------
5443
5444    procedure Expand_N_Op_Rem (N : Node_Id) is
5445       Loc : constant Source_Ptr := Sloc (N);
5446       Typ : constant Entity_Id  := Etype (N);
5447
5448       Left  : constant Node_Id := Left_Opnd (N);
5449       Right : constant Node_Id := Right_Opnd (N);
5450
5451       LLB : Uint;
5452       Llo : Uint;
5453       Lhi : Uint;
5454       LOK : Boolean;
5455       Rlo : Uint;
5456       Rhi : Uint;
5457       ROK : Boolean;
5458
5459    begin
5460       Binary_Op_Validity_Checks (N);
5461
5462       if Is_Integer_Type (Etype (N)) then
5463          Apply_Divide_Check (N);
5464       end if;
5465
5466       --  Apply optimization x rem 1 = 0. We don't really need that with
5467       --  gcc, but it is useful with other back ends (e.g. AAMP), and is
5468       --  certainly harmless.
5469
5470       if Is_Integer_Type (Etype (N))
5471         and then Compile_Time_Known_Value (Right)
5472         and then Expr_Value (Right) = Uint_1
5473       then
5474          Rewrite (N, Make_Integer_Literal (Loc, 0));
5475          Analyze_And_Resolve (N, Typ);
5476          return;
5477       end if;
5478
5479       --  Deal with annoying case of largest negative number remainder
5480       --  minus one. Gigi does not handle this case correctly, because
5481       --  it generates a divide instruction which may trap in this case.
5482
5483       --  In fact the check is quite easy, if the right operand is -1,
5484       --  then the remainder is always 0, and we can just ignore the
5485       --  left operand completely in this case.
5486
5487       Determine_Range (Right, ROK, Rlo, Rhi);
5488       Determine_Range (Left, LOK, Llo, Lhi);
5489
5490       --  The operand type may be private (e.g. in the expansion of an
5491       --  an intrinsic operation) so we must use the underlying type to
5492       --  get the bounds, and convert the literals explicitly.
5493
5494       LLB :=
5495         Expr_Value
5496           (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
5497
5498       --  Now perform the test, generating code only if needed
5499
5500       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
5501         and then
5502          ((not LOK) or else (Llo = LLB))
5503       then
5504          Rewrite (N,
5505            Make_Conditional_Expression (Loc,
5506              Expressions => New_List (
5507                Make_Op_Eq (Loc,
5508                  Left_Opnd => Duplicate_Subexpr (Right),
5509                  Right_Opnd =>
5510                    Unchecked_Convert_To (Typ,
5511                      Make_Integer_Literal (Loc, -1))),
5512
5513                Unchecked_Convert_To (Typ,
5514                  Make_Integer_Literal (Loc, Uint_0)),
5515
5516                Relocate_Node (N))));
5517
5518          Set_Analyzed (Next (Next (First (Expressions (N)))));
5519          Analyze_And_Resolve (N, Typ);
5520       end if;
5521    end Expand_N_Op_Rem;
5522
5523    -----------------------------
5524    -- Expand_N_Op_Rotate_Left --
5525    -----------------------------
5526
5527    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
5528    begin
5529       Binary_Op_Validity_Checks (N);
5530    end Expand_N_Op_Rotate_Left;
5531
5532    ------------------------------
5533    -- Expand_N_Op_Rotate_Right --
5534    ------------------------------
5535
5536    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
5537    begin
5538       Binary_Op_Validity_Checks (N);
5539    end Expand_N_Op_Rotate_Right;
5540
5541    ----------------------------
5542    -- Expand_N_Op_Shift_Left --
5543    ----------------------------
5544
5545    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
5546    begin
5547       Binary_Op_Validity_Checks (N);
5548    end Expand_N_Op_Shift_Left;
5549
5550    -----------------------------
5551    -- Expand_N_Op_Shift_Right --
5552    -----------------------------
5553
5554    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
5555    begin
5556       Binary_Op_Validity_Checks (N);
5557    end Expand_N_Op_Shift_Right;
5558
5559    ----------------------------------------
5560    -- Expand_N_Op_Shift_Right_Arithmetic --
5561    ----------------------------------------
5562
5563    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
5564    begin
5565       Binary_Op_Validity_Checks (N);
5566    end Expand_N_Op_Shift_Right_Arithmetic;
5567
5568    --------------------------
5569    -- Expand_N_Op_Subtract --
5570    --------------------------
5571
5572    procedure Expand_N_Op_Subtract (N : Node_Id) is
5573       Typ : constant Entity_Id := Etype (N);
5574
5575    begin
5576       Binary_Op_Validity_Checks (N);
5577
5578       --  N - 0 = N for integer types
5579
5580       if Is_Integer_Type (Typ)
5581         and then Compile_Time_Known_Value (Right_Opnd (N))
5582         and then Expr_Value (Right_Opnd (N)) = 0
5583       then
5584          Rewrite (N, Left_Opnd (N));
5585          return;
5586       end if;
5587
5588       --  Arithemtic overflow checks for signed integer/fixed point types
5589
5590       if Is_Signed_Integer_Type (Typ)
5591         or else Is_Fixed_Point_Type (Typ)
5592       then
5593          Apply_Arithmetic_Overflow_Check (N);
5594
5595       --  Vax floating-point types case
5596
5597       elsif Vax_Float (Typ) then
5598          Expand_Vax_Arith (N);
5599       end if;
5600    end Expand_N_Op_Subtract;
5601
5602    ---------------------
5603    -- Expand_N_Op_Xor --
5604    ---------------------
5605
5606    procedure Expand_N_Op_Xor (N : Node_Id) is
5607       Typ : constant Entity_Id := Etype (N);
5608
5609    begin
5610       Binary_Op_Validity_Checks (N);
5611
5612       if Is_Array_Type (Etype (N)) then
5613          Expand_Boolean_Operator (N);
5614
5615       elsif Is_Boolean_Type (Etype (N)) then
5616          Adjust_Condition (Left_Opnd (N));
5617          Adjust_Condition (Right_Opnd (N));
5618          Set_Etype (N, Standard_Boolean);
5619          Adjust_Result_Type (N, Typ);
5620       end if;
5621    end Expand_N_Op_Xor;
5622
5623    ----------------------
5624    -- Expand_N_Or_Else --
5625    ----------------------
5626
5627    --  Expand into conditional expression if Actions present, and also
5628    --  deal with optimizing case of arguments being True or False.
5629
5630    procedure Expand_N_Or_Else (N : Node_Id) is
5631       Loc     : constant Source_Ptr := Sloc (N);
5632       Typ     : constant Entity_Id  := Etype (N);
5633       Left    : constant Node_Id    := Left_Opnd (N);
5634       Right   : constant Node_Id    := Right_Opnd (N);
5635       Actlist : List_Id;
5636
5637    begin
5638       --  Deal with non-standard booleans
5639
5640       if Is_Boolean_Type (Typ) then
5641          Adjust_Condition (Left);
5642          Adjust_Condition (Right);
5643          Set_Etype (N, Standard_Boolean);
5644       end if;
5645
5646       --  Check for cases of left argument is True or False
5647
5648       if Nkind (Left) = N_Identifier then
5649
5650          --  If left argument is False, change (False or else Right) to Right.
5651          --  Any actions associated with Right will be executed unconditionally
5652          --  and can thus be inserted into the tree unconditionally.
5653
5654          if Entity (Left) = Standard_False then
5655             if Present (Actions (N)) then
5656                Insert_Actions (N, Actions (N));
5657             end if;
5658
5659             Rewrite (N, Right);
5660             Adjust_Result_Type (N, Typ);
5661             return;
5662
5663          --  If left argument is True, change (True and then Right) to
5664          --  True. In this case we can forget the actions associated with
5665          --  Right, since they will never be executed.
5666
5667          elsif Entity (Left) = Standard_True then
5668             Kill_Dead_Code (Right);
5669             Kill_Dead_Code (Actions (N));
5670             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5671             Adjust_Result_Type (N, Typ);
5672             return;
5673          end if;
5674       end if;
5675
5676       --  If Actions are present, we expand
5677
5678       --     left or else right
5679
5680       --  into
5681
5682       --     if left then True else right end
5683
5684       --  with the actions becoming the Else_Actions of the conditional
5685       --  expression. This conditional expression is then further expanded
5686       --  (and will eventually disappear)
5687
5688       if Present (Actions (N)) then
5689          Actlist := Actions (N);
5690          Rewrite (N,
5691             Make_Conditional_Expression (Loc,
5692               Expressions => New_List (
5693                 Left,
5694                 New_Occurrence_Of (Standard_True, Loc),
5695                 Right)));
5696
5697          Set_Else_Actions (N, Actlist);
5698          Analyze_And_Resolve (N, Standard_Boolean);
5699          Adjust_Result_Type (N, Typ);
5700          return;
5701       end if;
5702
5703       --  No actions present, check for cases of right argument True/False
5704
5705       if Nkind (Right) = N_Identifier then
5706
5707          --  Change (Left or else False) to Left. Note that we know there
5708          --  are no actions associated with the True operand, since we
5709          --  just checked for this case above.
5710
5711          if Entity (Right) = Standard_False then
5712             Rewrite (N, Left);
5713
5714          --  Change (Left or else True) to True, making sure to preserve
5715          --  any side effects associated with the Left operand.
5716
5717          elsif Entity (Right) = Standard_True then
5718             Remove_Side_Effects (Left);
5719             Rewrite
5720               (N, New_Occurrence_Of (Standard_True, Loc));
5721          end if;
5722       end if;
5723
5724       Adjust_Result_Type (N, Typ);
5725    end Expand_N_Or_Else;
5726
5727    -----------------------------------
5728    -- Expand_N_Qualified_Expression --
5729    -----------------------------------
5730
5731    procedure Expand_N_Qualified_Expression (N : Node_Id) is
5732       Operand     : constant Node_Id   := Expression (N);
5733       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
5734
5735    begin
5736       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
5737    end Expand_N_Qualified_Expression;
5738
5739    ---------------------------------
5740    -- Expand_N_Selected_Component --
5741    ---------------------------------
5742
5743    --  If the selector is a discriminant of a concurrent object, rewrite the
5744    --  prefix to denote the corresponding record type.
5745
5746    procedure Expand_N_Selected_Component (N : Node_Id) is
5747       Loc   : constant Source_Ptr := Sloc (N);
5748       Par   : constant Node_Id    := Parent (N);
5749       P     : constant Node_Id    := Prefix (N);
5750       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
5751       Disc  : Entity_Id;
5752       New_N : Node_Id;
5753       Dcon  : Elmt_Id;
5754
5755       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
5756       --  Gigi needs a temporary for prefixes that depend on a discriminant,
5757       --  unless the context of an assignment can provide size information.
5758       --  Don't we have a general routine that does this???
5759
5760       -----------------------
5761       -- In_Left_Hand_Side --
5762       -----------------------
5763
5764       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
5765       begin
5766          return (Nkind (Parent (Comp)) = N_Assignment_Statement
5767                    and then Comp = Name (Parent (Comp)))
5768            or else (Present (Parent (Comp))
5769                       and then Nkind (Parent (Comp)) in N_Subexpr
5770                       and then In_Left_Hand_Side (Parent (Comp)));
5771       end In_Left_Hand_Side;
5772
5773    --  Start of processing for Expand_N_Selected_Component
5774
5775    begin
5776       --  Insert explicit dereference if required
5777
5778       if Is_Access_Type (Ptyp) then
5779          Insert_Explicit_Dereference (P);
5780          Analyze_And_Resolve (P, Designated_Type (Ptyp));
5781
5782          if Ekind (Etype (P)) = E_Private_Subtype
5783            and then Is_For_Access_Subtype (Etype (P))
5784          then
5785             Set_Etype (P, Base_Type (Etype (P)));
5786          end if;
5787
5788          Ptyp := Etype (P);
5789       end if;
5790
5791       --  Deal with discriminant check required
5792
5793       if Do_Discriminant_Check (N) then
5794
5795          --  Present the discrminant checking function to the backend,
5796          --  so that it can inline the call to the function.
5797
5798          Add_Inlined_Body
5799            (Discriminant_Checking_Func
5800              (Original_Record_Component (Entity (Selector_Name (N)))));
5801
5802          --  Now reset the flag and generate the call
5803
5804          Set_Do_Discriminant_Check (N, False);
5805          Generate_Discriminant_Check (N);
5806       end if;
5807
5808       --  Gigi cannot handle unchecked conversions that are the prefix of a
5809       --  selected component with discriminants. This must be checked during
5810       --  expansion, because during analysis the type of the selector is not
5811       --  known at the point the prefix is analyzed. If the conversion is the
5812       --  target of an assignment, then we cannot force the evaluation.
5813
5814       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
5815         and then Has_Discriminants (Etype (N))
5816         and then not In_Left_Hand_Side (N)
5817       then
5818          Force_Evaluation (Prefix (N));
5819       end if;
5820
5821       --  Remaining processing applies only if selector is a discriminant
5822
5823       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
5824
5825          --  If the selector is a discriminant of a constrained record type,
5826          --  we may be able to rewrite the expression with the actual value
5827          --  of the discriminant, a useful optimization in some cases.
5828
5829          if Is_Record_Type (Ptyp)
5830            and then Has_Discriminants (Ptyp)
5831            and then Is_Constrained (Ptyp)
5832          then
5833             --  Do this optimization for discrete types only, and not for
5834             --  access types (access discriminants get us into trouble!)
5835
5836             if not Is_Discrete_Type (Etype (N)) then
5837                null;
5838
5839             --  Don't do this on the left hand of an assignment statement.
5840             --  Normally one would think that references like this would
5841             --  not occur, but they do in generated code, and mean that
5842             --  we really do want to assign the discriminant!
5843
5844             elsif Nkind (Par) = N_Assignment_Statement
5845               and then Name (Par) = N
5846             then
5847                null;
5848
5849             --  Don't do this optimization for the prefix of an attribute
5850             --  or the operand of an object renaming declaration since these
5851             --  are contexts where we do not want the value anyway.
5852
5853             elsif (Nkind (Par) = N_Attribute_Reference
5854                      and then Prefix (Par) = N)
5855               or else Is_Renamed_Object (N)
5856             then
5857                null;
5858
5859             --  Don't do this optimization if we are within the code for a
5860             --  discriminant check, since the whole point of such a check may
5861             --  be to verify the condition on which the code below depends!
5862
5863             elsif Is_In_Discriminant_Check (N) then
5864                null;
5865
5866             --  Green light to see if we can do the optimization. There is
5867             --  still one condition that inhibits the optimization below
5868             --  but now is the time to check the particular discriminant.
5869
5870             else
5871                --  Loop through discriminants to find the matching
5872                --  discriminant constraint to see if we can copy it.
5873
5874                Disc := First_Discriminant (Ptyp);
5875                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
5876                Discr_Loop : while Present (Dcon) loop
5877
5878                   --  Check if this is the matching discriminant
5879
5880                   if Disc = Entity (Selector_Name (N)) then
5881
5882                      --  Here we have the matching discriminant. Check for
5883                      --  the case of a discriminant of a component that is
5884                      --  constrained by an outer discriminant, which cannot
5885                      --  be optimized away.
5886
5887                      if
5888                        Denotes_Discriminant
5889                         (Node (Dcon), Check_Protected => True)
5890                      then
5891                         exit Discr_Loop;
5892
5893                      --  In the context of a case statement, the expression
5894                      --  may have the base type of the discriminant, and we
5895                      --  need to preserve the constraint to avoid spurious
5896                      --  errors on missing cases.
5897
5898                      elsif Nkind (Parent (N)) = N_Case_Statement
5899                        and then Etype (Node (Dcon)) /= Etype (Disc)
5900                      then
5901                         Rewrite (N,
5902                           Make_Qualified_Expression (Loc,
5903                             Subtype_Mark =>
5904                               New_Occurrence_Of (Etype (Disc), Loc),
5905                             Expression   =>
5906                               New_Copy_Tree (Node (Dcon))));
5907                         Analyze_And_Resolve (N, Etype (Disc));
5908
5909                         --  In case that comes out as a static expression,
5910                         --  reset it (a selected component is never static).
5911
5912                         Set_Is_Static_Expression (N, False);
5913                         return;
5914
5915                      --  Otherwise we can just copy the constraint, but the
5916                      --  result is certainly not static! In some cases the
5917                      --  discriminant constraint has been analyzed in the
5918                      --  context of the original subtype indication, but for
5919                      --  itypes the constraint might not have been analyzed
5920                      --  yet, and this must be done now.
5921
5922                      else
5923                         Rewrite (N, New_Copy_Tree (Node (Dcon)));
5924                         Analyze_And_Resolve (N);
5925                         Set_Is_Static_Expression (N, False);
5926                         return;
5927                      end if;
5928                   end if;
5929
5930                   Next_Elmt (Dcon);
5931                   Next_Discriminant (Disc);
5932                end loop Discr_Loop;
5933
5934                --  Note: the above loop should always find a matching
5935                --  discriminant, but if it does not, we just missed an
5936                --  optimization due to some glitch (perhaps a previous
5937                --  error), so ignore.
5938
5939             end if;
5940          end if;
5941
5942          --  The only remaining processing is in the case of a discriminant of
5943          --  a concurrent object, where we rewrite the prefix to denote the
5944          --  corresponding record type. If the type is derived and has renamed
5945          --  discriminants, use corresponding discriminant, which is the one
5946          --  that appears in the corresponding record.
5947
5948          if not Is_Concurrent_Type (Ptyp) then
5949             return;
5950          end if;
5951
5952          Disc := Entity (Selector_Name (N));
5953
5954          if Is_Derived_Type (Ptyp)
5955            and then Present (Corresponding_Discriminant (Disc))
5956          then
5957             Disc := Corresponding_Discriminant (Disc);
5958          end if;
5959
5960          New_N :=
5961            Make_Selected_Component (Loc,
5962              Prefix =>
5963                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
5964                  New_Copy_Tree (P)),
5965              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
5966
5967          Rewrite (N, New_N);
5968          Analyze (N);
5969       end if;
5970    end Expand_N_Selected_Component;
5971
5972    --------------------
5973    -- Expand_N_Slice --
5974    --------------------
5975
5976    procedure Expand_N_Slice (N : Node_Id) is
5977       Loc  : constant Source_Ptr := Sloc (N);
5978       Typ  : constant Entity_Id  := Etype (N);
5979       Pfx  : constant Node_Id    := Prefix (N);
5980       Ptp  : Entity_Id           := Etype (Pfx);
5981
5982       function Is_Procedure_Actual (N : Node_Id) return Boolean;
5983       --  Check whether the argument is an actual for a procedure call,
5984       --  in which case the expansion of a bit-packed slice is deferred
5985       --  until the call itself is expanded. The reason this is required
5986       --  is that we might have an IN OUT or OUT parameter, and the copy out
5987       --  is essential, and that copy out would be missed if we created a
5988       --  temporary here in Expand_N_Slice. Note that we don't bother
5989       --  to test specifically for an IN OUT or OUT mode parameter, since it
5990       --  is a bit tricky to do, and it is harmless to defer expansion
5991       --  in the IN case, since the call processing will still generate the
5992       --  appropriate copy in operation, which will take care of the slice.
5993
5994       procedure Make_Temporary;
5995       --  Create a named variable for the value of the slice, in
5996       --  cases where the back-end cannot handle it properly, e.g.
5997       --  when packed types or unaligned slices are involved.
5998
5999       -------------------------
6000       -- Is_Procedure_Actual --
6001       -------------------------
6002
6003       function Is_Procedure_Actual (N : Node_Id) return Boolean is
6004          Par : Node_Id := Parent (N);
6005
6006       begin
6007          loop
6008             --  If our parent is a procedure call we can return
6009
6010             if Nkind (Par) = N_Procedure_Call_Statement then
6011                return True;
6012
6013             --  If our parent is a type conversion, keep climbing the
6014             --  tree, since a type conversion can be a procedure actual.
6015             --  Also keep climbing if parameter association or a qualified
6016             --  expression, since these are additional cases that do can
6017             --  appear on procedure actuals.
6018
6019             elsif Nkind (Par) = N_Type_Conversion
6020               or else Nkind (Par) = N_Parameter_Association
6021               or else Nkind (Par) = N_Qualified_Expression
6022             then
6023                Par := Parent (Par);
6024
6025                --  Any other case is not what we are looking for
6026
6027             else
6028                return False;
6029             end if;
6030          end loop;
6031       end Is_Procedure_Actual;
6032
6033       --------------------
6034       -- Make_Temporary --
6035       --------------------
6036
6037       procedure Make_Temporary is
6038          Decl : Node_Id;
6039          Ent  : constant Entity_Id :=
6040                   Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
6041       begin
6042          Decl :=
6043            Make_Object_Declaration (Loc,
6044              Defining_Identifier => Ent,
6045              Object_Definition   => New_Occurrence_Of (Typ, Loc));
6046
6047          Set_No_Initialization (Decl);
6048
6049          Insert_Actions (N, New_List (
6050            Decl,
6051            Make_Assignment_Statement (Loc,
6052              Name => New_Occurrence_Of (Ent, Loc),
6053              Expression => Relocate_Node (N))));
6054
6055          Rewrite (N, New_Occurrence_Of (Ent, Loc));
6056          Analyze_And_Resolve (N, Typ);
6057       end Make_Temporary;
6058
6059    --  Start of processing for Expand_N_Slice
6060
6061    begin
6062       --  Special handling for access types
6063
6064       if Is_Access_Type (Ptp) then
6065
6066          Ptp := Designated_Type (Ptp);
6067
6068          Rewrite (Pfx,
6069            Make_Explicit_Dereference (Sloc (N),
6070             Prefix => Relocate_Node (Pfx)));
6071
6072          Analyze_And_Resolve (Pfx, Ptp);
6073       end if;
6074
6075       --  Range checks are potentially also needed for cases involving
6076       --  a slice indexed by a subtype indication, but Do_Range_Check
6077       --  can currently only be set for expressions ???
6078
6079       if not Index_Checks_Suppressed (Ptp)
6080         and then (not Is_Entity_Name (Pfx)
6081                    or else not Index_Checks_Suppressed (Entity (Pfx)))
6082         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
6083       then
6084          Enable_Range_Check (Discrete_Range (N));
6085       end if;
6086
6087       --  The remaining case to be handled is packed slices. We can leave
6088       --  packed slices as they are in the following situations:
6089
6090       --    1. Right or left side of an assignment (we can handle this
6091       --       situation correctly in the assignment statement expansion).
6092
6093       --    2. Prefix of indexed component (the slide is optimized away
6094       --       in this case, see the start of Expand_N_Slice.
6095
6096       --    3. Object renaming declaration, since we want the name of
6097       --       the slice, not the value.
6098
6099       --    4. Argument to procedure call, since copy-in/copy-out handling
6100       --       may be required, and this is handled in the expansion of
6101       --       call itself.
6102
6103       --    5. Prefix of an address attribute (this is an error which
6104       --       is caught elsewhere, and the expansion would intefere
6105       --       with generating the error message).
6106
6107       if not Is_Packed (Typ) then
6108
6109          --  Apply transformation for actuals of a function call,
6110          --  where Expand_Actuals is not used.
6111
6112          if Nkind (Parent (N)) = N_Function_Call
6113            and then Is_Possibly_Unaligned_Slice (N)
6114          then
6115             Make_Temporary;
6116          end if;
6117
6118       elsif Nkind (Parent (N)) = N_Assignment_Statement
6119         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
6120                    and then Parent (N) = Name (Parent (Parent (N))))
6121       then
6122          return;
6123
6124       elsif Nkind (Parent (N)) = N_Indexed_Component
6125         or else Is_Renamed_Object (N)
6126         or else Is_Procedure_Actual (N)
6127       then
6128          return;
6129
6130       elsif Nkind (Parent (N)) = N_Attribute_Reference
6131         and then Attribute_Name (Parent (N)) = Name_Address
6132       then
6133          return;
6134
6135       else
6136          Make_Temporary;
6137       end if;
6138    end Expand_N_Slice;
6139
6140    ------------------------------
6141    -- Expand_N_Type_Conversion --
6142    ------------------------------
6143
6144    procedure Expand_N_Type_Conversion (N : Node_Id) is
6145       Loc          : constant Source_Ptr := Sloc (N);
6146       Operand      : constant Node_Id    := Expression (N);
6147       Target_Type  : constant Entity_Id  := Etype (N);
6148       Operand_Type : Entity_Id           := Etype (Operand);
6149
6150       procedure Handle_Changed_Representation;
6151       --  This is called in the case of record and array type conversions
6152       --  to see if there is a change of representation to be handled.
6153       --  Change of representation is actually handled at the assignment
6154       --  statement level, and what this procedure does is rewrite node N
6155       --  conversion as an assignment to temporary. If there is no change
6156       --  of representation, then the conversion node is unchanged.
6157
6158       procedure Real_Range_Check;
6159       --  Handles generation of range check for real target value
6160
6161       -----------------------------------
6162       -- Handle_Changed_Representation --
6163       -----------------------------------
6164
6165       procedure Handle_Changed_Representation is
6166          Temp : Entity_Id;
6167          Decl : Node_Id;
6168          Odef : Node_Id;
6169          Disc : Node_Id;
6170          N_Ix : Node_Id;
6171          Cons : List_Id;
6172
6173       begin
6174          --  Nothing to do if no change of representation
6175
6176          if Same_Representation (Operand_Type, Target_Type) then
6177             return;
6178
6179          --  The real change of representation work is done by the assignment
6180          --  statement processing. So if this type conversion is appearing as
6181          --  the expression of an assignment statement, nothing needs to be
6182          --  done to the conversion.
6183
6184          elsif Nkind (Parent (N)) = N_Assignment_Statement then
6185             return;
6186
6187          --  Otherwise we need to generate a temporary variable, and do the
6188          --  change of representation assignment into that temporary variable.
6189          --  The conversion is then replaced by a reference to this variable.
6190
6191          else
6192             Cons := No_List;
6193
6194             --  If type is unconstrained we have to add a constraint,
6195             --  copied from the actual value of the left hand side.
6196
6197             if not Is_Constrained (Target_Type) then
6198                if Has_Discriminants (Operand_Type) then
6199                   Disc := First_Discriminant (Operand_Type);
6200
6201                   if Disc /= First_Stored_Discriminant (Operand_Type) then
6202                      Disc := First_Stored_Discriminant (Operand_Type);
6203                   end if;
6204
6205                   Cons := New_List;
6206                   while Present (Disc) loop
6207                      Append_To (Cons,
6208                        Make_Selected_Component (Loc,
6209                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
6210                          Selector_Name =>
6211                            Make_Identifier (Loc, Chars (Disc))));
6212                      Next_Discriminant (Disc);
6213                   end loop;
6214
6215                elsif Is_Array_Type (Operand_Type) then
6216                   N_Ix := First_Index (Target_Type);
6217                   Cons := New_List;
6218
6219                   for J in 1 .. Number_Dimensions (Operand_Type) loop
6220
6221                      --  We convert the bounds explicitly. We use an unchecked
6222                      --  conversion because bounds checks are done elsewhere.
6223
6224                      Append_To (Cons,
6225                        Make_Range (Loc,
6226                          Low_Bound =>
6227                            Unchecked_Convert_To (Etype (N_Ix),
6228                              Make_Attribute_Reference (Loc,
6229                                Prefix =>
6230                                  Duplicate_Subexpr_No_Checks
6231                                    (Operand, Name_Req => True),
6232                                Attribute_Name => Name_First,
6233                                Expressions    => New_List (
6234                                  Make_Integer_Literal (Loc, J)))),
6235
6236                          High_Bound =>
6237                            Unchecked_Convert_To (Etype (N_Ix),
6238                              Make_Attribute_Reference (Loc,
6239                                Prefix =>
6240                                  Duplicate_Subexpr_No_Checks
6241                                    (Operand, Name_Req => True),
6242                                Attribute_Name => Name_Last,
6243                                Expressions    => New_List (
6244                                  Make_Integer_Literal (Loc, J))))));
6245
6246                      Next_Index (N_Ix);
6247                   end loop;
6248                end if;
6249             end if;
6250
6251             Odef := New_Occurrence_Of (Target_Type, Loc);
6252
6253             if Present (Cons) then
6254                Odef :=
6255                  Make_Subtype_Indication (Loc,
6256                    Subtype_Mark => Odef,
6257                    Constraint =>
6258                      Make_Index_Or_Discriminant_Constraint (Loc,
6259                        Constraints => Cons));
6260             end if;
6261
6262             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
6263             Decl :=
6264               Make_Object_Declaration (Loc,
6265                 Defining_Identifier => Temp,
6266                 Object_Definition   => Odef);
6267
6268             Set_No_Initialization (Decl, True);
6269
6270             --  Insert required actions. It is essential to suppress checks
6271             --  since we have suppressed default initialization, which means
6272             --  that the variable we create may have no discriminants.
6273
6274             Insert_Actions (N,
6275               New_List (
6276                 Decl,
6277                 Make_Assignment_Statement (Loc,
6278                   Name => New_Occurrence_Of (Temp, Loc),
6279                   Expression => Relocate_Node (N))),
6280                 Suppress => All_Checks);
6281
6282             Rewrite (N, New_Occurrence_Of (Temp, Loc));
6283             return;
6284          end if;
6285       end Handle_Changed_Representation;
6286
6287       ----------------------
6288       -- Real_Range_Check --
6289       ----------------------
6290
6291       --  Case of conversions to floating-point or fixed-point. If range
6292       --  checks are enabled and the target type has a range constraint,
6293       --  we convert:
6294
6295       --     typ (x)
6296
6297       --       to
6298
6299       --     Tnn : typ'Base := typ'Base (x);
6300       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6301       --     Tnn
6302
6303       --  This is necessary when there is a conversion of integer to float
6304       --  or to fixed-point to ensure that the correct checks are made. It
6305       --  is not necessary for float to float where it is enough to simply
6306       --  set the Do_Range_Check flag.
6307
6308       procedure Real_Range_Check is
6309          Btyp : constant Entity_Id := Base_Type (Target_Type);
6310          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
6311          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
6312          Xtyp : constant Entity_Id := Etype (Operand);
6313          Conv : Node_Id;
6314          Tnn  : Entity_Id;
6315
6316       begin
6317          --  Nothing to do if conversion was rewritten
6318
6319          if Nkind (N) /= N_Type_Conversion then
6320             return;
6321          end if;
6322
6323          --  Nothing to do if range checks suppressed, or target has the
6324          --  same range as the base type (or is the base type).
6325
6326          if Range_Checks_Suppressed (Target_Type)
6327            or else (Lo = Type_Low_Bound (Btyp)
6328                       and then
6329                     Hi = Type_High_Bound (Btyp))
6330          then
6331             return;
6332          end if;
6333
6334          --  Nothing to do if expression is an entity on which checks
6335          --  have been suppressed.
6336
6337          if Is_Entity_Name (Operand)
6338            and then Range_Checks_Suppressed (Entity (Operand))
6339          then
6340             return;
6341          end if;
6342
6343          --  Nothing to do if bounds are all static and we can tell that
6344          --  the expression is within the bounds of the target. Note that
6345          --  if the operand is of an unconstrained floating-point type,
6346          --  then we do not trust it to be in range (might be infinite)
6347
6348          declare
6349             S_Lo : constant Node_Id   := Type_Low_Bound (Xtyp);
6350             S_Hi : constant Node_Id   := Type_High_Bound (Xtyp);
6351
6352          begin
6353             if (not Is_Floating_Point_Type (Xtyp)
6354                  or else Is_Constrained (Xtyp))
6355               and then Compile_Time_Known_Value (S_Lo)
6356               and then Compile_Time_Known_Value (S_Hi)
6357               and then Compile_Time_Known_Value (Hi)
6358               and then Compile_Time_Known_Value (Lo)
6359             then
6360                declare
6361                   D_Lov : constant Ureal := Expr_Value_R (Lo);
6362                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
6363                   S_Lov : Ureal;
6364                   S_Hiv : Ureal;
6365
6366                begin
6367                   if Is_Real_Type (Xtyp) then
6368                      S_Lov := Expr_Value_R (S_Lo);
6369                      S_Hiv := Expr_Value_R (S_Hi);
6370                   else
6371                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
6372                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
6373                   end if;
6374
6375                   if D_Hiv > D_Lov
6376                     and then S_Lov >= D_Lov
6377                     and then S_Hiv <= D_Hiv
6378                   then
6379                      Set_Do_Range_Check (Operand, False);
6380                      return;
6381                   end if;
6382                end;
6383             end if;
6384          end;
6385
6386          --  For float to float conversions, we are done
6387
6388          if Is_Floating_Point_Type (Xtyp)
6389               and then
6390             Is_Floating_Point_Type (Btyp)
6391          then
6392             return;
6393          end if;
6394
6395          --  Otherwise rewrite the conversion as described above
6396
6397          Conv := Relocate_Node (N);
6398          Rewrite
6399            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
6400          Set_Etype (Conv, Btyp);
6401
6402          --  Enable overflow except in the case of integer to float
6403          --  conversions, where it is never required, since we can
6404          --  never have overflow in this case.
6405
6406          if not Is_Integer_Type (Etype (Operand)) then
6407             Enable_Overflow_Check (Conv);
6408          end if;
6409
6410          Tnn :=
6411            Make_Defining_Identifier (Loc,
6412              Chars => New_Internal_Name ('T'));
6413
6414          Insert_Actions (N, New_List (
6415            Make_Object_Declaration (Loc,
6416              Defining_Identifier => Tnn,
6417              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
6418              Expression => Conv),
6419
6420            Make_Raise_Constraint_Error (Loc,
6421              Condition =>
6422               Make_Or_Else (Loc,
6423                 Left_Opnd =>
6424                   Make_Op_Lt (Loc,
6425                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
6426                     Right_Opnd =>
6427                       Make_Attribute_Reference (Loc,
6428                         Attribute_Name => Name_First,
6429                         Prefix =>
6430                           New_Occurrence_Of (Target_Type, Loc))),
6431
6432                 Right_Opnd =>
6433                   Make_Op_Gt (Loc,
6434                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
6435                     Right_Opnd =>
6436                       Make_Attribute_Reference (Loc,
6437                         Attribute_Name => Name_Last,
6438                         Prefix =>
6439                           New_Occurrence_Of (Target_Type, Loc)))),
6440              Reason => CE_Range_Check_Failed)));
6441
6442          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6443          Analyze_And_Resolve (N, Btyp);
6444       end Real_Range_Check;
6445
6446    --  Start of processing for Expand_N_Type_Conversion
6447
6448    begin
6449       --  Nothing at all to do if conversion is to the identical type
6450       --  so remove the conversion completely, it is useless.
6451
6452       if Operand_Type = Target_Type then
6453          Rewrite (N, Relocate_Node (Operand));
6454          return;
6455       end if;
6456
6457       --  Deal with Vax floating-point cases
6458
6459       if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
6460          Expand_Vax_Conversion (N);
6461          return;
6462       end if;
6463
6464       --  Nothing to do if this is the second argument of read. This
6465       --  is a "backwards" conversion that will be handled by the
6466       --  specialized code in attribute processing.
6467
6468       if Nkind (Parent (N)) = N_Attribute_Reference
6469         and then Attribute_Name (Parent (N)) = Name_Read
6470         and then Next (First (Expressions (Parent (N)))) = N
6471       then
6472          return;
6473       end if;
6474
6475       --  Here if we may need to expand conversion
6476
6477       --  Special case of converting from non-standard boolean type
6478
6479       if Is_Boolean_Type (Operand_Type)
6480         and then (Nonzero_Is_True (Operand_Type))
6481       then
6482          Adjust_Condition (Operand);
6483          Set_Etype (Operand, Standard_Boolean);
6484          Operand_Type := Standard_Boolean;
6485       end if;
6486
6487       --  Case of converting to an access type
6488
6489       if Is_Access_Type (Target_Type) then
6490
6491          --  Apply an accessibility check if the operand is an
6492          --  access parameter. Note that other checks may still
6493          --  need to be applied below (such as tagged type checks).
6494
6495          if Is_Entity_Name (Operand)
6496            and then Ekind (Entity (Operand)) in Formal_Kind
6497            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
6498          then
6499             Apply_Accessibility_Check (Operand, Target_Type);
6500
6501          --  If the level of the operand type is statically deeper
6502          --  then the level of the target type, then force Program_Error.
6503          --  Note that this can only occur for cases where the attribute
6504          --  is within the body of an instantiation (otherwise the
6505          --  conversion will already have been rejected as illegal).
6506          --  Note: warnings are issued by the analyzer for the instance
6507          --  cases.
6508
6509          elsif In_Instance_Body
6510            and then Type_Access_Level (Operand_Type) >
6511                     Type_Access_Level (Target_Type)
6512          then
6513             Rewrite (N,
6514               Make_Raise_Program_Error (Sloc (N),
6515                 Reason => PE_Accessibility_Check_Failed));
6516             Set_Etype (N, Target_Type);
6517
6518          --  When the operand is a selected access discriminant
6519          --  the check needs to be made against the level of the
6520          --  object denoted by the prefix of the selected name.
6521          --  Force Program_Error for this case as well (this
6522          --  accessibility violation can only happen if within
6523          --  the body of an instantiation).
6524
6525          elsif In_Instance_Body
6526            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
6527            and then Nkind (Operand) = N_Selected_Component
6528            and then Object_Access_Level (Operand) >
6529                       Type_Access_Level (Target_Type)
6530          then
6531             Rewrite (N,
6532               Make_Raise_Program_Error (Sloc (N),
6533                 Reason => PE_Accessibility_Check_Failed));
6534             Set_Etype (N, Target_Type);
6535          end if;
6536       end if;
6537
6538       --  Case of conversions of tagged types and access to tagged types
6539
6540       --  When needed, that is to say when the expression is class-wide,
6541       --  Add runtime a tag check for (strict) downward conversion by using
6542       --  the membership test, generating:
6543
6544       --      [constraint_error when Operand not in Target_Type'Class]
6545
6546       --  or in the access type case
6547
6548       --      [constraint_error
6549       --        when Operand /= null
6550       --          and then Operand.all not in
6551       --            Designated_Type (Target_Type)'Class]
6552
6553       if (Is_Access_Type (Target_Type)
6554            and then Is_Tagged_Type (Designated_Type (Target_Type)))
6555         or else Is_Tagged_Type (Target_Type)
6556       then
6557          --  Do not do any expansion in the access type case if the
6558          --  parent is a renaming, since this is an error situation
6559          --  which will be caught by Sem_Ch8, and the expansion can
6560          --  intefere with this error check.
6561
6562          if Is_Access_Type (Target_Type)
6563            and then Is_Renamed_Object (N)
6564          then
6565             return;
6566          end if;
6567
6568          --  Oherwise, proceed with processing tagged conversion
6569
6570          declare
6571             Actual_Operand_Type : Entity_Id;
6572             Actual_Target_Type  : Entity_Id;
6573
6574             Cond : Node_Id;
6575
6576          begin
6577             if Is_Access_Type (Target_Type) then
6578                Actual_Operand_Type := Designated_Type (Operand_Type);
6579                Actual_Target_Type  := Designated_Type (Target_Type);
6580
6581             else
6582                Actual_Operand_Type := Operand_Type;
6583                Actual_Target_Type  := Target_Type;
6584             end if;
6585
6586             if Is_Class_Wide_Type (Actual_Operand_Type)
6587               and then Root_Type (Actual_Operand_Type) /=  Actual_Target_Type
6588               and then Is_Ancestor
6589                          (Root_Type (Actual_Operand_Type),
6590                           Actual_Target_Type)
6591               and then not Tag_Checks_Suppressed (Actual_Target_Type)
6592             then
6593                --  The conversion is valid for any descendant of the
6594                --  target type
6595
6596                Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
6597
6598                if Is_Access_Type (Target_Type) then
6599                   Cond :=
6600                      Make_And_Then (Loc,
6601                        Left_Opnd =>
6602                          Make_Op_Ne (Loc,
6603                            Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
6604                            Right_Opnd => Make_Null (Loc)),
6605
6606                        Right_Opnd =>
6607                          Make_Not_In (Loc,
6608                            Left_Opnd  =>
6609                              Make_Explicit_Dereference (Loc,
6610                                Prefix =>
6611                                  Duplicate_Subexpr_No_Checks (Operand)),
6612                            Right_Opnd =>
6613                              New_Reference_To (Actual_Target_Type, Loc)));
6614
6615                else
6616                   Cond :=
6617                     Make_Not_In (Loc,
6618                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
6619                       Right_Opnd =>
6620                         New_Reference_To (Actual_Target_Type, Loc));
6621                end if;
6622
6623                Insert_Action (N,
6624                  Make_Raise_Constraint_Error (Loc,
6625                    Condition => Cond,
6626                    Reason    => CE_Tag_Check_Failed));
6627
6628                declare
6629                   Conv : Node_Id;
6630                begin
6631                   Conv :=
6632                     Make_Unchecked_Type_Conversion (Loc,
6633                       Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
6634                       Expression => Relocate_Node (Expression (N)));
6635                   Rewrite (N, Conv);
6636                   Analyze_And_Resolve (N, Target_Type);
6637                end;
6638             end if;
6639          end;
6640
6641       --  Case of other access type conversions
6642
6643       elsif Is_Access_Type (Target_Type) then
6644          Apply_Constraint_Check (Operand, Target_Type);
6645
6646       --  Case of conversions from a fixed-point type
6647
6648       --  These conversions require special expansion and processing, found
6649       --  in the Exp_Fixd package. We ignore cases where Conversion_OK is
6650       --  set, since from a semantic point of view, these are simple integer
6651       --  conversions, which do not need further processing.
6652
6653       elsif Is_Fixed_Point_Type (Operand_Type)
6654         and then not Conversion_OK (N)
6655       then
6656          --  We should never see universal fixed at this case, since the
6657          --  expansion of the constituent divide or multiply should have
6658          --  eliminated the explicit mention of universal fixed.
6659
6660          pragma Assert (Operand_Type /= Universal_Fixed);
6661
6662          --  Check for special case of the conversion to universal real
6663          --  that occurs as a result of the use of a round attribute.
6664          --  In this case, the real type for the conversion is taken
6665          --  from the target type of the Round attribute and the
6666          --  result must be marked as rounded.
6667
6668          if Target_Type = Universal_Real
6669            and then Nkind (Parent (N)) = N_Attribute_Reference
6670            and then Attribute_Name (Parent (N)) = Name_Round
6671          then
6672             Set_Rounded_Result (N);
6673             Set_Etype (N, Etype (Parent (N)));
6674          end if;
6675
6676          --  Otherwise do correct fixed-conversion, but skip these if the
6677          --  Conversion_OK flag is set, because from a semantic point of
6678          --  view these are simple integer conversions needing no further
6679          --  processing (the backend will simply treat them as integers)
6680
6681          if not Conversion_OK (N) then
6682             if Is_Fixed_Point_Type (Etype (N)) then
6683                Expand_Convert_Fixed_To_Fixed (N);
6684                Real_Range_Check;
6685
6686             elsif Is_Integer_Type (Etype (N)) then
6687                Expand_Convert_Fixed_To_Integer (N);
6688
6689             else
6690                pragma Assert (Is_Floating_Point_Type (Etype (N)));
6691                Expand_Convert_Fixed_To_Float (N);
6692                Real_Range_Check;
6693             end if;
6694          end if;
6695
6696       --  Case of conversions to a fixed-point type
6697
6698       --  These conversions require special expansion and processing, found
6699       --  in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6700       --  is set, since from a semantic point of view, these are simple
6701       --  integer conversions, which do not need further processing.
6702
6703       elsif Is_Fixed_Point_Type (Target_Type)
6704         and then not Conversion_OK (N)
6705       then
6706          if Is_Integer_Type (Operand_Type) then
6707             Expand_Convert_Integer_To_Fixed (N);
6708             Real_Range_Check;
6709          else
6710             pragma Assert (Is_Floating_Point_Type (Operand_Type));
6711             Expand_Convert_Float_To_Fixed (N);
6712             Real_Range_Check;
6713          end if;
6714
6715       --  Case of float-to-integer conversions
6716
6717       --  We also handle float-to-fixed conversions with Conversion_OK set
6718       --  since semantically the fixed-point target is treated as though it
6719       --  were an integer in such cases.
6720
6721       elsif Is_Floating_Point_Type (Operand_Type)
6722         and then
6723           (Is_Integer_Type (Target_Type)
6724             or else
6725           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
6726       then
6727          --  Special processing required if the conversion is the expression
6728          --  of a Truncation attribute reference. In this case we replace:
6729
6730          --     ityp (ftyp'Truncation (x))
6731
6732          --  by
6733
6734          --     ityp (x)
6735
6736          --  with the Float_Truncate flag set. This is clearly more efficient
6737
6738          if Nkind (Operand) = N_Attribute_Reference
6739            and then Attribute_Name (Operand) = Name_Truncation
6740          then
6741             Rewrite (Operand,
6742               Relocate_Node (First (Expressions (Operand))));
6743             Set_Float_Truncate (N, True);
6744          end if;
6745
6746          --  One more check here, gcc is still not able to do conversions of
6747          --  this type with proper overflow checking, and so gigi is doing an
6748          --  approximation of what is required by doing floating-point compares
6749          --  with the end-point. But that can lose precision in some cases, and
6750          --  give a wrong result. Converting the operand to Long_Long_Float is
6751          --  helpful, but still does not catch all cases with 64-bit integers
6752          --  on targets with only 64-bit floats ???
6753
6754          if Do_Range_Check (Operand) then
6755             Rewrite (Operand,
6756               Make_Type_Conversion (Loc,
6757                 Subtype_Mark =>
6758                   New_Occurrence_Of (Standard_Long_Long_Float, Loc),
6759                 Expression =>
6760                   Relocate_Node (Operand)));
6761
6762             Set_Etype (Operand, Standard_Long_Long_Float);
6763             Enable_Range_Check (Operand);
6764             Set_Do_Range_Check (Expression (Operand), False);
6765          end if;
6766
6767       --  Case of array conversions
6768
6769       --  Expansion of array conversions, add required length/range checks
6770       --  but only do this if there is no change of representation. For
6771       --  handling of this case, see Handle_Changed_Representation.
6772
6773       elsif Is_Array_Type (Target_Type) then
6774
6775          if Is_Constrained (Target_Type) then
6776             Apply_Length_Check (Operand, Target_Type);
6777          else
6778             Apply_Range_Check (Operand, Target_Type);
6779          end if;
6780
6781          Handle_Changed_Representation;
6782
6783       --  Case of conversions of discriminated types
6784
6785       --  Add required discriminant checks if target is constrained. Again
6786       --  this change is skipped if we have a change of representation.
6787
6788       elsif Has_Discriminants (Target_Type)
6789         and then Is_Constrained (Target_Type)
6790       then
6791          Apply_Discriminant_Check (Operand, Target_Type);
6792          Handle_Changed_Representation;
6793
6794       --  Case of all other record conversions. The only processing required
6795       --  is to check for a change of representation requiring the special
6796       --  assignment processing.
6797
6798       elsif Is_Record_Type (Target_Type) then
6799
6800          --  Ada 2005 (AI-216): Program_Error is raised when converting from
6801          --  a derived Unchecked_Union type to an unconstrained non-Unchecked_
6802          --  Union type if the operand lacks inferable discriminants.
6803
6804          if Is_Derived_Type (Operand_Type)
6805            and then Is_Unchecked_Union (Base_Type (Operand_Type))
6806            and then not Is_Constrained (Target_Type)
6807            and then not Is_Unchecked_Union (Base_Type (Target_Type))
6808            and then not Has_Inferable_Discriminants (Operand)
6809          then
6810             --  To prevent Gigi from generating illegal code, we make a
6811             --  Program_Error node, but we give it the target type of the
6812             --  conversion.
6813
6814             declare
6815                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
6816                       Reason => PE_Unchecked_Union_Restriction);
6817
6818             begin
6819                Set_Etype (PE, Target_Type);
6820                Rewrite (N, PE);
6821
6822             end;
6823          else
6824             Handle_Changed_Representation;
6825          end if;
6826
6827       --  Case of conversions of enumeration types
6828
6829       elsif Is_Enumeration_Type (Target_Type) then
6830
6831          --  Special processing is required if there is a change of
6832          --  representation (from enumeration representation clauses)
6833
6834          if not Same_Representation (Target_Type, Operand_Type) then
6835
6836             --  Convert: x(y) to x'val (ytyp'val (y))
6837
6838             Rewrite (N,
6839                Make_Attribute_Reference (Loc,
6840                  Prefix => New_Occurrence_Of (Target_Type, Loc),
6841                  Attribute_Name => Name_Val,
6842                  Expressions => New_List (
6843                    Make_Attribute_Reference (Loc,
6844                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
6845                      Attribute_Name => Name_Pos,
6846                      Expressions => New_List (Operand)))));
6847
6848             Analyze_And_Resolve (N, Target_Type);
6849          end if;
6850
6851       --  Case of conversions to floating-point
6852
6853       elsif Is_Floating_Point_Type (Target_Type) then
6854          Real_Range_Check;
6855
6856       --  The remaining cases require no front end processing
6857
6858       else
6859          null;
6860       end if;
6861
6862       --  At this stage, either the conversion node has been transformed
6863       --  into some other equivalent expression, or left as a conversion
6864       --  that can be handled by Gigi. The conversions that Gigi can handle
6865       --  are the following:
6866
6867       --    Conversions with no change of representation or type
6868
6869       --    Numeric conversions involving integer values, floating-point
6870       --    values, and fixed-point values. Fixed-point values are allowed
6871       --    only if Conversion_OK is set, i.e. if the fixed-point values
6872       --    are to be treated as integers.
6873
6874       --  No other conversions should be passed to Gigi
6875
6876       --  Check: are these rules stated in sinfo??? if so, why restate here???
6877
6878       --  The only remaining step is to generate a range check if we still
6879       --  have a type conversion at this stage and Do_Range_Check is set.
6880       --  For now we do this only for conversions of discrete types.
6881
6882       if Nkind (N) = N_Type_Conversion
6883         and then Is_Discrete_Type (Etype (N))
6884       then
6885          declare
6886             Expr : constant Node_Id := Expression (N);
6887             Ftyp : Entity_Id;
6888             Ityp : Entity_Id;
6889
6890          begin
6891             if Do_Range_Check (Expr)
6892               and then Is_Discrete_Type (Etype (Expr))
6893             then
6894                Set_Do_Range_Check (Expr, False);
6895
6896                --  Before we do a range check, we have to deal with treating
6897                --  a fixed-point operand as an integer. The way we do this
6898                --  is simply to do an unchecked conversion to an appropriate
6899                --  integer type large enough to hold the result.
6900
6901                --  This code is not active yet, because we are only dealing
6902                --  with discrete types so far ???
6903
6904                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
6905                  and then Treat_Fixed_As_Integer (Expr)
6906                then
6907                   Ftyp := Base_Type (Etype (Expr));
6908
6909                   if Esize (Ftyp) >= Esize (Standard_Integer) then
6910                      Ityp := Standard_Long_Long_Integer;
6911                   else
6912                      Ityp := Standard_Integer;
6913                   end if;
6914
6915                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
6916                end if;
6917
6918                --  Reset overflow flag, since the range check will include
6919                --  dealing with possible overflow, and generate the check
6920                --  If Address is either source or target type, suppress
6921                --  range check to avoid typing anomalies when it is a visible
6922                --  integer type.
6923
6924                Set_Do_Overflow_Check (N, False);
6925                if not Is_Descendent_Of_Address (Etype (Expr))
6926                  and then not Is_Descendent_Of_Address (Target_Type)
6927                then
6928                   Generate_Range_Check
6929                     (Expr, Target_Type, CE_Range_Check_Failed);
6930                end if;
6931             end if;
6932          end;
6933       end if;
6934    end Expand_N_Type_Conversion;
6935
6936    -----------------------------------
6937    -- Expand_N_Unchecked_Expression --
6938    -----------------------------------
6939
6940    --  Remove the unchecked expression node from the tree. It's job was simply
6941    --  to make sure that its constituent expression was handled with checks
6942    --  off, and now that that is done, we can remove it from the tree, and
6943    --  indeed must, since gigi does not expect to see these nodes.
6944
6945    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
6946       Exp : constant Node_Id := Expression (N);
6947
6948    begin
6949       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
6950       Rewrite (N, Exp);
6951    end Expand_N_Unchecked_Expression;
6952
6953    ----------------------------------------
6954    -- Expand_N_Unchecked_Type_Conversion --
6955    ----------------------------------------
6956
6957    --  If this cannot be handled by Gigi and we haven't already made
6958    --  a temporary for it, do it now.
6959
6960    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
6961       Target_Type  : constant Entity_Id := Etype (N);
6962       Operand      : constant Node_Id   := Expression (N);
6963       Operand_Type : constant Entity_Id := Etype (Operand);
6964
6965    begin
6966       --  If we have a conversion of a compile time known value to a target
6967       --  type and the value is in range of the target type, then we can simply
6968       --  replace the construct by an integer literal of the correct type. We
6969       --  only apply this to integer types being converted. Possibly it may
6970       --  apply in other cases, but it is too much trouble to worry about.
6971
6972       --  Note that we do not do this transformation if the Kill_Range_Check
6973       --  flag is set, since then the value may be outside the expected range.
6974       --  This happens in the Normalize_Scalars case.
6975
6976       if Is_Integer_Type (Target_Type)
6977         and then Is_Integer_Type (Operand_Type)
6978         and then Compile_Time_Known_Value (Operand)
6979         and then not Kill_Range_Check (N)
6980       then
6981          declare
6982             Val : constant Uint := Expr_Value (Operand);
6983
6984          begin
6985             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
6986                  and then
6987                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
6988                  and then
6989                Val >= Expr_Value (Type_Low_Bound (Target_Type))
6990                  and then
6991                Val <= Expr_Value (Type_High_Bound (Target_Type))
6992             then
6993                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
6994
6995                --  If Address is the target type, just set the type
6996                --  to avoid a spurious type error on the literal when
6997                --  Address is a visible integer type.
6998
6999                if Is_Descendent_Of_Address (Target_Type) then
7000                   Set_Etype (N, Target_Type);
7001                else
7002                   Analyze_And_Resolve (N, Target_Type);
7003                end if;
7004
7005                return;
7006             end if;
7007          end;
7008       end if;
7009
7010       --  Nothing to do if conversion is safe
7011
7012       if Safe_Unchecked_Type_Conversion (N) then
7013          return;
7014       end if;
7015
7016       --  Otherwise force evaluation unless Assignment_OK flag is set (this
7017       --  flag indicates ??? -- more comments needed here)
7018
7019       if Assignment_OK (N) then
7020          null;
7021       else
7022          Force_Evaluation (N);
7023       end if;
7024    end Expand_N_Unchecked_Type_Conversion;
7025
7026    ----------------------------
7027    -- Expand_Record_Equality --
7028    ----------------------------
7029
7030    --  For non-variant records, Equality is expanded when needed into:
7031
7032    --      and then Lhs.Discr1 = Rhs.Discr1
7033    --      and then ...
7034    --      and then Lhs.Discrn = Rhs.Discrn
7035    --      and then Lhs.Cmp1 = Rhs.Cmp1
7036    --      and then ...
7037    --      and then Lhs.Cmpn = Rhs.Cmpn
7038
7039    --  The expression is folded by the back-end for adjacent fields. This
7040    --  function is called for tagged record in only one occasion: for imple-
7041    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
7042    --  otherwise the primitive "=" is used directly.
7043
7044    function Expand_Record_Equality
7045      (Nod    : Node_Id;
7046       Typ    : Entity_Id;
7047       Lhs    : Node_Id;
7048       Rhs    : Node_Id;
7049       Bodies : List_Id) return Node_Id
7050    is
7051       Loc : constant Source_Ptr := Sloc (Nod);
7052
7053       Result : Node_Id;
7054       C      : Entity_Id;
7055
7056       First_Time : Boolean := True;
7057
7058       function Suitable_Element (C : Entity_Id) return Entity_Id;
7059       --  Return the first field to compare beginning with C, skipping the
7060       --  inherited components.
7061
7062       ----------------------
7063       -- Suitable_Element --
7064       ----------------------
7065
7066       function Suitable_Element (C : Entity_Id) return Entity_Id is
7067       begin
7068          if No (C) then
7069             return Empty;
7070
7071          elsif Ekind (C) /= E_Discriminant
7072            and then Ekind (C) /= E_Component
7073          then
7074             return Suitable_Element (Next_Entity (C));
7075
7076          elsif Is_Tagged_Type (Typ)
7077            and then C /= Original_Record_Component (C)
7078          then
7079             return Suitable_Element (Next_Entity (C));
7080
7081          elsif Chars (C) = Name_uController
7082            or else Chars (C) = Name_uTag
7083          then
7084             return Suitable_Element (Next_Entity (C));
7085
7086          else
7087             return C;
7088          end if;
7089       end Suitable_Element;
7090
7091    --  Start of processing for Expand_Record_Equality
7092
7093    begin
7094       --  Generates the following code: (assuming that Typ has one Discr and
7095       --  component C2 is also a record)
7096
7097       --   True
7098       --     and then Lhs.Discr1 = Rhs.Discr1
7099       --     and then Lhs.C1 = Rhs.C1
7100       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7101       --     and then ...
7102       --     and then Lhs.Cmpn = Rhs.Cmpn
7103
7104       Result := New_Reference_To (Standard_True, Loc);
7105       C := Suitable_Element (First_Entity (Typ));
7106
7107       while Present (C) loop
7108          declare
7109             New_Lhs : Node_Id;
7110             New_Rhs : Node_Id;
7111
7112          begin
7113             if First_Time then
7114                First_Time := False;
7115                New_Lhs := Lhs;
7116                New_Rhs := Rhs;
7117             else
7118                New_Lhs := New_Copy_Tree (Lhs);
7119                New_Rhs := New_Copy_Tree (Rhs);
7120             end if;
7121
7122             Result :=
7123               Make_And_Then (Loc,
7124                 Left_Opnd  => Result,
7125                 Right_Opnd =>
7126                   Expand_Composite_Equality (Nod, Etype (C),
7127                     Lhs =>
7128                       Make_Selected_Component (Loc,
7129                         Prefix => New_Lhs,
7130                         Selector_Name => New_Reference_To (C, Loc)),
7131                     Rhs =>
7132                       Make_Selected_Component (Loc,
7133                         Prefix => New_Rhs,
7134                         Selector_Name => New_Reference_To (C, Loc)),
7135                     Bodies => Bodies));
7136          end;
7137
7138          C := Suitable_Element (Next_Entity (C));
7139       end loop;
7140
7141       return Result;
7142    end Expand_Record_Equality;
7143
7144    -------------------------------------
7145    -- Fixup_Universal_Fixed_Operation --
7146    -------------------------------------
7147
7148    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
7149       Conv : constant Node_Id := Parent (N);
7150
7151    begin
7152       --  We must have a type conversion immediately above us
7153
7154       pragma Assert (Nkind (Conv) = N_Type_Conversion);
7155
7156       --  Normally the type conversion gives our target type. The exception
7157       --  occurs in the case of the Round attribute, where the conversion
7158       --  will be to universal real, and our real type comes from the Round
7159       --  attribute (as well as an indication that we must round the result)
7160
7161       if Nkind (Parent (Conv)) = N_Attribute_Reference
7162         and then Attribute_Name (Parent (Conv)) = Name_Round
7163       then
7164          Set_Etype (N, Etype (Parent (Conv)));
7165          Set_Rounded_Result (N);
7166
7167       --  Normal case where type comes from conversion above us
7168
7169       else
7170          Set_Etype (N, Etype (Conv));
7171       end if;
7172    end Fixup_Universal_Fixed_Operation;
7173
7174    ------------------------------
7175    -- Get_Allocator_Final_List --
7176    ------------------------------
7177
7178    function Get_Allocator_Final_List
7179      (N    : Node_Id;
7180       T    : Entity_Id;
7181       PtrT : Entity_Id) return Entity_Id
7182    is
7183       Loc : constant Source_Ptr := Sloc (N);
7184
7185       Owner : Entity_Id := PtrT;
7186       --  The entity whose finalisation list must be used to attach the
7187       --  allocated object.
7188
7189    begin
7190       if Ekind (PtrT) = E_Anonymous_Access_Type then
7191          if Nkind (Associated_Node_For_Itype (PtrT))
7192               in N_Subprogram_Specification
7193          then
7194             --  If the context is an access parameter, we need to create
7195             --  a non-anonymous access type in order to have a usable
7196             --  final list, because there is otherwise no pool to which
7197             --  the allocated object can belong. We create both the type
7198             --  and the finalization chain here, because freezing an
7199             --  internal type does not create such a chain. The Final_Chain
7200             --  that is thus created is shared by the access parameter.
7201
7202             Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
7203             Insert_Action (N,
7204               Make_Full_Type_Declaration (Loc,
7205                 Defining_Identifier => Owner,
7206                 Type_Definition =>
7207                    Make_Access_To_Object_Definition (Loc,
7208                      Subtype_Indication =>
7209                        New_Occurrence_Of (T, Loc))));
7210
7211             Build_Final_List (N, Owner);
7212             Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
7213
7214          else
7215             --  Case of an access discriminant, or (Ada 2005) of
7216             --  an anonymous access component: find the final list
7217             --  associated with the scope of the type.
7218
7219             Owner := Scope (PtrT);
7220          end if;
7221       end if;
7222
7223       return Find_Final_List (Owner);
7224    end Get_Allocator_Final_List;
7225
7226    ---------------------------------
7227    -- Has_Inferable_Discriminants --
7228    ---------------------------------
7229
7230    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
7231
7232       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
7233       --  Determines whether the left-most prefix of a selected component is a
7234       --  formal parameter in a subprogram. Assumes N is a selected component.
7235
7236       --------------------------------
7237       -- Prefix_Is_Formal_Parameter --
7238       --------------------------------
7239
7240       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
7241          Sel_Comp : Node_Id := N;
7242
7243       begin
7244          --  Move to the left-most prefix by climbing up the tree
7245
7246          while Present (Parent (Sel_Comp))
7247            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
7248          loop
7249             Sel_Comp := Parent (Sel_Comp);
7250          end loop;
7251
7252          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
7253       end Prefix_Is_Formal_Parameter;
7254
7255    --  Start of processing for Has_Inferable_Discriminants
7256
7257    begin
7258       --  For identifiers and indexed components, it is sufficent to have a
7259       --  constrained Unchecked_Union nominal subtype.
7260
7261       if Nkind (N) = N_Identifier
7262            or else
7263          Nkind (N) = N_Indexed_Component
7264       then
7265          return Is_Unchecked_Union (Base_Type (Etype (N)))
7266                   and then
7267                 Is_Constrained (Etype (N));
7268
7269       --  For selected components, the subtype of the selector must be a
7270       --  constrained Unchecked_Union. If the component is subject to a
7271       --  per-object constraint, then the enclosing object must have inferable
7272       --  discriminants.
7273
7274       elsif Nkind (N) = N_Selected_Component then
7275          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
7276
7277             --  A small hack. If we have a per-object constrained selected
7278             --  component of a formal parameter, return True since we do not
7279             --  know the actual parameter association yet.
7280
7281             if Prefix_Is_Formal_Parameter (N) then
7282                return True;
7283             end if;
7284
7285             --  Otherwise, check the enclosing object and the selector
7286
7287             return Has_Inferable_Discriminants (Prefix (N))
7288                      and then
7289                    Has_Inferable_Discriminants (Selector_Name (N));
7290          end if;
7291
7292          --  The call to Has_Inferable_Discriminants will determine whether
7293          --  the selector has a constrained Unchecked_Union nominal type.
7294
7295          return Has_Inferable_Discriminants (Selector_Name (N));
7296
7297       --  A qualified expression has inferable discriminants if its subtype
7298       --  mark is a constrained Unchecked_Union subtype.
7299
7300       elsif Nkind (N) = N_Qualified_Expression then
7301          return Is_Unchecked_Union (Subtype_Mark (N))
7302                   and then
7303                 Is_Constrained (Subtype_Mark (N));
7304
7305       end if;
7306
7307       return False;
7308    end Has_Inferable_Discriminants;
7309
7310    -------------------------------
7311    -- Insert_Dereference_Action --
7312    -------------------------------
7313
7314    procedure Insert_Dereference_Action (N : Node_Id) is
7315       Loc  : constant Source_Ptr := Sloc (N);
7316       Typ  : constant Entity_Id  := Etype (N);
7317       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
7318       Pnod : constant Node_Id    := Parent (N);
7319
7320       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
7321       --  Return true if type of P is derived from Checked_Pool;
7322
7323       -----------------------------
7324       -- Is_Checked_Storage_Pool --
7325       -----------------------------
7326
7327       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
7328          T : Entity_Id;
7329
7330       begin
7331          if No (P) then
7332             return False;
7333          end if;
7334
7335          T := Etype (P);
7336          while T /= Etype (T) loop
7337             if Is_RTE (T, RE_Checked_Pool) then
7338                return True;
7339             else
7340                T := Etype (T);
7341             end if;
7342          end loop;
7343
7344          return False;
7345       end Is_Checked_Storage_Pool;
7346
7347    --  Start of processing for Insert_Dereference_Action
7348
7349    begin
7350       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
7351
7352       if not (Is_Checked_Storage_Pool (Pool)
7353               and then Comes_From_Source (Original_Node (Pnod)))
7354       then
7355          return;
7356       end if;
7357
7358       Insert_Action (N,
7359         Make_Procedure_Call_Statement (Loc,
7360           Name => New_Reference_To (
7361             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
7362
7363           Parameter_Associations => New_List (
7364
7365             --  Pool
7366
7367              New_Reference_To (Pool, Loc),
7368
7369             --  Storage_Address. We use the attribute Pool_Address,
7370             --  which uses the pointer itself to find the address of
7371             --  the object, and which handles unconstrained arrays
7372             --  properly by computing the address of the template.
7373             --  i.e. the correct address of the corresponding allocation.
7374
7375              Make_Attribute_Reference (Loc,
7376                Prefix         => Duplicate_Subexpr_Move_Checks (N),
7377                Attribute_Name => Name_Pool_Address),
7378
7379             --  Size_In_Storage_Elements
7380
7381              Make_Op_Divide (Loc,
7382                Left_Opnd  =>
7383                 Make_Attribute_Reference (Loc,
7384                   Prefix         =>
7385                     Make_Explicit_Dereference (Loc,
7386                       Duplicate_Subexpr_Move_Checks (N)),
7387                   Attribute_Name => Name_Size),
7388                Right_Opnd =>
7389                  Make_Integer_Literal (Loc, System_Storage_Unit)),
7390
7391             --  Alignment
7392
7393              Make_Attribute_Reference (Loc,
7394                Prefix         =>
7395                  Make_Explicit_Dereference (Loc,
7396                    Duplicate_Subexpr_Move_Checks (N)),
7397                Attribute_Name => Name_Alignment))));
7398
7399    exception
7400       when RE_Not_Available =>
7401          return;
7402    end Insert_Dereference_Action;
7403
7404    ------------------------------
7405    -- Make_Array_Comparison_Op --
7406    ------------------------------
7407
7408    --  This is a hand-coded expansion of the following generic function:
7409
7410    --  generic
7411    --    type elem is  (<>);
7412    --    type index is (<>);
7413    --    type a is array (index range <>) of elem;
7414    --
7415    --  function Gnnn (X : a; Y: a) return boolean is
7416    --    J : index := Y'first;
7417    --
7418    --  begin
7419    --    if X'length = 0 then
7420    --       return false;
7421    --
7422    --    elsif Y'length = 0 then
7423    --       return true;
7424    --
7425    --    else
7426    --      for I in X'range loop
7427    --        if X (I) = Y (J) then
7428    --          if J = Y'last then
7429    --            exit;
7430    --          else
7431    --            J := index'succ (J);
7432    --          end if;
7433    --
7434    --        else
7435    --           return X (I) > Y (J);
7436    --        end if;
7437    --      end loop;
7438    --
7439    --      return X'length > Y'length;
7440    --    end if;
7441    --  end Gnnn;
7442
7443    --  Note that since we are essentially doing this expansion by hand, we
7444    --  do not need to generate an actual or formal generic part, just the
7445    --  instantiated function itself.
7446
7447    function Make_Array_Comparison_Op
7448      (Typ : Entity_Id;
7449       Nod : Node_Id) return Node_Id
7450    is
7451       Loc : constant Source_Ptr := Sloc (Nod);
7452
7453       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
7454       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
7455       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
7456       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
7457
7458       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
7459
7460       Loop_Statement : Node_Id;
7461       Loop_Body      : Node_Id;
7462       If_Stat        : Node_Id;
7463       Inner_If       : Node_Id;
7464       Final_Expr     : Node_Id;
7465       Func_Body      : Node_Id;
7466       Func_Name      : Entity_Id;
7467       Formals        : List_Id;
7468       Length1        : Node_Id;
7469       Length2        : Node_Id;
7470
7471    begin
7472       --  if J = Y'last then
7473       --     exit;
7474       --  else
7475       --     J := index'succ (J);
7476       --  end if;
7477
7478       Inner_If :=
7479         Make_Implicit_If_Statement (Nod,
7480           Condition =>
7481             Make_Op_Eq (Loc,
7482               Left_Opnd => New_Reference_To (J, Loc),
7483               Right_Opnd =>
7484                 Make_Attribute_Reference (Loc,
7485                   Prefix => New_Reference_To (Y, Loc),
7486                   Attribute_Name => Name_Last)),
7487
7488           Then_Statements => New_List (
7489                 Make_Exit_Statement (Loc)),
7490
7491           Else_Statements =>
7492             New_List (
7493               Make_Assignment_Statement (Loc,
7494                 Name => New_Reference_To (J, Loc),
7495                 Expression =>
7496                   Make_Attribute_Reference (Loc,
7497                     Prefix => New_Reference_To (Index, Loc),
7498                     Attribute_Name => Name_Succ,
7499                     Expressions => New_List (New_Reference_To (J, Loc))))));
7500
7501       --  if X (I) = Y (J) then
7502       --     if ... end if;
7503       --  else
7504       --     return X (I) > Y (J);
7505       --  end if;
7506
7507       Loop_Body :=
7508         Make_Implicit_If_Statement (Nod,
7509           Condition =>
7510             Make_Op_Eq (Loc,
7511               Left_Opnd =>
7512                 Make_Indexed_Component (Loc,
7513                   Prefix      => New_Reference_To (X, Loc),
7514                   Expressions => New_List (New_Reference_To (I, Loc))),
7515
7516               Right_Opnd =>
7517                 Make_Indexed_Component (Loc,
7518                   Prefix      => New_Reference_To (Y, Loc),
7519                   Expressions => New_List (New_Reference_To (J, Loc)))),
7520
7521           Then_Statements => New_List (Inner_If),
7522
7523           Else_Statements => New_List (
7524             Make_Return_Statement (Loc,
7525               Expression =>
7526                 Make_Op_Gt (Loc,
7527                   Left_Opnd =>
7528                     Make_Indexed_Component (Loc,
7529                       Prefix      => New_Reference_To (X, Loc),
7530                       Expressions => New_List (New_Reference_To (I, Loc))),
7531
7532                   Right_Opnd =>
7533                     Make_Indexed_Component (Loc,
7534                       Prefix      => New_Reference_To (Y, Loc),
7535                       Expressions => New_List (
7536                         New_Reference_To (J, Loc)))))));
7537
7538       --  for I in X'range loop
7539       --     if ... end if;
7540       --  end loop;
7541
7542       Loop_Statement :=
7543         Make_Implicit_Loop_Statement (Nod,
7544           Identifier => Empty,
7545
7546           Iteration_Scheme =>
7547             Make_Iteration_Scheme (Loc,
7548               Loop_Parameter_Specification =>
7549                 Make_Loop_Parameter_Specification (Loc,
7550                   Defining_Identifier => I,
7551                   Discrete_Subtype_Definition =>
7552                     Make_Attribute_Reference (Loc,
7553                       Prefix => New_Reference_To (X, Loc),
7554                       Attribute_Name => Name_Range))),
7555
7556           Statements => New_List (Loop_Body));
7557
7558       --    if X'length = 0 then
7559       --       return false;
7560       --    elsif Y'length = 0 then
7561       --       return true;
7562       --    else
7563       --      for ... loop ... end loop;
7564       --      return X'length > Y'length;
7565       --    end if;
7566
7567       Length1 :=
7568         Make_Attribute_Reference (Loc,
7569           Prefix => New_Reference_To (X, Loc),
7570           Attribute_Name => Name_Length);
7571
7572       Length2 :=
7573         Make_Attribute_Reference (Loc,
7574           Prefix => New_Reference_To (Y, Loc),
7575           Attribute_Name => Name_Length);
7576
7577       Final_Expr :=
7578         Make_Op_Gt (Loc,
7579           Left_Opnd  => Length1,
7580           Right_Opnd => Length2);
7581
7582       If_Stat :=
7583         Make_Implicit_If_Statement (Nod,
7584           Condition =>
7585             Make_Op_Eq (Loc,
7586               Left_Opnd =>
7587                 Make_Attribute_Reference (Loc,
7588                   Prefix => New_Reference_To (X, Loc),
7589                   Attribute_Name => Name_Length),
7590               Right_Opnd =>
7591                 Make_Integer_Literal (Loc, 0)),
7592
7593           Then_Statements =>
7594             New_List (
7595               Make_Return_Statement (Loc,
7596                 Expression => New_Reference_To (Standard_False, Loc))),
7597
7598           Elsif_Parts => New_List (
7599             Make_Elsif_Part (Loc,
7600               Condition =>
7601                 Make_Op_Eq (Loc,
7602                   Left_Opnd =>
7603                     Make_Attribute_Reference (Loc,
7604                       Prefix => New_Reference_To (Y, Loc),
7605                       Attribute_Name => Name_Length),
7606                   Right_Opnd =>
7607                     Make_Integer_Literal (Loc, 0)),
7608
7609               Then_Statements =>
7610                 New_List (
7611                   Make_Return_Statement (Loc,
7612                      Expression => New_Reference_To (Standard_True, Loc))))),
7613
7614           Else_Statements => New_List (
7615             Loop_Statement,
7616             Make_Return_Statement (Loc,
7617               Expression => Final_Expr)));
7618
7619       --  (X : a; Y: a)
7620
7621       Formals := New_List (
7622         Make_Parameter_Specification (Loc,
7623           Defining_Identifier => X,
7624           Parameter_Type      => New_Reference_To (Typ, Loc)),
7625
7626         Make_Parameter_Specification (Loc,
7627           Defining_Identifier => Y,
7628           Parameter_Type      => New_Reference_To (Typ, Loc)));
7629
7630       --  function Gnnn (...) return boolean is
7631       --    J : index := Y'first;
7632       --  begin
7633       --    if ... end if;
7634       --  end Gnnn;
7635
7636       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
7637
7638       Func_Body :=
7639         Make_Subprogram_Body (Loc,
7640           Specification =>
7641             Make_Function_Specification (Loc,
7642               Defining_Unit_Name       => Func_Name,
7643               Parameter_Specifications => Formals,
7644               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
7645
7646           Declarations => New_List (
7647             Make_Object_Declaration (Loc,
7648               Defining_Identifier => J,
7649               Object_Definition   => New_Reference_To (Index, Loc),
7650               Expression =>
7651                 Make_Attribute_Reference (Loc,
7652                   Prefix => New_Reference_To (Y, Loc),
7653                   Attribute_Name => Name_First))),
7654
7655           Handled_Statement_Sequence =>
7656             Make_Handled_Sequence_Of_Statements (Loc,
7657               Statements => New_List (If_Stat)));
7658
7659       return Func_Body;
7660
7661    end Make_Array_Comparison_Op;
7662
7663    ---------------------------
7664    -- Make_Boolean_Array_Op --
7665    ---------------------------
7666
7667    --  For logical operations on boolean arrays, expand in line the
7668    --  following, replacing 'and' with 'or' or 'xor' where needed:
7669
7670    --    function Annn (A : typ; B: typ) return typ is
7671    --       C : typ;
7672    --    begin
7673    --       for J in A'range loop
7674    --          C (J) := A (J) op B (J);
7675    --       end loop;
7676    --       return C;
7677    --    end Annn;
7678
7679    --  Here typ is the boolean array type
7680
7681    function Make_Boolean_Array_Op
7682      (Typ : Entity_Id;
7683       N   : Node_Id) return Node_Id
7684    is
7685       Loc : constant Source_Ptr := Sloc (N);
7686
7687       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
7688       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
7689       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
7690       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
7691
7692       A_J : Node_Id;
7693       B_J : Node_Id;
7694       C_J : Node_Id;
7695       Op  : Node_Id;
7696
7697       Formals        : List_Id;
7698       Func_Name      : Entity_Id;
7699       Func_Body      : Node_Id;
7700       Loop_Statement : Node_Id;
7701
7702    begin
7703       A_J :=
7704         Make_Indexed_Component (Loc,
7705           Prefix      => New_Reference_To (A, Loc),
7706           Expressions => New_List (New_Reference_To (J, Loc)));
7707
7708       B_J :=
7709         Make_Indexed_Component (Loc,
7710           Prefix      => New_Reference_To (B, Loc),
7711           Expressions => New_List (New_Reference_To (J, Loc)));
7712
7713       C_J :=
7714         Make_Indexed_Component (Loc,
7715           Prefix      => New_Reference_To (C, Loc),
7716           Expressions => New_List (New_Reference_To (J, Loc)));
7717
7718       if Nkind (N) = N_Op_And then
7719          Op :=
7720            Make_Op_And (Loc,
7721              Left_Opnd  => A_J,
7722              Right_Opnd => B_J);
7723
7724       elsif Nkind (N) = N_Op_Or then
7725          Op :=
7726            Make_Op_Or (Loc,
7727              Left_Opnd  => A_J,
7728              Right_Opnd => B_J);
7729
7730       else
7731          Op :=
7732            Make_Op_Xor (Loc,
7733              Left_Opnd  => A_J,
7734              Right_Opnd => B_J);
7735       end if;
7736
7737       Loop_Statement :=
7738         Make_Implicit_Loop_Statement (N,
7739           Identifier => Empty,
7740
7741           Iteration_Scheme =>
7742             Make_Iteration_Scheme (Loc,
7743               Loop_Parameter_Specification =>
7744                 Make_Loop_Parameter_Specification (Loc,
7745                   Defining_Identifier => J,
7746                   Discrete_Subtype_Definition =>
7747                     Make_Attribute_Reference (Loc,
7748                       Prefix => New_Reference_To (A, Loc),
7749                       Attribute_Name => Name_Range))),
7750
7751           Statements => New_List (
7752             Make_Assignment_Statement (Loc,
7753               Name       => C_J,
7754               Expression => Op)));
7755
7756       Formals := New_List (
7757         Make_Parameter_Specification (Loc,
7758           Defining_Identifier => A,
7759           Parameter_Type      => New_Reference_To (Typ, Loc)),
7760
7761         Make_Parameter_Specification (Loc,
7762           Defining_Identifier => B,
7763           Parameter_Type      => New_Reference_To (Typ, Loc)));
7764
7765       Func_Name :=
7766         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7767       Set_Is_Inlined (Func_Name);
7768
7769       Func_Body :=
7770         Make_Subprogram_Body (Loc,
7771           Specification =>
7772             Make_Function_Specification (Loc,
7773               Defining_Unit_Name       => Func_Name,
7774               Parameter_Specifications => Formals,
7775               Subtype_Mark             => New_Reference_To (Typ, Loc)),
7776
7777           Declarations => New_List (
7778             Make_Object_Declaration (Loc,
7779               Defining_Identifier => C,
7780               Object_Definition   => New_Reference_To (Typ, Loc))),
7781
7782           Handled_Statement_Sequence =>
7783             Make_Handled_Sequence_Of_Statements (Loc,
7784               Statements => New_List (
7785                 Loop_Statement,
7786                 Make_Return_Statement (Loc,
7787                   Expression => New_Reference_To (C, Loc)))));
7788
7789       return Func_Body;
7790    end Make_Boolean_Array_Op;
7791
7792    ------------------------
7793    -- Rewrite_Comparison --
7794    ------------------------
7795
7796    procedure Rewrite_Comparison (N : Node_Id) is
7797       Typ : constant Entity_Id := Etype (N);
7798       Op1 : constant Node_Id   := Left_Opnd (N);
7799       Op2 : constant Node_Id   := Right_Opnd (N);
7800
7801       Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
7802       --  Res indicates if compare outcome can be determined at compile time
7803
7804       True_Result  : Boolean;
7805       False_Result : Boolean;
7806
7807    begin
7808       case N_Op_Compare (Nkind (N)) is
7809          when N_Op_Eq =>
7810             True_Result  := Res = EQ;
7811             False_Result := Res = LT or else Res = GT or else Res = NE;
7812
7813          when N_Op_Ge =>
7814             True_Result  := Res in Compare_GE;
7815             False_Result := Res = LT;
7816
7817          when N_Op_Gt =>
7818             True_Result  := Res = GT;
7819             False_Result := Res in Compare_LE;
7820
7821          when N_Op_Lt =>
7822             True_Result  := Res = LT;
7823             False_Result := Res in Compare_GE;
7824
7825          when N_Op_Le =>
7826             True_Result  := Res in Compare_LE;
7827             False_Result := Res = GT;
7828
7829          when N_Op_Ne =>
7830             True_Result  := Res = NE;
7831             False_Result := Res = LT or else Res = GT or else Res = EQ;
7832       end case;
7833
7834       if True_Result then
7835          Rewrite (N,
7836            Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
7837          Analyze_And_Resolve (N, Typ);
7838          Warn_On_Known_Condition (N);
7839
7840       elsif False_Result then
7841          Rewrite (N,
7842            Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
7843          Analyze_And_Resolve (N, Typ);
7844          Warn_On_Known_Condition (N);
7845       end if;
7846    end Rewrite_Comparison;
7847
7848    ----------------------------
7849    -- Safe_In_Place_Array_Op --
7850    ----------------------------
7851
7852    function Safe_In_Place_Array_Op
7853      (Lhs : Node_Id;
7854       Op1 : Node_Id;
7855       Op2 : Node_Id) return Boolean
7856    is
7857       Target : Entity_Id;
7858
7859       function Is_Safe_Operand (Op : Node_Id) return Boolean;
7860       --  Operand is safe if it cannot overlap part of the target of the
7861       --  operation. If the operand and the target are identical, the operand
7862       --  is safe. The operand can be empty in the case of negation.
7863
7864       function Is_Unaliased (N : Node_Id) return Boolean;
7865       --  Check that N is a stand-alone entity
7866
7867       ------------------
7868       -- Is_Unaliased --
7869       ------------------
7870
7871       function Is_Unaliased (N : Node_Id) return Boolean is
7872       begin
7873          return
7874            Is_Entity_Name (N)
7875              and then No (Address_Clause (Entity (N)))
7876              and then No (Renamed_Object (Entity (N)));
7877       end Is_Unaliased;
7878
7879       ---------------------
7880       -- Is_Safe_Operand --
7881       ---------------------
7882
7883       function Is_Safe_Operand (Op : Node_Id) return Boolean is
7884       begin
7885          if No (Op) then
7886             return True;
7887
7888          elsif Is_Entity_Name (Op) then
7889             return Is_Unaliased (Op);
7890
7891          elsif Nkind (Op) = N_Indexed_Component
7892            or else Nkind (Op) = N_Selected_Component
7893          then
7894             return Is_Unaliased (Prefix (Op));
7895
7896          elsif Nkind (Op) = N_Slice then
7897             return
7898               Is_Unaliased (Prefix (Op))
7899                 and then Entity (Prefix (Op)) /= Target;
7900
7901          elsif Nkind (Op) = N_Op_Not then
7902             return Is_Safe_Operand (Right_Opnd (Op));
7903
7904          else
7905             return False;
7906          end if;
7907       end Is_Safe_Operand;
7908
7909       --  Start of processing for Is_Safe_In_Place_Array_Op
7910
7911    begin
7912       --  We skip this processing if the component size is not the
7913       --  same as a system storage unit (since at least for NOT
7914       --  this would cause problems).
7915
7916       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
7917          return False;
7918
7919       --  Cannot do in place stuff on Java_VM since cannot pass addresses
7920
7921       elsif Java_VM then
7922          return False;
7923
7924       --  Cannot do in place stuff if non-standard Boolean representation
7925
7926       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
7927          return False;
7928
7929       elsif not Is_Unaliased (Lhs) then
7930          return False;
7931       else
7932          Target := Entity (Lhs);
7933
7934          return
7935            Is_Safe_Operand (Op1)
7936              and then Is_Safe_Operand (Op2);
7937       end if;
7938    end Safe_In_Place_Array_Op;
7939
7940    -----------------------
7941    -- Tagged_Membership --
7942    -----------------------
7943
7944    --  There are two different cases to consider depending on whether
7945    --  the right operand is a class-wide type or not. If not we just
7946    --  compare the actual tag of the left expr to the target type tag:
7947    --
7948    --     Left_Expr.Tag = Right_Type'Tag;
7949    --
7950    --  If it is a class-wide type we use the RT function CW_Membership which
7951    --  is usually implemented by looking in the ancestor tables contained in
7952    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7953
7954    function Tagged_Membership (N : Node_Id) return Node_Id is
7955       Left  : constant Node_Id    := Left_Opnd  (N);
7956       Right : constant Node_Id    := Right_Opnd (N);
7957       Loc   : constant Source_Ptr := Sloc (N);
7958
7959       Left_Type  : Entity_Id;
7960       Right_Type : Entity_Id;
7961       Obj_Tag    : Node_Id;
7962
7963    begin
7964       Left_Type  := Etype (Left);
7965       Right_Type := Etype (Right);
7966
7967       if Is_Class_Wide_Type (Left_Type) then
7968          Left_Type := Root_Type (Left_Type);
7969       end if;
7970
7971       Obj_Tag :=
7972         Make_Selected_Component (Loc,
7973           Prefix        => Relocate_Node (Left),
7974           Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
7975
7976       if Is_Class_Wide_Type (Right_Type) then
7977          return
7978            Make_DT_Access_Action (Left_Type,
7979              Action => CW_Membership,
7980              Args   => New_List (
7981                Obj_Tag,
7982                New_Reference_To (
7983                  Access_Disp_Table (Root_Type (Right_Type)), Loc)));
7984       else
7985          return
7986            Make_Op_Eq (Loc,
7987            Left_Opnd  => Obj_Tag,
7988            Right_Opnd =>
7989              New_Reference_To (Access_Disp_Table (Right_Type), Loc));
7990       end if;
7991
7992    end Tagged_Membership;
7993
7994    ------------------------------
7995    -- Unary_Op_Validity_Checks --
7996    ------------------------------
7997
7998    procedure Unary_Op_Validity_Checks (N : Node_Id) is
7999    begin
8000       if Validity_Checks_On and Validity_Check_Operands then
8001          Ensure_Valid (Right_Opnd (N));
8002       end if;
8003    end Unary_Op_Validity_Checks;
8004
8005 end Exp_Ch4;