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          Rewrite (P,
3277            Make_Explicit_Dereference (Sloc (N),
3278              Prefix => Relocate_Node (P)));
3279          Analyze_And_Resolve (P, Designated_Type (T));
3280       end if;
3281
3282       --  Generate index and validity checks
3283
3284       Generate_Index_Checks (N);
3285
3286       if Validity_Checks_On and then Validity_Check_Subscripts then
3287          Apply_Subscript_Validity_Checks (N);
3288       end if;
3289
3290       --  All done for the non-packed case
3291
3292       if not Is_Packed (Etype (Prefix (N))) then
3293          return;
3294       end if;
3295
3296       --  For packed arrays that are not bit-packed (i.e. the case of an array
3297       --  with one or more index types with a non-coniguous enumeration type),
3298       --  we can always use the normal packed element get circuit.
3299
3300       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
3301          Expand_Packed_Element_Reference (N);
3302          return;
3303       end if;
3304
3305       --  For a reference to a component of a bit packed array, we have to
3306       --  convert it to a reference to the corresponding Packed_Array_Type.
3307       --  We only want to do this for simple references, and not for:
3308
3309       --    Left side of assignment, or prefix of left side of assignment,
3310       --    or prefix of the prefix, to handle packed arrays of packed arrays,
3311       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
3312
3313       --    Renaming objects in renaming associations
3314       --      This case is handled when a use of the renamed variable occurs
3315
3316       --    Actual parameters for a procedure call
3317       --      This case is handled in Exp_Ch6.Expand_Actuals
3318
3319       --    The second expression in a 'Read attribute reference
3320
3321       --    The prefix of an address or size attribute reference
3322
3323       --  The following circuit detects these exceptions
3324
3325       declare
3326          Child : Node_Id := N;
3327          Parnt : Node_Id := Parent (N);
3328
3329       begin
3330          loop
3331             if Nkind (Parnt) = N_Unchecked_Expression then
3332                null;
3333
3334             elsif Nkind (Parnt) = N_Object_Renaming_Declaration
3335               or else Nkind (Parnt) = N_Procedure_Call_Statement
3336               or else (Nkind (Parnt) = N_Parameter_Association
3337                         and then
3338                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
3339             then
3340                return;
3341
3342             elsif Nkind (Parnt) = N_Attribute_Reference
3343               and then (Attribute_Name (Parnt) = Name_Address
3344                          or else
3345                         Attribute_Name (Parnt) = Name_Size)
3346               and then Prefix (Parnt) = Child
3347             then
3348                return;
3349
3350             elsif Nkind (Parnt) = N_Assignment_Statement
3351               and then Name (Parnt) = Child
3352             then
3353                return;
3354
3355             --  If the expression is an index of an indexed component,
3356             --  it must be expanded regardless of context.
3357
3358             elsif Nkind (Parnt) = N_Indexed_Component
3359               and then Child /= Prefix (Parnt)
3360             then
3361                Expand_Packed_Element_Reference (N);
3362                return;
3363
3364             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
3365               and then Name (Parent (Parnt)) = Parnt
3366             then
3367                return;
3368
3369             elsif Nkind (Parnt) = N_Attribute_Reference
3370               and then Attribute_Name (Parnt) = Name_Read
3371               and then Next (First (Expressions (Parnt))) = Child
3372             then
3373                return;
3374
3375             elsif (Nkind (Parnt) = N_Indexed_Component
3376                     or else Nkind (Parnt) = N_Selected_Component)
3377                and then Prefix (Parnt) = Child
3378             then
3379                null;
3380
3381             else
3382                Expand_Packed_Element_Reference (N);
3383                return;
3384             end if;
3385
3386             --  Keep looking up tree for unchecked expression, or if we are
3387             --  the prefix of a possible assignment left side.
3388
3389             Child := Parnt;
3390             Parnt := Parent (Child);
3391          end loop;
3392       end;
3393
3394    end Expand_N_Indexed_Component;
3395
3396    ---------------------
3397    -- Expand_N_Not_In --
3398    ---------------------
3399
3400    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
3401    --  can be done. This avoids needing to duplicate this expansion code.
3402
3403    procedure Expand_N_Not_In (N : Node_Id) is
3404       Loc  : constant Source_Ptr := Sloc (N);
3405       Typ  : constant Entity_Id  := Etype (N);
3406
3407    begin
3408       Rewrite (N,
3409         Make_Op_Not (Loc,
3410           Right_Opnd =>
3411             Make_In (Loc,
3412               Left_Opnd  => Left_Opnd (N),
3413               Right_Opnd => Right_Opnd (N))));
3414       Analyze_And_Resolve (N, Typ);
3415    end Expand_N_Not_In;
3416
3417    -------------------
3418    -- Expand_N_Null --
3419    -------------------
3420
3421    --  The only replacement required is for the case of a null of type
3422    --  that is an access to protected subprogram. We represent such
3423    --  access values as a record, and so we must replace the occurrence
3424    --  of null by the equivalent record (with a null address and a null
3425    --  pointer in it), so that the backend creates the proper value.
3426
3427    procedure Expand_N_Null (N : Node_Id) is
3428       Loc : constant Source_Ptr := Sloc (N);
3429       Typ : constant Entity_Id  := Etype (N);
3430       Agg : Node_Id;
3431
3432    begin
3433       if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
3434          Agg :=
3435            Make_Aggregate (Loc,
3436              Expressions => New_List (
3437                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
3438                Make_Null (Loc)));
3439
3440          Rewrite (N, Agg);
3441          Analyze_And_Resolve (N, Equivalent_Type (Typ));
3442
3443          --  For subsequent semantic analysis, the node must retain its
3444          --  type. Gigi in any case replaces this type by the corresponding
3445          --  record type before processing the node.
3446
3447          Set_Etype (N, Typ);
3448       end if;
3449
3450    exception
3451       when RE_Not_Available =>
3452          return;
3453    end Expand_N_Null;
3454
3455    ---------------------
3456    -- Expand_N_Op_Abs --
3457    ---------------------
3458
3459    procedure Expand_N_Op_Abs (N : Node_Id) is
3460       Loc  : constant Source_Ptr := Sloc (N);
3461       Expr : constant Node_Id := Right_Opnd (N);
3462
3463    begin
3464       Unary_Op_Validity_Checks (N);
3465
3466       --  Deal with software overflow checking
3467
3468       if not Backend_Overflow_Checks_On_Target
3469          and then Is_Signed_Integer_Type (Etype (N))
3470          and then Do_Overflow_Check (N)
3471       then
3472          --  The only case to worry about is when the argument is
3473          --  equal to the largest negative number, so what we do is
3474          --  to insert the check:
3475
3476          --     [constraint_error when Expr = typ'Base'First]
3477
3478          --  with the usual Duplicate_Subexpr use coding for expr
3479
3480          Insert_Action (N,
3481            Make_Raise_Constraint_Error (Loc,
3482              Condition =>
3483                Make_Op_Eq (Loc,
3484                  Left_Opnd  => Duplicate_Subexpr (Expr),
3485                  Right_Opnd =>
3486                    Make_Attribute_Reference (Loc,
3487                      Prefix =>
3488                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
3489                      Attribute_Name => Name_First)),
3490              Reason => CE_Overflow_Check_Failed));
3491       end if;
3492
3493       --  Vax floating-point types case
3494
3495       if Vax_Float (Etype (N)) then
3496          Expand_Vax_Arith (N);
3497       end if;
3498    end Expand_N_Op_Abs;
3499
3500    ---------------------
3501    -- Expand_N_Op_Add --
3502    ---------------------
3503
3504    procedure Expand_N_Op_Add (N : Node_Id) is
3505       Typ : constant Entity_Id := Etype (N);
3506
3507    begin
3508       Binary_Op_Validity_Checks (N);
3509
3510       --  N + 0 = 0 + N = N for integer types
3511
3512       if Is_Integer_Type (Typ) then
3513          if Compile_Time_Known_Value (Right_Opnd (N))
3514            and then Expr_Value (Right_Opnd (N)) = Uint_0
3515          then
3516             Rewrite (N, Left_Opnd (N));
3517             return;
3518
3519          elsif Compile_Time_Known_Value (Left_Opnd (N))
3520            and then Expr_Value (Left_Opnd (N)) = Uint_0
3521          then
3522             Rewrite (N, Right_Opnd (N));
3523             return;
3524          end if;
3525       end if;
3526
3527       --  Arithmetic overflow checks for signed integer/fixed point types
3528
3529       if Is_Signed_Integer_Type (Typ)
3530         or else Is_Fixed_Point_Type (Typ)
3531       then
3532          Apply_Arithmetic_Overflow_Check (N);
3533          return;
3534
3535       --  Vax floating-point types case
3536
3537       elsif Vax_Float (Typ) then
3538          Expand_Vax_Arith (N);
3539       end if;
3540    end Expand_N_Op_Add;
3541
3542    ---------------------
3543    -- Expand_N_Op_And --
3544    ---------------------
3545
3546    procedure Expand_N_Op_And (N : Node_Id) is
3547       Typ : constant Entity_Id := Etype (N);
3548
3549    begin
3550       Binary_Op_Validity_Checks (N);
3551
3552       if Is_Array_Type (Etype (N)) then
3553          Expand_Boolean_Operator (N);
3554
3555       elsif Is_Boolean_Type (Etype (N)) then
3556          Adjust_Condition (Left_Opnd (N));
3557          Adjust_Condition (Right_Opnd (N));
3558          Set_Etype (N, Standard_Boolean);
3559          Adjust_Result_Type (N, Typ);
3560       end if;
3561    end Expand_N_Op_And;
3562
3563    ------------------------
3564    -- Expand_N_Op_Concat --
3565    ------------------------
3566
3567    Max_Available_String_Operands : Int := -1;
3568    --  This is initialized the first time this routine is called. It records
3569    --  a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
3570    --  available in the run-time:
3571    --
3572    --    0  None available
3573    --    2  RE_Str_Concat available, RE_Str_Concat_3 not available
3574    --    3  RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
3575    --    4  RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
3576    --    5  All routines including RE_Str_Concat_5 available
3577
3578    Char_Concat_Available : Boolean;
3579    --  Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
3580    --  all three are available, False if any one of these is unavailable.
3581
3582    procedure Expand_N_Op_Concat (N : Node_Id) is
3583       Opnds : List_Id;
3584       --  List of operands to be concatenated
3585
3586       Opnd  : Node_Id;
3587       --  Single operand for concatenation
3588
3589       Cnode : Node_Id;
3590       --  Node which is to be replaced by the result of concatenating
3591       --  the nodes in the list Opnds.
3592
3593       Atyp : Entity_Id;
3594       --  Array type of concatenation result type
3595
3596       Ctyp : Entity_Id;
3597       --  Component type of concatenation represented by Cnode
3598
3599    begin
3600       --  Initialize global variables showing run-time status
3601
3602       if Max_Available_String_Operands < 1 then
3603          if not RTE_Available (RE_Str_Concat) then
3604             Max_Available_String_Operands := 0;
3605          elsif not RTE_Available (RE_Str_Concat_3) then
3606             Max_Available_String_Operands := 2;
3607          elsif not RTE_Available (RE_Str_Concat_4) then
3608             Max_Available_String_Operands := 3;
3609          elsif not RTE_Available (RE_Str_Concat_5) then
3610             Max_Available_String_Operands := 4;
3611          else
3612             Max_Available_String_Operands := 5;
3613          end if;
3614
3615          Char_Concat_Available :=
3616            RTE_Available (RE_Str_Concat_CC)
3617              and then
3618            RTE_Available (RE_Str_Concat_CS)
3619              and then
3620            RTE_Available (RE_Str_Concat_SC);
3621       end if;
3622
3623       --  Ensure validity of both operands
3624
3625       Binary_Op_Validity_Checks (N);
3626
3627       --  If we are the left operand of a concatenation higher up the
3628       --  tree, then do nothing for now, since we want to deal with a
3629       --  series of concatenations as a unit.
3630
3631       if Nkind (Parent (N)) = N_Op_Concat
3632         and then N = Left_Opnd (Parent (N))
3633       then
3634          return;
3635       end if;
3636
3637       --  We get here with a concatenation whose left operand may be a
3638       --  concatenation itself with a consistent type. We need to process
3639       --  these concatenation operands from left to right, which means
3640       --  from the deepest node in the tree to the highest node.
3641
3642       Cnode := N;
3643       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
3644          Cnode := Left_Opnd (Cnode);
3645       end loop;
3646
3647       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
3648       --  nodes above, so now we process bottom up, doing the operations. We
3649       --  gather a string that is as long as possible up to five operands
3650
3651       --  The outer loop runs more than once if there are more than five
3652       --  concatenations of type Standard.String, the most we handle for
3653       --  this case, or if more than one concatenation type is involved.
3654
3655       Outer : loop
3656          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
3657          Set_Parent (Opnds, N);
3658
3659          --  The inner loop gathers concatenation operands. We gather any
3660          --  number of these in the non-string case, or if no concatenation
3661          --  routines are available for string (since in that case we will
3662          --  treat string like any other non-string case). Otherwise we only
3663          --  gather as many operands as can be handled by the available
3664          --  procedures in the run-time library (normally 5, but may be
3665          --  less for the configurable run-time case).
3666
3667          Inner : while Cnode /= N
3668                    and then (Base_Type (Etype (Cnode)) /= Standard_String
3669                                or else
3670                              Max_Available_String_Operands = 0
3671                                or else
3672                              List_Length (Opnds) <
3673                                                Max_Available_String_Operands)
3674                    and then Base_Type (Etype (Cnode)) =
3675                             Base_Type (Etype (Parent (Cnode)))
3676          loop
3677             Cnode := Parent (Cnode);
3678             Append (Right_Opnd (Cnode), Opnds);
3679          end loop Inner;
3680
3681          --  Here we process the collected operands. First we convert
3682          --  singleton operands to singleton aggregates. This is skipped
3683          --  however for the case of two operands of type String, since
3684          --  we have special routines for these cases.
3685
3686          Atyp := Base_Type (Etype (Cnode));
3687          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
3688
3689          if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
3690            or else not Char_Concat_Available
3691          then
3692             Opnd := First (Opnds);
3693             loop
3694                if Base_Type (Etype (Opnd)) = Ctyp then
3695                   Rewrite (Opnd,
3696                     Make_Aggregate (Sloc (Cnode),
3697                       Expressions => New_List (Relocate_Node (Opnd))));
3698                   Analyze_And_Resolve (Opnd, Atyp);
3699                end if;
3700
3701                Next (Opnd);
3702                exit when No (Opnd);
3703             end loop;
3704          end if;
3705
3706          --  Now call appropriate continuation routine
3707
3708          if Atyp = Standard_String
3709            and then Max_Available_String_Operands > 0
3710          then
3711             Expand_Concatenate_String (Cnode, Opnds);
3712          else
3713             Expand_Concatenate_Other (Cnode, Opnds);
3714          end if;
3715
3716          exit Outer when Cnode = N;
3717          Cnode := Parent (Cnode);
3718       end loop Outer;
3719    end Expand_N_Op_Concat;
3720
3721    ------------------------
3722    -- Expand_N_Op_Divide --
3723    ------------------------
3724
3725    procedure Expand_N_Op_Divide (N : Node_Id) is
3726       Loc  : constant Source_Ptr := Sloc (N);
3727       Ltyp : constant Entity_Id  := Etype (Left_Opnd (N));
3728       Rtyp : constant Entity_Id  := Etype (Right_Opnd (N));
3729       Typ  : Entity_Id           := Etype (N);
3730
3731    begin
3732       Binary_Op_Validity_Checks (N);
3733
3734       --  Vax_Float is a special case
3735
3736       if Vax_Float (Typ) then
3737          Expand_Vax_Arith (N);
3738          return;
3739       end if;
3740
3741       --  N / 1 = N for integer types
3742
3743       if Is_Integer_Type (Typ)
3744         and then Compile_Time_Known_Value (Right_Opnd (N))
3745         and then Expr_Value (Right_Opnd (N)) = Uint_1
3746       then
3747          Rewrite (N, Left_Opnd (N));
3748          return;
3749       end if;
3750
3751       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
3752       --  Is_Power_Of_2_For_Shift is set means that we know that our left
3753       --  operand is an unsigned integer, as required for this to work.
3754
3755       if Nkind (Right_Opnd (N)) = N_Op_Expon
3756         and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
3757
3758       --  We cannot do this transformation in configurable run time mode if we
3759       --  have 64-bit --  integers and long shifts are not available.
3760
3761         and then
3762           (Esize (Ltyp) <= 32
3763              or else Support_Long_Shifts_On_Target)
3764       then
3765          Rewrite (N,
3766            Make_Op_Shift_Right (Loc,
3767              Left_Opnd  => Left_Opnd (N),
3768              Right_Opnd =>
3769                Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
3770          Analyze_And_Resolve (N, Typ);
3771          return;
3772       end if;
3773
3774       --  Do required fixup of universal fixed operation
3775
3776       if Typ = Universal_Fixed then
3777          Fixup_Universal_Fixed_Operation (N);
3778          Typ := Etype (N);
3779       end if;
3780
3781       --  Divisions with fixed-point results
3782
3783       if Is_Fixed_Point_Type (Typ) then
3784
3785          --  No special processing if Treat_Fixed_As_Integer is set,
3786          --  since from a semantic point of view such operations are
3787          --  simply integer operations and will be treated that way.
3788
3789          if not Treat_Fixed_As_Integer (N) then
3790             if Is_Integer_Type (Rtyp) then
3791                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
3792             else
3793                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
3794             end if;
3795          end if;
3796
3797       --  Other cases of division of fixed-point operands. Again we
3798       --  exclude the case where Treat_Fixed_As_Integer is set.
3799
3800       elsif (Is_Fixed_Point_Type (Ltyp) or else
3801              Is_Fixed_Point_Type (Rtyp))
3802         and then not Treat_Fixed_As_Integer (N)
3803       then
3804          if Is_Integer_Type (Typ) then
3805             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
3806          else
3807             pragma Assert (Is_Floating_Point_Type (Typ));
3808             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
3809          end if;
3810
3811       --  Mixed-mode operations can appear in a non-static universal
3812       --  context, in  which case the integer argument must be converted
3813       --  explicitly.
3814
3815       elsif Typ = Universal_Real
3816         and then Is_Integer_Type (Rtyp)
3817       then
3818          Rewrite (Right_Opnd (N),
3819            Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
3820
3821          Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
3822
3823       elsif Typ = Universal_Real
3824         and then Is_Integer_Type (Ltyp)
3825       then
3826          Rewrite (Left_Opnd (N),
3827            Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
3828
3829          Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
3830
3831       --  Non-fixed point cases, do zero divide and overflow checks
3832
3833       elsif Is_Integer_Type (Typ) then
3834          Apply_Divide_Check (N);
3835
3836          --  Check for 64-bit division available
3837
3838          if Esize (Ltyp) > 32
3839            and then not Support_64_Bit_Divides_On_Target
3840          then
3841             Error_Msg_CRT ("64-bit division", N);
3842          end if;
3843       end if;
3844    end Expand_N_Op_Divide;
3845
3846    --------------------
3847    -- Expand_N_Op_Eq --
3848    --------------------
3849
3850    procedure Expand_N_Op_Eq (N : Node_Id) is
3851       Loc    : constant Source_Ptr := Sloc (N);
3852       Typ    : constant Entity_Id  := Etype (N);
3853       Lhs    : constant Node_Id    := Left_Opnd (N);
3854       Rhs    : constant Node_Id    := Right_Opnd (N);
3855       Bodies : constant List_Id    := New_List;
3856       A_Typ  : constant Entity_Id  := Etype (Lhs);
3857
3858       Typl    : Entity_Id := A_Typ;
3859       Op_Name : Entity_Id;
3860       Prim    : Elmt_Id;
3861
3862       procedure Build_Equality_Call (Eq : Entity_Id);
3863       --  If a constructed equality exists for the type or for its parent,
3864       --  build and analyze call, adding conversions if the operation is
3865       --  inherited.
3866
3867       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
3868       --  Determines whether a type has a subcompoment of an unconstrained
3869       --  Unchecked_Union subtype. Typ is a record type.
3870
3871       -------------------------
3872       -- Build_Equality_Call --
3873       -------------------------
3874
3875       procedure Build_Equality_Call (Eq : Entity_Id) is
3876          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
3877          L_Exp   : Node_Id := Relocate_Node (Lhs);
3878          R_Exp   : Node_Id := Relocate_Node (Rhs);
3879
3880       begin
3881          if Base_Type (Op_Type) /= Base_Type (A_Typ)
3882            and then not Is_Class_Wide_Type (A_Typ)
3883          then
3884             L_Exp := OK_Convert_To (Op_Type, L_Exp);
3885             R_Exp := OK_Convert_To (Op_Type, R_Exp);
3886          end if;
3887
3888          --  If we have an Unchecked_Union, we need to add the inferred
3889          --  discriminant values as actuals in the function call. At this
3890          --  point, the expansion has determined that both operands have
3891          --  inferable discriminants.
3892
3893          if Is_Unchecked_Union (Op_Type) then
3894             declare
3895                Lhs_Type      : constant Node_Id := Etype (L_Exp);
3896                Rhs_Type      : constant Node_Id := Etype (R_Exp);
3897                Lhs_Discr_Val : Node_Id;
3898                Rhs_Discr_Val : Node_Id;
3899
3900             begin
3901                --  Per-object constrained selected components require special
3902                --  attention. If the enclosing scope of the component is an
3903                --  Unchecked_Union, we can not reference its discriminants
3904                --  directly. This is why we use the two extra parameters of
3905                --  the equality function of the enclosing Unchecked_Union.
3906
3907                --  type UU_Type (Discr : Integer := 0) is
3908                --     . . .
3909                --  end record;
3910                --  pragma Unchecked_Union (UU_Type);
3911
3912                --  1. Unchecked_Union enclosing record:
3913
3914                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
3915                --        . . .
3916                --        Comp : UU_Type (Discr);
3917                --        . . .
3918                --     end Enclosing_UU_Type;
3919                --     pragma Unchecked_Union (Enclosing_UU_Type);
3920
3921                --     Obj1 : Enclosing_UU_Type;
3922                --     Obj2 : Enclosing_UU_Type (1);
3923
3924                --     . . . Obj1 = Obj2 . . .
3925
3926                --     Generated code:
3927
3928                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
3929
3930                --  A and B are the formal parameters of the equality function
3931                --  of Enclosing_UU_Type. The function always has two extra
3932                --  formals to capture the inferred discriminant values.
3933
3934                --  2. Non-Unchecked_Union enclosing record:
3935
3936                --     type
3937                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
3938                --     is record
3939                --        . . .
3940                --        Comp : UU_Type (Discr);
3941                --        . . .
3942                --     end Enclosing_Non_UU_Type;
3943
3944                --     Obj1 : Enclosing_Non_UU_Type;
3945                --     Obj2 : Enclosing_Non_UU_Type (1);
3946
3947                --     . . . Obj1 = Obj2 . . .
3948
3949                --     Generated code:
3950
3951                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
3952                --                        obj1.discr, obj2.discr)) then
3953
3954                --  In this case we can directly reference the discriminants of
3955                --  the enclosing record.
3956
3957                --  Lhs of equality
3958
3959                if Nkind (Lhs) = N_Selected_Component
3960                  and then Has_Per_Object_Constraint
3961                             (Entity (Selector_Name (Lhs)))
3962                then
3963                   --  Enclosing record is an Unchecked_Union, use formal A
3964
3965                   if Is_Unchecked_Union (Scope
3966                        (Entity (Selector_Name (Lhs))))
3967                   then
3968                      Lhs_Discr_Val :=
3969                        Make_Identifier (Loc,
3970                          Chars => Name_A);
3971
3972                   --  Enclosing record is of a non-Unchecked_Union type, it is
3973                   --  possible to reference the discriminant.
3974
3975                   else
3976                      Lhs_Discr_Val :=
3977                        Make_Selected_Component (Loc,
3978                          Prefix => Prefix (Lhs),
3979                          Selector_Name =>
3980                            New_Copy
3981                              (Get_Discriminant_Value
3982                                 (First_Discriminant (Lhs_Type),
3983                                  Lhs_Type,
3984                                  Stored_Constraint (Lhs_Type))));
3985                   end if;
3986
3987                --  Comment needed here ???
3988
3989                else
3990                   --  Infer the discriminant value
3991
3992                   Lhs_Discr_Val :=
3993                     New_Copy
3994                       (Get_Discriminant_Value
3995                          (First_Discriminant (Lhs_Type),
3996                           Lhs_Type,
3997                           Stored_Constraint (Lhs_Type)));
3998                end if;
3999
4000                --  Rhs of equality
4001
4002                if Nkind (Rhs) = N_Selected_Component
4003                  and then Has_Per_Object_Constraint
4004                             (Entity (Selector_Name (Rhs)))
4005                then
4006                   if Is_Unchecked_Union
4007                        (Scope (Entity (Selector_Name (Rhs))))
4008                   then
4009                      Rhs_Discr_Val :=
4010                        Make_Identifier (Loc,
4011                          Chars => Name_B);
4012
4013                   else
4014                      Rhs_Discr_Val :=
4015                        Make_Selected_Component (Loc,
4016                          Prefix => Prefix (Rhs),
4017                          Selector_Name =>
4018                            New_Copy (Get_Discriminant_Value (
4019                              First_Discriminant (Rhs_Type),
4020                              Rhs_Type,
4021                              Stored_Constraint (Rhs_Type))));
4022
4023                   end if;
4024                else
4025                   Rhs_Discr_Val :=
4026                     New_Copy (Get_Discriminant_Value (
4027                       First_Discriminant (Rhs_Type),
4028                       Rhs_Type,
4029                       Stored_Constraint (Rhs_Type)));
4030
4031                end if;
4032
4033                Rewrite (N,
4034                  Make_Function_Call (Loc,
4035                    Name => New_Reference_To (Eq, Loc),
4036                    Parameter_Associations => New_List (
4037                      L_Exp,
4038                      R_Exp,
4039                      Lhs_Discr_Val,
4040                      Rhs_Discr_Val)));
4041             end;
4042
4043          --  Normal case, not an unchecked union
4044
4045          else
4046             Rewrite (N,
4047               Make_Function_Call (Loc,
4048                 Name => New_Reference_To (Eq, Loc),
4049                 Parameter_Associations => New_List (L_Exp, R_Exp)));
4050          end if;
4051
4052          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4053       end Build_Equality_Call;
4054
4055       ------------------------------------
4056       -- Has_Unconstrained_UU_Component --
4057       ------------------------------------
4058
4059       function Has_Unconstrained_UU_Component
4060         (Typ : Node_Id) return Boolean
4061       is
4062          Tdef  : constant Node_Id :=
4063                    Type_Definition (Declaration_Node (Typ));
4064          Clist : Node_Id;
4065          Vpart : Node_Id;
4066
4067          function Component_Is_Unconstrained_UU
4068            (Comp : Node_Id) return Boolean;
4069          --  Determines whether the subtype of the component is an
4070          --  unconstrained Unchecked_Union.
4071
4072          function Variant_Is_Unconstrained_UU
4073            (Variant : Node_Id) return Boolean;
4074          --  Determines whether a component of the variant has an unconstrained
4075          --  Unchecked_Union subtype.
4076
4077          -----------------------------------
4078          -- Component_Is_Unconstrained_UU --
4079          -----------------------------------
4080
4081          function Component_Is_Unconstrained_UU
4082            (Comp : Node_Id) return Boolean
4083          is
4084          begin
4085             if Nkind (Comp) /= N_Component_Declaration then
4086                return False;
4087             end if;
4088
4089             declare
4090                Sindic : constant Node_Id :=
4091                           Subtype_Indication (Component_Definition (Comp));
4092
4093             begin
4094                --  Unconstrained nominal type. In the case of a constraint
4095                --  present, the node kind would have been N_Subtype_Indication.
4096
4097                if Nkind (Sindic) = N_Identifier then
4098                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
4099                end if;
4100
4101                return False;
4102             end;
4103          end Component_Is_Unconstrained_UU;
4104
4105          ---------------------------------
4106          -- Variant_Is_Unconstrained_UU --
4107          ---------------------------------
4108
4109          function Variant_Is_Unconstrained_UU
4110            (Variant : Node_Id) return Boolean
4111          is
4112             Clist : constant Node_Id := Component_List (Variant);
4113
4114          begin
4115             if Is_Empty_List (Component_Items (Clist)) then
4116                return False;
4117             end if;
4118
4119             declare
4120                Comp : Node_Id := First (Component_Items (Clist));
4121
4122             begin
4123                while Present (Comp) loop
4124
4125                   --  One component is sufficent
4126
4127                   if Component_Is_Unconstrained_UU (Comp) then
4128                      return True;
4129                   end if;
4130
4131                   Next (Comp);
4132                end loop;
4133             end;
4134
4135             --  None of the components withing the variant were of
4136             --  unconstrained Unchecked_Union type.
4137
4138             return False;
4139          end Variant_Is_Unconstrained_UU;
4140
4141       --  Start of processing for Has_Unconstrained_UU_Component
4142
4143       begin
4144          if Null_Present (Tdef) then
4145             return False;
4146          end if;
4147
4148          Clist := Component_List (Tdef);
4149          Vpart := Variant_Part (Clist);
4150
4151          --  Inspect available components
4152
4153          if Present (Component_Items (Clist)) then
4154             declare
4155                Comp : Node_Id := First (Component_Items (Clist));
4156
4157             begin
4158                while Present (Comp) loop
4159
4160                   --  One component is sufficent
4161
4162                   if Component_Is_Unconstrained_UU (Comp) then
4163                      return True;
4164                   end if;
4165
4166                   Next (Comp);
4167                end loop;
4168             end;
4169          end if;
4170
4171          --  Inspect available components withing variants
4172
4173          if Present (Vpart) then
4174             declare
4175                Variant : Node_Id := First (Variants (Vpart));
4176
4177             begin
4178                while Present (Variant) loop
4179
4180                   --  One component within a variant is sufficent
4181
4182                   if Variant_Is_Unconstrained_UU (Variant) then
4183                      return True;
4184                   end if;
4185
4186                   Next (Variant);
4187                end loop;
4188             end;
4189          end if;
4190
4191          --  Neither the available components, nor the components inside the
4192          --  variant parts were of an unconstrained Unchecked_Union subtype.
4193
4194          return False;
4195       end Has_Unconstrained_UU_Component;
4196
4197    --  Start of processing for Expand_N_Op_Eq
4198
4199    begin
4200       Binary_Op_Validity_Checks (N);
4201
4202       if Ekind (Typl) = E_Private_Type then
4203          Typl := Underlying_Type (Typl);
4204
4205       elsif Ekind (Typl) = E_Private_Subtype then
4206          Typl := Underlying_Type (Base_Type (Typl));
4207       end if;
4208
4209       --  It may happen in error situations that the underlying type is not
4210       --  set. The error will be detected later, here we just defend the
4211       --  expander code.
4212
4213       if No (Typl) then
4214          return;
4215       end if;
4216
4217       Typl := Base_Type (Typl);
4218
4219       --  Vax float types
4220
4221       if Vax_Float (Typl) then
4222          Expand_Vax_Comparison (N);
4223          return;
4224
4225       --  Boolean types (requiring handling of non-standard case)
4226
4227       elsif Is_Boolean_Type (Typl) then
4228          Adjust_Condition (Left_Opnd (N));
4229          Adjust_Condition (Right_Opnd (N));
4230          Set_Etype (N, Standard_Boolean);
4231          Adjust_Result_Type (N, Typ);
4232
4233       --  Array types
4234
4235       elsif Is_Array_Type (Typl) then
4236
4237          --  If we are doing full validity checking, then expand out array
4238          --  comparisons to make sure that we check the array elements.
4239
4240          if Validity_Check_Operands then
4241             declare
4242                Save_Force_Validity_Checks : constant Boolean :=
4243                                               Force_Validity_Checks;
4244             begin
4245                Force_Validity_Checks := True;
4246                Rewrite (N,
4247                  Expand_Array_Equality
4248                   (N,
4249                    Relocate_Node (Lhs),
4250                    Relocate_Node (Rhs),
4251                    Bodies,
4252                    Typl));
4253                Insert_Actions (N, Bodies);
4254                Analyze_And_Resolve (N, Standard_Boolean);
4255                Force_Validity_Checks := Save_Force_Validity_Checks;
4256             end;
4257
4258          --  Packed case
4259
4260          elsif Is_Bit_Packed_Array (Typl) then
4261             Expand_Packed_Eq (N);
4262
4263          --  Where the component type is elementary we can use a block bit
4264          --  comparison (if supported on the target) exception in the case
4265          --  of floating-point (negative zero issues require element by
4266          --  element comparison), and atomic types (where we must be sure
4267          --  to load elements independently).
4268
4269          elsif Is_Elementary_Type (Component_Type (Typl))
4270            and then not Is_Floating_Point_Type (Component_Type (Typl))
4271            and then not Is_Atomic (Component_Type (Typl))
4272            and then Support_Composite_Compare_On_Target
4273          then
4274             null;
4275
4276          --  For composite and floating-point cases, expand equality loop
4277          --  to make sure of using proper comparisons for tagged types,
4278          --  and correctly handling the floating-point case.
4279
4280          else
4281             Rewrite (N,
4282               Expand_Array_Equality
4283                 (N,
4284                  Relocate_Node (Lhs),
4285                  Relocate_Node (Rhs),
4286                  Bodies,
4287                  Typl));
4288             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
4289             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4290          end if;
4291
4292       --  Record Types
4293
4294       elsif Is_Record_Type (Typl) then
4295
4296          --  For tagged types, use the primitive "="
4297
4298          if Is_Tagged_Type (Typl) then
4299
4300             --  If this is derived from an untagged private type completed
4301             --  with a tagged type, it does not have a full view, so we
4302             --  use the primitive operations of the private type.
4303             --  This check should no longer be necessary when these
4304             --  types receive their full views ???
4305
4306             if Is_Private_Type (A_Typ)
4307               and then not Is_Tagged_Type (A_Typ)
4308               and then Is_Derived_Type (A_Typ)
4309               and then No (Full_View (A_Typ))
4310             then
4311                --  Search for equality operation, checking that the
4312                --  operands have the same type. Note that we must find
4313                --  a matching entry, or something is very wrong!
4314
4315                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
4316
4317                while Present (Prim) loop
4318                   exit when Chars (Node (Prim)) = Name_Op_Eq
4319                     and then Etype (First_Formal (Node (Prim))) =
4320                              Etype (Next_Formal (First_Formal (Node (Prim))))
4321                     and then
4322                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
4323
4324                   Next_Elmt (Prim);
4325                end loop;
4326
4327                pragma Assert (Present (Prim));
4328                Op_Name := Node (Prim);
4329
4330             --  Find the type's predefined equality or an overriding
4331             --  user-defined equality. The reason for not simply calling
4332             --  Find_Prim_Op here is that there may be a user-defined
4333             --  overloaded equality op that precedes the equality that
4334             --  we want, so we have to explicitly search (e.g., there
4335             --  could be an equality with two different parameter types).
4336
4337             else
4338                if Is_Class_Wide_Type (Typl) then
4339                   Typl := Root_Type (Typl);
4340                end if;
4341
4342                Prim := First_Elmt (Primitive_Operations (Typl));
4343                while Present (Prim) loop
4344                   exit when Chars (Node (Prim)) = Name_Op_Eq
4345                     and then Etype (First_Formal (Node (Prim))) =
4346                              Etype (Next_Formal (First_Formal (Node (Prim))))
4347                     and then
4348                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
4349
4350                   Next_Elmt (Prim);
4351                end loop;
4352
4353                pragma Assert (Present (Prim));
4354                Op_Name := Node (Prim);
4355             end if;
4356
4357             Build_Equality_Call (Op_Name);
4358
4359          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
4360          --  predefined equality operator for a type which has a subcomponent
4361          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
4362
4363          elsif Has_Unconstrained_UU_Component (Typl) then
4364             Insert_Action (N,
4365               Make_Raise_Program_Error (Loc,
4366                 Reason => PE_Unchecked_Union_Restriction));
4367
4368             --  Prevent Gigi from generating incorrect code by rewriting the
4369             --  equality as a standard False.
4370
4371             Rewrite (N,
4372               New_Occurrence_Of (Standard_False, Loc));
4373
4374          elsif Is_Unchecked_Union (Typl) then
4375
4376             --  If we can infer the discriminants of the operands, we make a
4377             --  call to the TSS equality function.
4378
4379             if Has_Inferable_Discriminants (Lhs)
4380                  and then
4381                Has_Inferable_Discriminants (Rhs)
4382             then
4383                Build_Equality_Call
4384                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
4385
4386             else
4387                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
4388                --  the predefined equality operator for an Unchecked_Union type
4389                --  if either of the operands lack inferable discriminants.
4390
4391                Insert_Action (N,
4392                  Make_Raise_Program_Error (Loc,
4393                    Reason => PE_Unchecked_Union_Restriction));
4394
4395                --  Prevent Gigi from generating incorrect code by rewriting
4396                --  the equality as a standard False.
4397
4398                Rewrite (N,
4399                  New_Occurrence_Of (Standard_False, Loc));
4400
4401             end if;
4402
4403          --  If a type support function is present (for complex cases), use it
4404
4405          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
4406             Build_Equality_Call
4407               (TSS (Root_Type (Typl), TSS_Composite_Equality));
4408
4409          --  Otherwise expand the component by component equality. Note that
4410          --  we never use block-bit coparisons for records, because of the
4411          --  problems with gaps. The backend will often be able to recombine
4412          --  the separate comparisons that we generate here.
4413
4414          else
4415             Remove_Side_Effects (Lhs);
4416             Remove_Side_Effects (Rhs);
4417             Rewrite (N,
4418               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
4419
4420             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
4421             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4422          end if;
4423       end if;
4424
4425       --  If we still have an equality comparison (i.e. it was not rewritten
4426       --  in some way), then we can test if result is needed at compile time).
4427
4428       if Nkind (N) = N_Op_Eq then
4429          Rewrite_Comparison (N);
4430       end if;
4431    end Expand_N_Op_Eq;
4432
4433    -----------------------
4434    -- Expand_N_Op_Expon --
4435    -----------------------
4436
4437    procedure Expand_N_Op_Expon (N : Node_Id) is
4438       Loc    : constant Source_Ptr := Sloc (N);
4439       Typ    : constant Entity_Id  := Etype (N);
4440       Rtyp   : constant Entity_Id  := Root_Type (Typ);
4441       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
4442       Bastyp : constant Node_Id    := Etype (Base);
4443       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
4444       Exptyp : constant Entity_Id  := Etype (Exp);
4445       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
4446       Expv   : Uint;
4447       Xnode  : Node_Id;
4448       Temp   : Node_Id;
4449       Rent   : RE_Id;
4450       Ent    : Entity_Id;
4451       Etyp   : Entity_Id;
4452
4453    begin
4454       Binary_Op_Validity_Checks (N);
4455
4456       --  If either operand is of a private type, then we have the use of
4457       --  an intrinsic operator, and we get rid of the privateness, by using
4458       --  root types of underlying types for the actual operation. Otherwise
4459       --  the private types will cause trouble if we expand multiplications
4460       --  or shifts etc. We also do this transformation if the result type
4461       --  is different from the base type.
4462
4463       if Is_Private_Type (Etype (Base))
4464            or else
4465          Is_Private_Type (Typ)
4466            or else
4467          Is_Private_Type (Exptyp)
4468            or else
4469          Rtyp /= Root_Type (Bastyp)
4470       then
4471          declare
4472             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
4473             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
4474
4475          begin
4476             Rewrite (N,
4477               Unchecked_Convert_To (Typ,
4478                 Make_Op_Expon (Loc,
4479                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
4480                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
4481             Analyze_And_Resolve (N, Typ);
4482             return;
4483          end;
4484       end if;
4485
4486       --  Test for case of known right argument
4487
4488       if Compile_Time_Known_Value (Exp) then
4489          Expv := Expr_Value (Exp);
4490
4491          --  We only fold small non-negative exponents. You might think we
4492          --  could fold small negative exponents for the real case, but we
4493          --  can't because we are required to raise Constraint_Error for
4494          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
4495          --  See ACVC test C4A012B.
4496
4497          if Expv >= 0 and then Expv <= 4 then
4498
4499             --  X ** 0 = 1 (or 1.0)
4500
4501             if Expv = 0 then
4502                if Ekind (Typ) in Integer_Kind then
4503                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
4504                else
4505                   Xnode := Make_Real_Literal (Loc, Ureal_1);
4506                end if;
4507
4508             --  X ** 1 = X
4509
4510             elsif Expv = 1 then
4511                Xnode := Base;
4512
4513             --  X ** 2 = X * X
4514
4515             elsif Expv = 2 then
4516                Xnode :=
4517                  Make_Op_Multiply (Loc,
4518                    Left_Opnd  => Duplicate_Subexpr (Base),
4519                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
4520
4521             --  X ** 3 = X * X * X
4522
4523             elsif Expv = 3 then
4524                Xnode :=
4525                  Make_Op_Multiply (Loc,
4526                    Left_Opnd =>
4527                      Make_Op_Multiply (Loc,
4528                        Left_Opnd  => Duplicate_Subexpr (Base),
4529                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
4530                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
4531
4532             --  X ** 4  ->
4533             --    En : constant base'type := base * base;
4534             --    ...
4535             --    En * En
4536
4537             else -- Expv = 4
4538                Temp :=
4539                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
4540
4541                Insert_Actions (N, New_List (
4542                  Make_Object_Declaration (Loc,
4543                    Defining_Identifier => Temp,
4544                    Constant_Present    => True,
4545                    Object_Definition   => New_Reference_To (Typ, Loc),
4546                    Expression =>
4547                      Make_Op_Multiply (Loc,
4548                        Left_Opnd  => Duplicate_Subexpr (Base),
4549                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
4550
4551                Xnode :=
4552                  Make_Op_Multiply (Loc,
4553                    Left_Opnd  => New_Reference_To (Temp, Loc),
4554                    Right_Opnd => New_Reference_To (Temp, Loc));
4555             end if;
4556
4557             Rewrite (N, Xnode);
4558             Analyze_And_Resolve (N, Typ);
4559             return;
4560          end if;
4561       end if;
4562
4563       --  Case of (2 ** expression) appearing as an argument of an integer
4564       --  multiplication, or as the right argument of a division of a non-
4565       --  negative integer. In such cases we leave the node untouched, setting
4566       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
4567       --  of the higher level node converts it into a shift.
4568
4569       if Nkind (Base) = N_Integer_Literal
4570         and then Intval (Base) = 2
4571         and then Is_Integer_Type (Root_Type (Exptyp))
4572         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
4573         and then Is_Unsigned_Type (Exptyp)
4574         and then not Ovflo
4575         and then Nkind (Parent (N)) in N_Binary_Op
4576       then
4577          declare
4578             P : constant Node_Id := Parent (N);
4579             L : constant Node_Id := Left_Opnd (P);
4580             R : constant Node_Id := Right_Opnd (P);
4581
4582          begin
4583             if (Nkind (P) = N_Op_Multiply
4584                  and then
4585                    ((Is_Integer_Type (Etype (L)) and then R = N)
4586                        or else
4587                     (Is_Integer_Type (Etype (R)) and then L = N))
4588                  and then not Do_Overflow_Check (P))
4589
4590               or else
4591                 (Nkind (P) = N_Op_Divide
4592                   and then Is_Integer_Type (Etype (L))
4593                   and then Is_Unsigned_Type (Etype (L))
4594                   and then R = N
4595                   and then not Do_Overflow_Check (P))
4596             then
4597                Set_Is_Power_Of_2_For_Shift (N);
4598                return;
4599             end if;
4600          end;
4601       end if;
4602
4603       --  Fall through if exponentiation must be done using a runtime routine
4604
4605       --  First deal with modular case
4606
4607       if Is_Modular_Integer_Type (Rtyp) then
4608
4609          --  Non-binary case, we call the special exponentiation routine for
4610          --  the non-binary case, converting the argument to Long_Long_Integer
4611          --  and passing the modulus value. Then the result is converted back
4612          --  to the base type.
4613
4614          if Non_Binary_Modulus (Rtyp) then
4615             Rewrite (N,
4616               Convert_To (Typ,
4617                 Make_Function_Call (Loc,
4618                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
4619                   Parameter_Associations => New_List (
4620                     Convert_To (Standard_Integer, Base),
4621                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
4622                     Exp))));
4623
4624          --  Binary case, in this case, we call one of two routines, either
4625          --  the unsigned integer case, or the unsigned long long integer
4626          --  case, with a final "and" operation to do the required mod.
4627
4628          else
4629             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
4630                Ent := RTE (RE_Exp_Unsigned);
4631             else
4632                Ent := RTE (RE_Exp_Long_Long_Unsigned);
4633             end if;
4634
4635             Rewrite (N,
4636               Convert_To (Typ,
4637                 Make_Op_And (Loc,
4638                   Left_Opnd =>
4639                     Make_Function_Call (Loc,
4640                       Name => New_Reference_To (Ent, Loc),
4641                       Parameter_Associations => New_List (
4642                         Convert_To (Etype (First_Formal (Ent)), Base),
4643                         Exp)),
4644                    Right_Opnd =>
4645                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
4646
4647          end if;
4648
4649          --  Common exit point for modular type case
4650
4651          Analyze_And_Resolve (N, Typ);
4652          return;
4653
4654       --  Signed integer cases, done using either Integer or Long_Long_Integer.
4655       --  It is not worth having routines for Short_[Short_]Integer, since for
4656       --  most machines it would not help, and it would generate more code that
4657       --  might need certification in the HI-E case.
4658
4659       --  In the integer cases, we have two routines, one for when overflow
4660       --  checks are required, and one when they are not required, since
4661       --  there is a real gain in ommitting checks on many machines.
4662
4663       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
4664         or else (Rtyp = Base_Type (Standard_Long_Integer)
4665                    and then
4666                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
4667         or else (Rtyp = Universal_Integer)
4668       then
4669          Etyp := Standard_Long_Long_Integer;
4670
4671          if Ovflo then
4672             Rent := RE_Exp_Long_Long_Integer;
4673          else
4674             Rent := RE_Exn_Long_Long_Integer;
4675          end if;
4676
4677       elsif Is_Signed_Integer_Type (Rtyp) then
4678          Etyp := Standard_Integer;
4679
4680          if Ovflo then
4681             Rent := RE_Exp_Integer;
4682          else
4683             Rent := RE_Exn_Integer;
4684          end if;
4685
4686       --  Floating-point cases, always done using Long_Long_Float. We do not
4687       --  need separate routines for the overflow case here, since in the case
4688       --  of floating-point, we generate infinities anyway as a rule (either
4689       --  that or we automatically trap overflow), and if there is an infinity
4690       --  generated and a range check is required, the check will fail anyway.
4691
4692       else
4693          pragma Assert (Is_Floating_Point_Type (Rtyp));
4694          Etyp := Standard_Long_Long_Float;
4695          Rent := RE_Exn_Long_Long_Float;
4696       end if;
4697
4698       --  Common processing for integer cases and floating-point cases.
4699       --  If we are in the right type, we can call runtime routine directly
4700
4701       if Typ = Etyp
4702         and then Rtyp /= Universal_Integer
4703         and then Rtyp /= Universal_Real
4704       then
4705          Rewrite (N,
4706            Make_Function_Call (Loc,
4707              Name => New_Reference_To (RTE (Rent), Loc),
4708              Parameter_Associations => New_List (Base, Exp)));
4709
4710       --  Otherwise we have to introduce conversions (conversions are also
4711       --  required in the universal cases, since the runtime routine is
4712       --  typed using one of the standard types.
4713
4714       else
4715          Rewrite (N,
4716            Convert_To (Typ,
4717              Make_Function_Call (Loc,
4718                Name => New_Reference_To (RTE (Rent), Loc),
4719                Parameter_Associations => New_List (
4720                  Convert_To (Etyp, Base),
4721                  Exp))));
4722       end if;
4723
4724       Analyze_And_Resolve (N, Typ);
4725       return;
4726
4727    exception
4728       when RE_Not_Available =>
4729          return;
4730    end Expand_N_Op_Expon;
4731
4732    --------------------
4733    -- Expand_N_Op_Ge --
4734    --------------------
4735
4736    procedure Expand_N_Op_Ge (N : Node_Id) is
4737       Typ  : constant Entity_Id := Etype (N);
4738       Op1  : constant Node_Id   := Left_Opnd (N);
4739       Op2  : constant Node_Id   := Right_Opnd (N);
4740       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4741
4742    begin
4743       Binary_Op_Validity_Checks (N);
4744
4745       if Vax_Float (Typ1) then
4746          Expand_Vax_Comparison (N);
4747          return;
4748
4749       elsif Is_Array_Type (Typ1) then
4750          Expand_Array_Comparison (N);
4751          return;
4752       end if;
4753
4754       if Is_Boolean_Type (Typ1) then
4755          Adjust_Condition (Op1);
4756          Adjust_Condition (Op2);
4757          Set_Etype (N, Standard_Boolean);
4758          Adjust_Result_Type (N, Typ);
4759       end if;
4760
4761       Rewrite_Comparison (N);
4762    end Expand_N_Op_Ge;
4763
4764    --------------------
4765    -- Expand_N_Op_Gt --
4766    --------------------
4767
4768    procedure Expand_N_Op_Gt (N : Node_Id) is
4769       Typ  : constant Entity_Id := Etype (N);
4770       Op1  : constant Node_Id   := Left_Opnd (N);
4771       Op2  : constant Node_Id   := Right_Opnd (N);
4772       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4773
4774    begin
4775       Binary_Op_Validity_Checks (N);
4776
4777       if Vax_Float (Typ1) then
4778          Expand_Vax_Comparison (N);
4779          return;
4780
4781       elsif Is_Array_Type (Typ1) then
4782          Expand_Array_Comparison (N);
4783          return;
4784       end if;
4785
4786       if Is_Boolean_Type (Typ1) then
4787          Adjust_Condition (Op1);
4788          Adjust_Condition (Op2);
4789          Set_Etype (N, Standard_Boolean);
4790          Adjust_Result_Type (N, Typ);
4791       end if;
4792
4793       Rewrite_Comparison (N);
4794    end Expand_N_Op_Gt;
4795
4796    --------------------
4797    -- Expand_N_Op_Le --
4798    --------------------
4799
4800    procedure Expand_N_Op_Le (N : Node_Id) is
4801       Typ  : constant Entity_Id := Etype (N);
4802       Op1  : constant Node_Id   := Left_Opnd (N);
4803       Op2  : constant Node_Id   := Right_Opnd (N);
4804       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4805
4806    begin
4807       Binary_Op_Validity_Checks (N);
4808
4809       if Vax_Float (Typ1) then
4810          Expand_Vax_Comparison (N);
4811          return;
4812
4813       elsif Is_Array_Type (Typ1) then
4814          Expand_Array_Comparison (N);
4815          return;
4816       end if;
4817
4818       if Is_Boolean_Type (Typ1) then
4819          Adjust_Condition (Op1);
4820          Adjust_Condition (Op2);
4821          Set_Etype (N, Standard_Boolean);
4822          Adjust_Result_Type (N, Typ);
4823       end if;
4824
4825       Rewrite_Comparison (N);
4826    end Expand_N_Op_Le;
4827
4828    --------------------
4829    -- Expand_N_Op_Lt --
4830    --------------------
4831
4832    procedure Expand_N_Op_Lt (N : Node_Id) is
4833       Typ  : constant Entity_Id := Etype (N);
4834       Op1  : constant Node_Id   := Left_Opnd (N);
4835       Op2  : constant Node_Id   := Right_Opnd (N);
4836       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
4837
4838    begin
4839       Binary_Op_Validity_Checks (N);
4840
4841       if Vax_Float (Typ1) then
4842          Expand_Vax_Comparison (N);
4843          return;
4844
4845       elsif Is_Array_Type (Typ1) then
4846          Expand_Array_Comparison (N);
4847          return;
4848       end if;
4849
4850       if Is_Boolean_Type (Typ1) then
4851          Adjust_Condition (Op1);
4852          Adjust_Condition (Op2);
4853          Set_Etype (N, Standard_Boolean);
4854          Adjust_Result_Type (N, Typ);
4855       end if;
4856
4857       Rewrite_Comparison (N);
4858    end Expand_N_Op_Lt;
4859
4860    -----------------------
4861    -- Expand_N_Op_Minus --
4862    -----------------------
4863
4864    procedure Expand_N_Op_Minus (N : Node_Id) is
4865       Loc : constant Source_Ptr := Sloc (N);
4866       Typ : constant Entity_Id  := Etype (N);
4867
4868    begin
4869       Unary_Op_Validity_Checks (N);
4870
4871       if not Backend_Overflow_Checks_On_Target
4872          and then Is_Signed_Integer_Type (Etype (N))
4873          and then Do_Overflow_Check (N)
4874       then
4875          --  Software overflow checking expands -expr into (0 - expr)
4876
4877          Rewrite (N,
4878            Make_Op_Subtract (Loc,
4879              Left_Opnd  => Make_Integer_Literal (Loc, 0),
4880              Right_Opnd => Right_Opnd (N)));
4881
4882          Analyze_And_Resolve (N, Typ);
4883
4884       --  Vax floating-point types case
4885
4886       elsif Vax_Float (Etype (N)) then
4887          Expand_Vax_Arith (N);
4888       end if;
4889    end Expand_N_Op_Minus;
4890
4891    ---------------------
4892    -- Expand_N_Op_Mod --
4893    ---------------------
4894
4895    procedure Expand_N_Op_Mod (N : Node_Id) is
4896       Loc   : constant Source_Ptr := Sloc (N);
4897       Typ   : constant Entity_Id  := Etype (N);
4898       Left  : constant Node_Id    := Left_Opnd (N);
4899       Right : constant Node_Id    := Right_Opnd (N);
4900       DOC   : constant Boolean    := Do_Overflow_Check (N);
4901       DDC   : constant Boolean    := Do_Division_Check (N);
4902
4903       LLB : Uint;
4904       Llo : Uint;
4905       Lhi : Uint;
4906       LOK : Boolean;
4907       Rlo : Uint;
4908       Rhi : Uint;
4909       ROK : Boolean;
4910
4911    begin
4912       Binary_Op_Validity_Checks (N);
4913
4914       Determine_Range (Right, ROK, Rlo, Rhi);
4915       Determine_Range (Left,  LOK, Llo, Lhi);
4916
4917       --  Convert mod to rem if operands are known non-negative. We do this
4918       --  since it is quite likely that this will improve the quality of code,
4919       --  (the operation now corresponds to the hardware remainder), and it
4920       --  does not seem likely that it could be harmful.
4921
4922       if LOK and then Llo >= 0
4923            and then
4924          ROK and then Rlo >= 0
4925       then
4926          Rewrite (N,
4927            Make_Op_Rem (Sloc (N),
4928              Left_Opnd  => Left_Opnd (N),
4929              Right_Opnd => Right_Opnd (N)));
4930
4931          --  Instead of reanalyzing the node we do the analysis manually.
4932          --  This avoids anomalies when the replacement is done in an
4933          --  instance and is epsilon more efficient.
4934
4935          Set_Entity            (N, Standard_Entity (S_Op_Rem));
4936          Set_Etype             (N, Typ);
4937          Set_Do_Overflow_Check (N, DOC);
4938          Set_Do_Division_Check (N, DDC);
4939          Expand_N_Op_Rem (N);
4940          Set_Analyzed (N);
4941
4942       --  Otherwise, normal mod processing
4943
4944       else
4945          if Is_Integer_Type (Etype (N)) then
4946             Apply_Divide_Check (N);
4947          end if;
4948
4949          --  Apply optimization x mod 1 = 0. We don't really need that with
4950          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
4951          --  certainly harmless.
4952
4953          if Is_Integer_Type (Etype (N))
4954            and then Compile_Time_Known_Value (Right)
4955            and then Expr_Value (Right) = Uint_1
4956          then
4957             Rewrite (N, Make_Integer_Literal (Loc, 0));
4958             Analyze_And_Resolve (N, Typ);
4959             return;
4960          end if;
4961
4962          --  Deal with annoying case of largest negative number remainder
4963          --  minus one. Gigi does not handle this case correctly, because
4964          --  it generates a divide instruction which may trap in this case.
4965
4966          --  In fact the check is quite easy, if the right operand is -1,
4967          --  then the mod value is always 0, and we can just ignore the
4968          --  left operand completely in this case.
4969
4970          --  The operand type may be private (e.g. in the expansion of an
4971          --  an intrinsic operation) so we must use the underlying type to
4972          --  get the bounds, and convert the literals explicitly.
4973
4974          LLB :=
4975            Expr_Value
4976              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
4977
4978          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4979            and then
4980             ((not LOK) or else (Llo = LLB))
4981          then
4982             Rewrite (N,
4983               Make_Conditional_Expression (Loc,
4984                 Expressions => New_List (
4985                   Make_Op_Eq (Loc,
4986                     Left_Opnd => Duplicate_Subexpr (Right),
4987                     Right_Opnd =>
4988                       Unchecked_Convert_To (Typ,
4989                         Make_Integer_Literal (Loc, -1))),
4990                   Unchecked_Convert_To (Typ,
4991                     Make_Integer_Literal (Loc, Uint_0)),
4992                   Relocate_Node (N))));
4993
4994             Set_Analyzed (Next (Next (First (Expressions (N)))));
4995             Analyze_And_Resolve (N, Typ);
4996          end if;
4997       end if;
4998    end Expand_N_Op_Mod;
4999
5000    --------------------------
5001    -- Expand_N_Op_Multiply --
5002    --------------------------
5003
5004    procedure Expand_N_Op_Multiply (N : Node_Id) is
5005       Loc  : constant Source_Ptr := Sloc (N);
5006       Lop  : constant Node_Id    := Left_Opnd (N);
5007       Rop  : constant Node_Id    := Right_Opnd (N);
5008
5009       Lp2  : constant Boolean :=
5010                Nkind (Lop) = N_Op_Expon
5011                  and then Is_Power_Of_2_For_Shift (Lop);
5012
5013       Rp2  : constant Boolean :=
5014                Nkind (Rop) = N_Op_Expon
5015                  and then Is_Power_Of_2_For_Shift (Rop);
5016
5017       Ltyp : constant Entity_Id  := Etype (Lop);
5018       Rtyp : constant Entity_Id  := Etype (Rop);
5019       Typ  : Entity_Id           := Etype (N);
5020
5021    begin
5022       Binary_Op_Validity_Checks (N);
5023
5024       --  Special optimizations for integer types
5025
5026       if Is_Integer_Type (Typ) then
5027
5028          --  N * 0 = 0 * N = 0 for integer types
5029
5030          if (Compile_Time_Known_Value (Rop)
5031               and then Expr_Value (Rop) = Uint_0)
5032            or else
5033             (Compile_Time_Known_Value (Lop)
5034               and then Expr_Value (Lop) = Uint_0)
5035          then
5036             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
5037             Analyze_And_Resolve (N, Typ);
5038             return;
5039          end if;
5040
5041          --  N * 1 = 1 * N = N for integer types
5042
5043          --  This optimisation is not done if we are going to
5044          --  rewrite the product 1 * 2 ** N to a shift.
5045
5046          if Compile_Time_Known_Value (Rop)
5047            and then Expr_Value (Rop) = Uint_1
5048            and then not Lp2
5049          then
5050             Rewrite (N, Lop);
5051             return;
5052
5053          elsif Compile_Time_Known_Value (Lop)
5054            and then Expr_Value (Lop) = Uint_1
5055            and then not Rp2
5056          then
5057             Rewrite (N, Rop);
5058             return;
5059          end if;
5060       end if;
5061
5062       --  Deal with VAX float case
5063
5064       if Vax_Float (Typ) then
5065          Expand_Vax_Arith (N);
5066          return;
5067       end if;
5068
5069       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5070       --  Is_Power_Of_2_For_Shift is set means that we know that our left
5071       --  operand is an integer, as required for this to work.
5072
5073       if Rp2 then
5074          if Lp2 then
5075
5076             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
5077
5078             Rewrite (N,
5079               Make_Op_Expon (Loc,
5080                 Left_Opnd => Make_Integer_Literal (Loc, 2),
5081                 Right_Opnd =>
5082                   Make_Op_Add (Loc,
5083                     Left_Opnd  => Right_Opnd (Lop),
5084                     Right_Opnd => Right_Opnd (Rop))));
5085             Analyze_And_Resolve (N, Typ);
5086             return;
5087
5088          else
5089             Rewrite (N,
5090               Make_Op_Shift_Left (Loc,
5091                 Left_Opnd  => Lop,
5092                 Right_Opnd =>
5093                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
5094             Analyze_And_Resolve (N, Typ);
5095             return;
5096          end if;
5097
5098       --  Same processing for the operands the other way round
5099
5100       elsif Lp2 then
5101          Rewrite (N,
5102            Make_Op_Shift_Left (Loc,
5103              Left_Opnd  => Rop,
5104              Right_Opnd =>
5105                Convert_To (Standard_Natural, Right_Opnd (Lop))));
5106          Analyze_And_Resolve (N, Typ);
5107          return;
5108       end if;
5109
5110       --  Do required fixup of universal fixed operation
5111
5112       if Typ = Universal_Fixed then
5113          Fixup_Universal_Fixed_Operation (N);
5114          Typ := Etype (N);
5115       end if;
5116
5117       --  Multiplications with fixed-point results
5118
5119       if Is_Fixed_Point_Type (Typ) then
5120
5121          --  No special processing if Treat_Fixed_As_Integer is set,
5122          --  since from a semantic point of view such operations are
5123          --  simply integer operations and will be treated that way.
5124
5125          if not Treat_Fixed_As_Integer (N) then
5126
5127             --  Case of fixed * integer => fixed
5128
5129             if Is_Integer_Type (Rtyp) then
5130                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
5131
5132             --  Case of integer * fixed => fixed
5133
5134             elsif Is_Integer_Type (Ltyp) then
5135                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
5136
5137             --  Case of fixed * fixed => fixed
5138
5139             else
5140                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
5141             end if;
5142          end if;
5143
5144       --  Other cases of multiplication of fixed-point operands. Again
5145       --  we exclude the cases where Treat_Fixed_As_Integer flag is set.
5146
5147       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
5148         and then not Treat_Fixed_As_Integer (N)
5149       then
5150          if Is_Integer_Type (Typ) then
5151             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
5152          else
5153             pragma Assert (Is_Floating_Point_Type (Typ));
5154             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
5155          end if;
5156
5157       --  Mixed-mode operations can appear in a non-static universal
5158       --  context, in  which case the integer argument must be converted
5159       --  explicitly.
5160
5161       elsif Typ = Universal_Real
5162         and then Is_Integer_Type (Rtyp)
5163       then
5164          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
5165
5166          Analyze_And_Resolve (Rop, Universal_Real);
5167
5168       elsif Typ = Universal_Real
5169         and then Is_Integer_Type (Ltyp)
5170       then
5171          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
5172
5173          Analyze_And_Resolve (Lop, Universal_Real);
5174
5175       --  Non-fixed point cases, check software overflow checking required
5176
5177       elsif Is_Signed_Integer_Type (Etype (N)) then
5178          Apply_Arithmetic_Overflow_Check (N);
5179       end if;
5180    end Expand_N_Op_Multiply;
5181
5182    --------------------
5183    -- Expand_N_Op_Ne --
5184    --------------------
5185
5186    --  Rewrite node as the negation of an equality operation, and reanalyze.
5187    --  The equality to be used is defined in the same scope and has the same
5188    --  signature. It must be set explicitly because in an instance it may not
5189    --  have the same visibility as in the generic unit.
5190
5191    procedure Expand_N_Op_Ne (N : Node_Id) is
5192       Loc : constant Source_Ptr := Sloc (N);
5193       Neg : Node_Id;
5194       Ne  : constant Entity_Id := Entity (N);
5195
5196    begin
5197       Binary_Op_Validity_Checks (N);
5198
5199       Neg :=
5200         Make_Op_Not (Loc,
5201           Right_Opnd =>
5202             Make_Op_Eq (Loc,
5203               Left_Opnd =>  Left_Opnd (N),
5204               Right_Opnd => Right_Opnd (N)));
5205       Set_Paren_Count (Right_Opnd (Neg), 1);
5206
5207       if Scope (Ne) /= Standard_Standard then
5208          Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
5209       end if;
5210
5211       --  For navigation purposes, the inequality is treated as an implicit
5212       --  reference to the corresponding equality. Preserve the Comes_From_
5213       --  source flag so that the proper Xref entry is generated.
5214
5215       Preserve_Comes_From_Source (Neg, N);
5216       Preserve_Comes_From_Source (Right_Opnd (Neg), N);
5217       Rewrite (N, Neg);
5218       Analyze_And_Resolve (N, Standard_Boolean);
5219    end Expand_N_Op_Ne;
5220
5221    ---------------------
5222    -- Expand_N_Op_Not --
5223    ---------------------
5224
5225    --  If the argument is other than a Boolean array type, there is no
5226    --  special expansion required.
5227
5228    --  For the packed case, we call the special routine in Exp_Pakd, except
5229    --  that if the component size is greater than one, we use the standard
5230    --  routine generating a gruesome loop (it is so peculiar to have packed
5231    --  arrays with non-standard Boolean representations anyway, so it does
5232    --  not matter that we do not handle this case efficiently).
5233
5234    --  For the unpacked case (and for the special packed case where we have
5235    --  non standard Booleans, as discussed above), we generate and insert
5236    --  into the tree the following function definition:
5237
5238    --     function Nnnn (A : arr) is
5239    --       B : arr;
5240    --     begin
5241    --       for J in a'range loop
5242    --          B (J) := not A (J);
5243    --       end loop;
5244    --       return B;
5245    --     end Nnnn;
5246
5247    --  Here arr is the actual subtype of the parameter (and hence always
5248    --  constrained). Then we replace the not with a call to this function.
5249
5250    procedure Expand_N_Op_Not (N : Node_Id) is
5251       Loc  : constant Source_Ptr := Sloc (N);
5252       Typ  : constant Entity_Id  := Etype (N);
5253       Opnd : Node_Id;
5254       Arr  : Entity_Id;
5255       A    : Entity_Id;
5256       B    : Entity_Id;
5257       J    : Entity_Id;
5258       A_J  : Node_Id;
5259       B_J  : Node_Id;
5260
5261       Func_Name      : Entity_Id;
5262       Loop_Statement : Node_Id;
5263
5264    begin
5265       Unary_Op_Validity_Checks (N);
5266
5267       --  For boolean operand, deal with non-standard booleans
5268
5269       if Is_Boolean_Type (Typ) then
5270          Adjust_Condition (Right_Opnd (N));
5271          Set_Etype (N, Standard_Boolean);
5272          Adjust_Result_Type (N, Typ);
5273          return;
5274       end if;
5275
5276       --  Only array types need any other processing
5277
5278       if not Is_Array_Type (Typ) then
5279          return;
5280       end if;
5281
5282       --  Case of array operand. If bit packed, handle it in Exp_Pakd
5283
5284       if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
5285          Expand_Packed_Not (N);
5286          return;
5287       end if;
5288
5289       --  Case of array operand which is not bit-packed. If the context is
5290       --  a safe assignment, call in-place operation, If context is a larger
5291       --  boolean expression in the context of a safe assignment, expansion is
5292       --  done by enclosing operation.
5293
5294       Opnd := Relocate_Node (Right_Opnd (N));
5295       Convert_To_Actual_Subtype (Opnd);
5296       Arr := Etype (Opnd);
5297       Ensure_Defined (Arr, N);
5298
5299       if Nkind (Parent (N)) = N_Assignment_Statement then
5300          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
5301             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
5302             return;
5303
5304          --  Special case the negation of a binary operation
5305
5306          elsif (Nkind (Opnd) = N_Op_And
5307                  or else Nkind (Opnd) = N_Op_Or
5308                  or else Nkind (Opnd) = N_Op_Xor)
5309            and then Safe_In_Place_Array_Op
5310              (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
5311          then
5312             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
5313             return;
5314          end if;
5315
5316       elsif Nkind (Parent (N)) in N_Binary_Op
5317         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
5318       then
5319          declare
5320             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
5321             Op2 : constant Node_Id := Right_Opnd (Parent (N));
5322             Lhs : constant Node_Id := Name (Parent (Parent (N)));
5323
5324          begin
5325             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
5326                if N = Op1
5327                  and then Nkind (Op2) = N_Op_Not
5328                then
5329                   --  (not A) op (not B) can be reduced to a single call
5330
5331                   return;
5332
5333                elsif N = Op2
5334                  and then Nkind (Parent (N)) = N_Op_Xor
5335                then
5336                   --  A xor (not B) can also be special-cased
5337
5338                   return;
5339                end if;
5340             end if;
5341          end;
5342       end if;
5343
5344       A := Make_Defining_Identifier (Loc, Name_uA);
5345       B := Make_Defining_Identifier (Loc, Name_uB);
5346       J := Make_Defining_Identifier (Loc, Name_uJ);
5347
5348       A_J :=
5349         Make_Indexed_Component (Loc,
5350           Prefix      => New_Reference_To (A, Loc),
5351           Expressions => New_List (New_Reference_To (J, Loc)));
5352
5353       B_J :=
5354         Make_Indexed_Component (Loc,
5355           Prefix      => New_Reference_To (B, Loc),
5356           Expressions => New_List (New_Reference_To (J, Loc)));
5357
5358       Loop_Statement :=
5359         Make_Implicit_Loop_Statement (N,
5360           Identifier => Empty,
5361
5362           Iteration_Scheme =>
5363             Make_Iteration_Scheme (Loc,
5364               Loop_Parameter_Specification =>
5365                 Make_Loop_Parameter_Specification (Loc,
5366                   Defining_Identifier => J,
5367                   Discrete_Subtype_Definition =>
5368                     Make_Attribute_Reference (Loc,
5369                       Prefix => Make_Identifier (Loc, Chars (A)),
5370                       Attribute_Name => Name_Range))),
5371
5372           Statements => New_List (
5373             Make_Assignment_Statement (Loc,
5374               Name       => B_J,
5375               Expression => Make_Op_Not (Loc, A_J))));
5376
5377       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
5378       Set_Is_Inlined (Func_Name);
5379
5380       Insert_Action (N,
5381         Make_Subprogram_Body (Loc,
5382           Specification =>
5383             Make_Function_Specification (Loc,
5384               Defining_Unit_Name => Func_Name,
5385               Parameter_Specifications => New_List (
5386                 Make_Parameter_Specification (Loc,
5387                   Defining_Identifier => A,
5388                   Parameter_Type      => New_Reference_To (Typ, Loc))),
5389               Subtype_Mark => New_Reference_To (Typ, Loc)),
5390
5391           Declarations => New_List (
5392             Make_Object_Declaration (Loc,
5393               Defining_Identifier => B,
5394               Object_Definition   => New_Reference_To (Arr, Loc))),
5395
5396           Handled_Statement_Sequence =>
5397             Make_Handled_Sequence_Of_Statements (Loc,
5398               Statements => New_List (
5399                 Loop_Statement,
5400                 Make_Return_Statement (Loc,
5401                   Expression =>
5402                     Make_Identifier (Loc, Chars (B)))))));
5403
5404       Rewrite (N,
5405         Make_Function_Call (Loc,
5406           Name => New_Reference_To (Func_Name, Loc),
5407           Parameter_Associations => New_List (Opnd)));
5408
5409       Analyze_And_Resolve (N, Typ);
5410    end Expand_N_Op_Not;
5411
5412    --------------------
5413    -- Expand_N_Op_Or --
5414    --------------------
5415
5416    procedure Expand_N_Op_Or (N : Node_Id) is
5417       Typ : constant Entity_Id := Etype (N);
5418
5419    begin
5420       Binary_Op_Validity_Checks (N);
5421
5422       if Is_Array_Type (Etype (N)) then
5423          Expand_Boolean_Operator (N);
5424
5425       elsif Is_Boolean_Type (Etype (N)) then
5426          Adjust_Condition (Left_Opnd (N));
5427          Adjust_Condition (Right_Opnd (N));
5428          Set_Etype (N, Standard_Boolean);
5429          Adjust_Result_Type (N, Typ);
5430       end if;
5431    end Expand_N_Op_Or;
5432
5433    ----------------------
5434    -- Expand_N_Op_Plus --
5435    ----------------------
5436
5437    procedure Expand_N_Op_Plus (N : Node_Id) is
5438    begin
5439       Unary_Op_Validity_Checks (N);
5440    end Expand_N_Op_Plus;
5441
5442    ---------------------
5443    -- Expand_N_Op_Rem --
5444    ---------------------
5445
5446    procedure Expand_N_Op_Rem (N : Node_Id) is
5447       Loc : constant Source_Ptr := Sloc (N);
5448       Typ : constant Entity_Id  := Etype (N);
5449
5450       Left  : constant Node_Id := Left_Opnd (N);
5451       Right : constant Node_Id := Right_Opnd (N);
5452
5453       LLB : Uint;
5454       Llo : Uint;
5455       Lhi : Uint;
5456       LOK : Boolean;
5457       Rlo : Uint;
5458       Rhi : Uint;
5459       ROK : Boolean;
5460
5461    begin
5462       Binary_Op_Validity_Checks (N);
5463
5464       if Is_Integer_Type (Etype (N)) then
5465          Apply_Divide_Check (N);
5466       end if;
5467
5468       --  Apply optimization x rem 1 = 0. We don't really need that with
5469       --  gcc, but it is useful with other back ends (e.g. AAMP), and is
5470       --  certainly harmless.
5471
5472       if Is_Integer_Type (Etype (N))
5473         and then Compile_Time_Known_Value (Right)
5474         and then Expr_Value (Right) = Uint_1
5475       then
5476          Rewrite (N, Make_Integer_Literal (Loc, 0));
5477          Analyze_And_Resolve (N, Typ);
5478          return;
5479       end if;
5480
5481       --  Deal with annoying case of largest negative number remainder
5482       --  minus one. Gigi does not handle this case correctly, because
5483       --  it generates a divide instruction which may trap in this case.
5484
5485       --  In fact the check is quite easy, if the right operand is -1,
5486       --  then the remainder is always 0, and we can just ignore the
5487       --  left operand completely in this case.
5488
5489       Determine_Range (Right, ROK, Rlo, Rhi);
5490       Determine_Range (Left, LOK, Llo, Lhi);
5491
5492       --  The operand type may be private (e.g. in the expansion of an
5493       --  an intrinsic operation) so we must use the underlying type to
5494       --  get the bounds, and convert the literals explicitly.
5495
5496       LLB :=
5497         Expr_Value
5498           (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
5499
5500       --  Now perform the test, generating code only if needed
5501
5502       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
5503         and then
5504          ((not LOK) or else (Llo = LLB))
5505       then
5506          Rewrite (N,
5507            Make_Conditional_Expression (Loc,
5508              Expressions => New_List (
5509                Make_Op_Eq (Loc,
5510                  Left_Opnd => Duplicate_Subexpr (Right),
5511                  Right_Opnd =>
5512                    Unchecked_Convert_To (Typ,
5513                      Make_Integer_Literal (Loc, -1))),
5514
5515                Unchecked_Convert_To (Typ,
5516                  Make_Integer_Literal (Loc, Uint_0)),
5517
5518                Relocate_Node (N))));
5519
5520          Set_Analyzed (Next (Next (First (Expressions (N)))));
5521          Analyze_And_Resolve (N, Typ);
5522       end if;
5523    end Expand_N_Op_Rem;
5524
5525    -----------------------------
5526    -- Expand_N_Op_Rotate_Left --
5527    -----------------------------
5528
5529    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
5530    begin
5531       Binary_Op_Validity_Checks (N);
5532    end Expand_N_Op_Rotate_Left;
5533
5534    ------------------------------
5535    -- Expand_N_Op_Rotate_Right --
5536    ------------------------------
5537
5538    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
5539    begin
5540       Binary_Op_Validity_Checks (N);
5541    end Expand_N_Op_Rotate_Right;
5542
5543    ----------------------------
5544    -- Expand_N_Op_Shift_Left --
5545    ----------------------------
5546
5547    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
5548    begin
5549       Binary_Op_Validity_Checks (N);
5550    end Expand_N_Op_Shift_Left;
5551
5552    -----------------------------
5553    -- Expand_N_Op_Shift_Right --
5554    -----------------------------
5555
5556    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
5557    begin
5558       Binary_Op_Validity_Checks (N);
5559    end Expand_N_Op_Shift_Right;
5560
5561    ----------------------------------------
5562    -- Expand_N_Op_Shift_Right_Arithmetic --
5563    ----------------------------------------
5564
5565    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
5566    begin
5567       Binary_Op_Validity_Checks (N);
5568    end Expand_N_Op_Shift_Right_Arithmetic;
5569
5570    --------------------------
5571    -- Expand_N_Op_Subtract --
5572    --------------------------
5573
5574    procedure Expand_N_Op_Subtract (N : Node_Id) is
5575       Typ : constant Entity_Id := Etype (N);
5576
5577    begin
5578       Binary_Op_Validity_Checks (N);
5579
5580       --  N - 0 = N for integer types
5581
5582       if Is_Integer_Type (Typ)
5583         and then Compile_Time_Known_Value (Right_Opnd (N))
5584         and then Expr_Value (Right_Opnd (N)) = 0
5585       then
5586          Rewrite (N, Left_Opnd (N));
5587          return;
5588       end if;
5589
5590       --  Arithemtic overflow checks for signed integer/fixed point types
5591
5592       if Is_Signed_Integer_Type (Typ)
5593         or else Is_Fixed_Point_Type (Typ)
5594       then
5595          Apply_Arithmetic_Overflow_Check (N);
5596
5597       --  Vax floating-point types case
5598
5599       elsif Vax_Float (Typ) then
5600          Expand_Vax_Arith (N);
5601       end if;
5602    end Expand_N_Op_Subtract;
5603
5604    ---------------------
5605    -- Expand_N_Op_Xor --
5606    ---------------------
5607
5608    procedure Expand_N_Op_Xor (N : Node_Id) is
5609       Typ : constant Entity_Id := Etype (N);
5610
5611    begin
5612       Binary_Op_Validity_Checks (N);
5613
5614       if Is_Array_Type (Etype (N)) then
5615          Expand_Boolean_Operator (N);
5616
5617       elsif Is_Boolean_Type (Etype (N)) then
5618          Adjust_Condition (Left_Opnd (N));
5619          Adjust_Condition (Right_Opnd (N));
5620          Set_Etype (N, Standard_Boolean);
5621          Adjust_Result_Type (N, Typ);
5622       end if;
5623    end Expand_N_Op_Xor;
5624
5625    ----------------------
5626    -- Expand_N_Or_Else --
5627    ----------------------
5628
5629    --  Expand into conditional expression if Actions present, and also
5630    --  deal with optimizing case of arguments being True or False.
5631
5632    procedure Expand_N_Or_Else (N : Node_Id) is
5633       Loc     : constant Source_Ptr := Sloc (N);
5634       Typ     : constant Entity_Id  := Etype (N);
5635       Left    : constant Node_Id    := Left_Opnd (N);
5636       Right   : constant Node_Id    := Right_Opnd (N);
5637       Actlist : List_Id;
5638
5639    begin
5640       --  Deal with non-standard booleans
5641
5642       if Is_Boolean_Type (Typ) then
5643          Adjust_Condition (Left);
5644          Adjust_Condition (Right);
5645          Set_Etype (N, Standard_Boolean);
5646       end if;
5647
5648       --  Check for cases of left argument is True or False
5649
5650       if Nkind (Left) = N_Identifier then
5651
5652          --  If left argument is False, change (False or else Right) to Right.
5653          --  Any actions associated with Right will be executed unconditionally
5654          --  and can thus be inserted into the tree unconditionally.
5655
5656          if Entity (Left) = Standard_False then
5657             if Present (Actions (N)) then
5658                Insert_Actions (N, Actions (N));
5659             end if;
5660
5661             Rewrite (N, Right);
5662             Adjust_Result_Type (N, Typ);
5663             return;
5664
5665          --  If left argument is True, change (True and then Right) to
5666          --  True. In this case we can forget the actions associated with
5667          --  Right, since they will never be executed.
5668
5669          elsif Entity (Left) = Standard_True then
5670             Kill_Dead_Code (Right);
5671             Kill_Dead_Code (Actions (N));
5672             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5673             Adjust_Result_Type (N, Typ);
5674             return;
5675          end if;
5676       end if;
5677
5678       --  If Actions are present, we expand
5679
5680       --     left or else right
5681
5682       --  into
5683
5684       --     if left then True else right end
5685
5686       --  with the actions becoming the Else_Actions of the conditional
5687       --  expression. This conditional expression is then further expanded
5688       --  (and will eventually disappear)
5689
5690       if Present (Actions (N)) then
5691          Actlist := Actions (N);
5692          Rewrite (N,
5693             Make_Conditional_Expression (Loc,
5694               Expressions => New_List (
5695                 Left,
5696                 New_Occurrence_Of (Standard_True, Loc),
5697                 Right)));
5698
5699          Set_Else_Actions (N, Actlist);
5700          Analyze_And_Resolve (N, Standard_Boolean);
5701          Adjust_Result_Type (N, Typ);
5702          return;
5703       end if;
5704
5705       --  No actions present, check for cases of right argument True/False
5706
5707       if Nkind (Right) = N_Identifier then
5708
5709          --  Change (Left or else False) to Left. Note that we know there
5710          --  are no actions associated with the True operand, since we
5711          --  just checked for this case above.
5712
5713          if Entity (Right) = Standard_False then
5714             Rewrite (N, Left);
5715
5716          --  Change (Left or else True) to True, making sure to preserve
5717          --  any side effects associated with the Left operand.
5718
5719          elsif Entity (Right) = Standard_True then
5720             Remove_Side_Effects (Left);
5721             Rewrite
5722               (N, New_Occurrence_Of (Standard_True, Loc));
5723          end if;
5724       end if;
5725
5726       Adjust_Result_Type (N, Typ);
5727    end Expand_N_Or_Else;
5728
5729    -----------------------------------
5730    -- Expand_N_Qualified_Expression --
5731    -----------------------------------
5732
5733    procedure Expand_N_Qualified_Expression (N : Node_Id) is
5734       Operand     : constant Node_Id   := Expression (N);
5735       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
5736
5737    begin
5738       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
5739    end Expand_N_Qualified_Expression;
5740
5741    ---------------------------------
5742    -- Expand_N_Selected_Component --
5743    ---------------------------------
5744
5745    --  If the selector is a discriminant of a concurrent object, rewrite the
5746    --  prefix to denote the corresponding record type.
5747
5748    procedure Expand_N_Selected_Component (N : Node_Id) is
5749       Loc   : constant Source_Ptr := Sloc (N);
5750       Par   : constant Node_Id    := Parent (N);
5751       P     : constant Node_Id    := Prefix (N);
5752       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
5753       Disc  : Entity_Id;
5754       New_N : Node_Id;
5755       Dcon  : Elmt_Id;
5756
5757       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
5758       --  Gigi needs a temporary for prefixes that depend on a discriminant,
5759       --  unless the context of an assignment can provide size information.
5760       --  Don't we have a general routine that does this???
5761
5762       -----------------------
5763       -- In_Left_Hand_Side --
5764       -----------------------
5765
5766       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
5767       begin
5768          return (Nkind (Parent (Comp)) = N_Assignment_Statement
5769                    and then Comp = Name (Parent (Comp)))
5770            or else (Present (Parent (Comp))
5771                       and then Nkind (Parent (Comp)) in N_Subexpr
5772                       and then In_Left_Hand_Side (Parent (Comp)));
5773       end In_Left_Hand_Side;
5774
5775    --  Start of processing for Expand_N_Selected_Component
5776
5777    begin
5778       --  Insert explicit dereference if required
5779
5780       if Is_Access_Type (Ptyp) then
5781          Insert_Explicit_Dereference (P);
5782          Analyze_And_Resolve (P, Designated_Type (Ptyp));
5783
5784          if Ekind (Etype (P)) = E_Private_Subtype
5785            and then Is_For_Access_Subtype (Etype (P))
5786          then
5787             Set_Etype (P, Base_Type (Etype (P)));
5788          end if;
5789
5790          Ptyp := Etype (P);
5791       end if;
5792
5793       --  Deal with discriminant check required
5794
5795       if Do_Discriminant_Check (N) then
5796
5797          --  Present the discrminant checking function to the backend,
5798          --  so that it can inline the call to the function.
5799
5800          Add_Inlined_Body
5801            (Discriminant_Checking_Func
5802              (Original_Record_Component (Entity (Selector_Name (N)))));
5803
5804          --  Now reset the flag and generate the call
5805
5806          Set_Do_Discriminant_Check (N, False);
5807          Generate_Discriminant_Check (N);
5808       end if;
5809
5810       --  Gigi cannot handle unchecked conversions that are the prefix of a
5811       --  selected component with discriminants. This must be checked during
5812       --  expansion, because during analysis the type of the selector is not
5813       --  known at the point the prefix is analyzed. If the conversion is the
5814       --  target of an assignment, then we cannot force the evaluation.
5815
5816       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
5817         and then Has_Discriminants (Etype (N))
5818         and then not In_Left_Hand_Side (N)
5819       then
5820          Force_Evaluation (Prefix (N));
5821       end if;
5822
5823       --  Remaining processing applies only if selector is a discriminant
5824
5825       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
5826
5827          --  If the selector is a discriminant of a constrained record type,
5828          --  we may be able to rewrite the expression with the actual value
5829          --  of the discriminant, a useful optimization in some cases.
5830
5831          if Is_Record_Type (Ptyp)
5832            and then Has_Discriminants (Ptyp)
5833            and then Is_Constrained (Ptyp)
5834          then
5835             --  Do this optimization for discrete types only, and not for
5836             --  access types (access discriminants get us into trouble!)
5837
5838             if not Is_Discrete_Type (Etype (N)) then
5839                null;
5840
5841             --  Don't do this on the left hand of an assignment statement.
5842             --  Normally one would think that references like this would
5843             --  not occur, but they do in generated code, and mean that
5844             --  we really do want to assign the discriminant!
5845
5846             elsif Nkind (Par) = N_Assignment_Statement
5847               and then Name (Par) = N
5848             then
5849                null;
5850
5851             --  Don't do this optimization for the prefix of an attribute
5852             --  or the operand of an object renaming declaration since these
5853             --  are contexts where we do not want the value anyway.
5854
5855             elsif (Nkind (Par) = N_Attribute_Reference
5856                      and then Prefix (Par) = N)
5857               or else Is_Renamed_Object (N)
5858             then
5859                null;
5860
5861             --  Don't do this optimization if we are within the code for a
5862             --  discriminant check, since the whole point of such a check may
5863             --  be to verify the condition on which the code below depends!
5864
5865             elsif Is_In_Discriminant_Check (N) then
5866                null;
5867
5868             --  Green light to see if we can do the optimization. There is
5869             --  still one condition that inhibits the optimization below
5870             --  but now is the time to check the particular discriminant.
5871
5872             else
5873                --  Loop through discriminants to find the matching
5874                --  discriminant constraint to see if we can copy it.
5875
5876                Disc := First_Discriminant (Ptyp);
5877                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
5878                Discr_Loop : while Present (Dcon) loop
5879
5880                   --  Check if this is the matching discriminant
5881
5882                   if Disc = Entity (Selector_Name (N)) then
5883
5884                      --  Here we have the matching discriminant. Check for
5885                      --  the case of a discriminant of a component that is
5886                      --  constrained by an outer discriminant, which cannot
5887                      --  be optimized away.
5888
5889                      if
5890                        Denotes_Discriminant
5891                         (Node (Dcon), Check_Protected => True)
5892                      then
5893                         exit Discr_Loop;
5894
5895                      --  In the context of a case statement, the expression
5896                      --  may have the base type of the discriminant, and we
5897                      --  need to preserve the constraint to avoid spurious
5898                      --  errors on missing cases.
5899
5900                      elsif Nkind (Parent (N)) = N_Case_Statement
5901                        and then Etype (Node (Dcon)) /= Etype (Disc)
5902                      then
5903                         Rewrite (N,
5904                           Make_Qualified_Expression (Loc,
5905                             Subtype_Mark =>
5906                               New_Occurrence_Of (Etype (Disc), Loc),
5907                             Expression   =>
5908                               New_Copy_Tree (Node (Dcon))));
5909                         Analyze_And_Resolve (N, Etype (Disc));
5910
5911                         --  In case that comes out as a static expression,
5912                         --  reset it (a selected component is never static).
5913
5914                         Set_Is_Static_Expression (N, False);
5915                         return;
5916
5917                      --  Otherwise we can just copy the constraint, but the
5918                      --  result is certainly not static! In some cases the
5919                      --  discriminant constraint has been analyzed in the
5920                      --  context of the original subtype indication, but for
5921                      --  itypes the constraint might not have been analyzed
5922                      --  yet, and this must be done now.
5923
5924                      else
5925                         Rewrite (N, New_Copy_Tree (Node (Dcon)));
5926                         Analyze_And_Resolve (N);
5927                         Set_Is_Static_Expression (N, False);
5928                         return;
5929                      end if;
5930                   end if;
5931
5932                   Next_Elmt (Dcon);
5933                   Next_Discriminant (Disc);
5934                end loop Discr_Loop;
5935
5936                --  Note: the above loop should always find a matching
5937                --  discriminant, but if it does not, we just missed an
5938                --  optimization due to some glitch (perhaps a previous
5939                --  error), so ignore.
5940
5941             end if;
5942          end if;
5943
5944          --  The only remaining processing is in the case of a discriminant of
5945          --  a concurrent object, where we rewrite the prefix to denote the
5946          --  corresponding record type. If the type is derived and has renamed
5947          --  discriminants, use corresponding discriminant, which is the one
5948          --  that appears in the corresponding record.
5949
5950          if not Is_Concurrent_Type (Ptyp) then
5951             return;
5952          end if;
5953
5954          Disc := Entity (Selector_Name (N));
5955
5956          if Is_Derived_Type (Ptyp)
5957            and then Present (Corresponding_Discriminant (Disc))
5958          then
5959             Disc := Corresponding_Discriminant (Disc);
5960          end if;
5961
5962          New_N :=
5963            Make_Selected_Component (Loc,
5964              Prefix =>
5965                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
5966                  New_Copy_Tree (P)),
5967              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
5968
5969          Rewrite (N, New_N);
5970          Analyze (N);
5971       end if;
5972    end Expand_N_Selected_Component;
5973
5974    --------------------
5975    -- Expand_N_Slice --
5976    --------------------
5977
5978    procedure Expand_N_Slice (N : Node_Id) is
5979       Loc  : constant Source_Ptr := Sloc (N);
5980       Typ  : constant Entity_Id  := Etype (N);
5981       Pfx  : constant Node_Id    := Prefix (N);
5982       Ptp  : Entity_Id           := Etype (Pfx);
5983
5984       function Is_Procedure_Actual (N : Node_Id) return Boolean;
5985       --  Check whether the argument is an actual for a procedure call,
5986       --  in which case the expansion of a bit-packed slice is deferred
5987       --  until the call itself is expanded. The reason this is required
5988       --  is that we might have an IN OUT or OUT parameter, and the copy out
5989       --  is essential, and that copy out would be missed if we created a
5990       --  temporary here in Expand_N_Slice. Note that we don't bother
5991       --  to test specifically for an IN OUT or OUT mode parameter, since it
5992       --  is a bit tricky to do, and it is harmless to defer expansion
5993       --  in the IN case, since the call processing will still generate the
5994       --  appropriate copy in operation, which will take care of the slice.
5995
5996       procedure Make_Temporary;
5997       --  Create a named variable for the value of the slice, in
5998       --  cases where the back-end cannot handle it properly, e.g.
5999       --  when packed types or unaligned slices are involved.
6000
6001       -------------------------
6002       -- Is_Procedure_Actual --
6003       -------------------------
6004
6005       function Is_Procedure_Actual (N : Node_Id) return Boolean is
6006          Par : Node_Id := Parent (N);
6007
6008       begin
6009          loop
6010             --  If our parent is a procedure call we can return
6011
6012             if Nkind (Par) = N_Procedure_Call_Statement then
6013                return True;
6014
6015             --  If our parent is a type conversion, keep climbing the
6016             --  tree, since a type conversion can be a procedure actual.
6017             --  Also keep climbing if parameter association or a qualified
6018             --  expression, since these are additional cases that do can
6019             --  appear on procedure actuals.
6020
6021             elsif Nkind (Par) = N_Type_Conversion
6022               or else Nkind (Par) = N_Parameter_Association
6023               or else Nkind (Par) = N_Qualified_Expression
6024             then
6025                Par := Parent (Par);
6026
6027                --  Any other case is not what we are looking for
6028
6029             else
6030                return False;
6031             end if;
6032          end loop;
6033       end Is_Procedure_Actual;
6034
6035       --------------------
6036       -- Make_Temporary --
6037       --------------------
6038
6039       procedure Make_Temporary is
6040          Decl : Node_Id;
6041          Ent  : constant Entity_Id :=
6042                   Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
6043       begin
6044          Decl :=
6045            Make_Object_Declaration (Loc,
6046              Defining_Identifier => Ent,
6047              Object_Definition   => New_Occurrence_Of (Typ, Loc));
6048
6049          Set_No_Initialization (Decl);
6050
6051          Insert_Actions (N, New_List (
6052            Decl,
6053            Make_Assignment_Statement (Loc,
6054              Name => New_Occurrence_Of (Ent, Loc),
6055              Expression => Relocate_Node (N))));
6056
6057          Rewrite (N, New_Occurrence_Of (Ent, Loc));
6058          Analyze_And_Resolve (N, Typ);
6059       end Make_Temporary;
6060
6061    --  Start of processing for Expand_N_Slice
6062
6063    begin
6064       --  Special handling for access types
6065
6066       if Is_Access_Type (Ptp) then
6067
6068          Ptp := Designated_Type (Ptp);
6069
6070          Rewrite (Pfx,
6071            Make_Explicit_Dereference (Sloc (N),
6072             Prefix => Relocate_Node (Pfx)));
6073
6074          Analyze_And_Resolve (Pfx, Ptp);
6075       end if;
6076
6077       --  Range checks are potentially also needed for cases involving
6078       --  a slice indexed by a subtype indication, but Do_Range_Check
6079       --  can currently only be set for expressions ???
6080
6081       if not Index_Checks_Suppressed (Ptp)
6082         and then (not Is_Entity_Name (Pfx)
6083                    or else not Index_Checks_Suppressed (Entity (Pfx)))
6084         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
6085       then
6086          Enable_Range_Check (Discrete_Range (N));
6087       end if;
6088
6089       --  The remaining case to be handled is packed slices. We can leave
6090       --  packed slices as they are in the following situations:
6091
6092       --    1. Right or left side of an assignment (we can handle this
6093       --       situation correctly in the assignment statement expansion).
6094
6095       --    2. Prefix of indexed component (the slide is optimized away
6096       --       in this case, see the start of Expand_N_Slice.
6097
6098       --    3. Object renaming declaration, since we want the name of
6099       --       the slice, not the value.
6100
6101       --    4. Argument to procedure call, since copy-in/copy-out handling
6102       --       may be required, and this is handled in the expansion of
6103       --       call itself.
6104
6105       --    5. Prefix of an address attribute (this is an error which
6106       --       is caught elsewhere, and the expansion would intefere
6107       --       with generating the error message).
6108
6109       if not Is_Packed (Typ) then
6110
6111          --  Apply transformation for actuals of a function call,
6112          --  where Expand_Actuals is not used.
6113
6114          if Nkind (Parent (N)) = N_Function_Call
6115            and then Is_Possibly_Unaligned_Slice (N)
6116          then
6117             Make_Temporary;
6118          end if;
6119
6120       elsif Nkind (Parent (N)) = N_Assignment_Statement
6121         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
6122                    and then Parent (N) = Name (Parent (Parent (N))))
6123       then
6124          return;
6125
6126       elsif Nkind (Parent (N)) = N_Indexed_Component
6127         or else Is_Renamed_Object (N)
6128         or else Is_Procedure_Actual (N)
6129       then
6130          return;
6131
6132       elsif Nkind (Parent (N)) = N_Attribute_Reference
6133         and then Attribute_Name (Parent (N)) = Name_Address
6134       then
6135          return;
6136
6137       else
6138          Make_Temporary;
6139       end if;
6140    end Expand_N_Slice;
6141
6142    ------------------------------
6143    -- Expand_N_Type_Conversion --
6144    ------------------------------
6145
6146    procedure Expand_N_Type_Conversion (N : Node_Id) is
6147       Loc          : constant Source_Ptr := Sloc (N);
6148       Operand      : constant Node_Id    := Expression (N);
6149       Target_Type  : constant Entity_Id  := Etype (N);
6150       Operand_Type : Entity_Id           := Etype (Operand);
6151
6152       procedure Handle_Changed_Representation;
6153       --  This is called in the case of record and array type conversions
6154       --  to see if there is a change of representation to be handled.
6155       --  Change of representation is actually handled at the assignment
6156       --  statement level, and what this procedure does is rewrite node N
6157       --  conversion as an assignment to temporary. If there is no change
6158       --  of representation, then the conversion node is unchanged.
6159
6160       procedure Real_Range_Check;
6161       --  Handles generation of range check for real target value
6162
6163       -----------------------------------
6164       -- Handle_Changed_Representation --
6165       -----------------------------------
6166
6167       procedure Handle_Changed_Representation is
6168          Temp : Entity_Id;
6169          Decl : Node_Id;
6170          Odef : Node_Id;
6171          Disc : Node_Id;
6172          N_Ix : Node_Id;
6173          Cons : List_Id;
6174
6175       begin
6176          --  Nothing to do if no change of representation
6177
6178          if Same_Representation (Operand_Type, Target_Type) then
6179             return;
6180
6181          --  The real change of representation work is done by the assignment
6182          --  statement processing. So if this type conversion is appearing as
6183          --  the expression of an assignment statement, nothing needs to be
6184          --  done to the conversion.
6185
6186          elsif Nkind (Parent (N)) = N_Assignment_Statement then
6187             return;
6188
6189          --  Otherwise we need to generate a temporary variable, and do the
6190          --  change of representation assignment into that temporary variable.
6191          --  The conversion is then replaced by a reference to this variable.
6192
6193          else
6194             Cons := No_List;
6195
6196             --  If type is unconstrained we have to add a constraint,
6197             --  copied from the actual value of the left hand side.
6198
6199             if not Is_Constrained (Target_Type) then
6200                if Has_Discriminants (Operand_Type) then
6201                   Disc := First_Discriminant (Operand_Type);
6202
6203                   if Disc /= First_Stored_Discriminant (Operand_Type) then
6204                      Disc := First_Stored_Discriminant (Operand_Type);
6205                   end if;
6206
6207                   Cons := New_List;
6208                   while Present (Disc) loop
6209                      Append_To (Cons,
6210                        Make_Selected_Component (Loc,
6211                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
6212                          Selector_Name =>
6213                            Make_Identifier (Loc, Chars (Disc))));
6214                      Next_Discriminant (Disc);
6215                   end loop;
6216
6217                elsif Is_Array_Type (Operand_Type) then
6218                   N_Ix := First_Index (Target_Type);
6219                   Cons := New_List;
6220
6221                   for J in 1 .. Number_Dimensions (Operand_Type) loop
6222
6223                      --  We convert the bounds explicitly. We use an unchecked
6224                      --  conversion because bounds checks are done elsewhere.
6225
6226                      Append_To (Cons,
6227                        Make_Range (Loc,
6228                          Low_Bound =>
6229                            Unchecked_Convert_To (Etype (N_Ix),
6230                              Make_Attribute_Reference (Loc,
6231                                Prefix =>
6232                                  Duplicate_Subexpr_No_Checks
6233                                    (Operand, Name_Req => True),
6234                                Attribute_Name => Name_First,
6235                                Expressions    => New_List (
6236                                  Make_Integer_Literal (Loc, J)))),
6237
6238                          High_Bound =>
6239                            Unchecked_Convert_To (Etype (N_Ix),
6240                              Make_Attribute_Reference (Loc,
6241                                Prefix =>
6242                                  Duplicate_Subexpr_No_Checks
6243                                    (Operand, Name_Req => True),
6244                                Attribute_Name => Name_Last,
6245                                Expressions    => New_List (
6246                                  Make_Integer_Literal (Loc, J))))));
6247
6248                      Next_Index (N_Ix);
6249                   end loop;
6250                end if;
6251             end if;
6252
6253             Odef := New_Occurrence_Of (Target_Type, Loc);
6254
6255             if Present (Cons) then
6256                Odef :=
6257                  Make_Subtype_Indication (Loc,
6258                    Subtype_Mark => Odef,
6259                    Constraint =>
6260                      Make_Index_Or_Discriminant_Constraint (Loc,
6261                        Constraints => Cons));
6262             end if;
6263
6264             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
6265             Decl :=
6266               Make_Object_Declaration (Loc,
6267                 Defining_Identifier => Temp,
6268                 Object_Definition   => Odef);
6269
6270             Set_No_Initialization (Decl, True);
6271
6272             --  Insert required actions. It is essential to suppress checks
6273             --  since we have suppressed default initialization, which means
6274             --  that the variable we create may have no discriminants.
6275
6276             Insert_Actions (N,
6277               New_List (
6278                 Decl,
6279                 Make_Assignment_Statement (Loc,
6280                   Name => New_Occurrence_Of (Temp, Loc),
6281                   Expression => Relocate_Node (N))),
6282                 Suppress => All_Checks);
6283
6284             Rewrite (N, New_Occurrence_Of (Temp, Loc));
6285             return;
6286          end if;
6287       end Handle_Changed_Representation;
6288
6289       ----------------------
6290       -- Real_Range_Check --
6291       ----------------------
6292
6293       --  Case of conversions to floating-point or fixed-point. If range
6294       --  checks are enabled and the target type has a range constraint,
6295       --  we convert:
6296
6297       --     typ (x)
6298
6299       --       to
6300
6301       --     Tnn : typ'Base := typ'Base (x);
6302       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
6303       --     Tnn
6304
6305       --  This is necessary when there is a conversion of integer to float
6306       --  or to fixed-point to ensure that the correct checks are made. It
6307       --  is not necessary for float to float where it is enough to simply
6308       --  set the Do_Range_Check flag.
6309
6310       procedure Real_Range_Check is
6311          Btyp : constant Entity_Id := Base_Type (Target_Type);
6312          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
6313          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
6314          Xtyp : constant Entity_Id := Etype (Operand);
6315          Conv : Node_Id;
6316          Tnn  : Entity_Id;
6317
6318       begin
6319          --  Nothing to do if conversion was rewritten
6320
6321          if Nkind (N) /= N_Type_Conversion then
6322             return;
6323          end if;
6324
6325          --  Nothing to do if range checks suppressed, or target has the
6326          --  same range as the base type (or is the base type).
6327
6328          if Range_Checks_Suppressed (Target_Type)
6329            or else (Lo = Type_Low_Bound (Btyp)
6330                       and then
6331                     Hi = Type_High_Bound (Btyp))
6332          then
6333             return;
6334          end if;
6335
6336          --  Nothing to do if expression is an entity on which checks
6337          --  have been suppressed.
6338
6339          if Is_Entity_Name (Operand)
6340            and then Range_Checks_Suppressed (Entity (Operand))
6341          then
6342             return;
6343          end if;
6344
6345          --  Nothing to do if bounds are all static and we can tell that
6346          --  the expression is within the bounds of the target. Note that
6347          --  if the operand is of an unconstrained floating-point type,
6348          --  then we do not trust it to be in range (might be infinite)
6349
6350          declare
6351             S_Lo : constant Node_Id   := Type_Low_Bound (Xtyp);
6352             S_Hi : constant Node_Id   := Type_High_Bound (Xtyp);
6353
6354          begin
6355             if (not Is_Floating_Point_Type (Xtyp)
6356                  or else Is_Constrained (Xtyp))
6357               and then Compile_Time_Known_Value (S_Lo)
6358               and then Compile_Time_Known_Value (S_Hi)
6359               and then Compile_Time_Known_Value (Hi)
6360               and then Compile_Time_Known_Value (Lo)
6361             then
6362                declare
6363                   D_Lov : constant Ureal := Expr_Value_R (Lo);
6364                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
6365                   S_Lov : Ureal;
6366                   S_Hiv : Ureal;
6367
6368                begin
6369                   if Is_Real_Type (Xtyp) then
6370                      S_Lov := Expr_Value_R (S_Lo);
6371                      S_Hiv := Expr_Value_R (S_Hi);
6372                   else
6373                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
6374                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
6375                   end if;
6376
6377                   if D_Hiv > D_Lov
6378                     and then S_Lov >= D_Lov
6379                     and then S_Hiv <= D_Hiv
6380                   then
6381                      Set_Do_Range_Check (Operand, False);
6382                      return;
6383                   end if;
6384                end;
6385             end if;
6386          end;
6387
6388          --  For float to float conversions, we are done
6389
6390          if Is_Floating_Point_Type (Xtyp)
6391               and then
6392             Is_Floating_Point_Type (Btyp)
6393          then
6394             return;
6395          end if;
6396
6397          --  Otherwise rewrite the conversion as described above
6398
6399          Conv := Relocate_Node (N);
6400          Rewrite
6401            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
6402          Set_Etype (Conv, Btyp);
6403
6404          --  Enable overflow except in the case of integer to float
6405          --  conversions, where it is never required, since we can
6406          --  never have overflow in this case.
6407
6408          if not Is_Integer_Type (Etype (Operand)) then
6409             Enable_Overflow_Check (Conv);
6410          end if;
6411
6412          Tnn :=
6413            Make_Defining_Identifier (Loc,
6414              Chars => New_Internal_Name ('T'));
6415
6416          Insert_Actions (N, New_List (
6417            Make_Object_Declaration (Loc,
6418              Defining_Identifier => Tnn,
6419              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
6420              Expression => Conv),
6421
6422            Make_Raise_Constraint_Error (Loc,
6423              Condition =>
6424               Make_Or_Else (Loc,
6425                 Left_Opnd =>
6426                   Make_Op_Lt (Loc,
6427                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
6428                     Right_Opnd =>
6429                       Make_Attribute_Reference (Loc,
6430                         Attribute_Name => Name_First,
6431                         Prefix =>
6432                           New_Occurrence_Of (Target_Type, Loc))),
6433
6434                 Right_Opnd =>
6435                   Make_Op_Gt (Loc,
6436                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
6437                     Right_Opnd =>
6438                       Make_Attribute_Reference (Loc,
6439                         Attribute_Name => Name_Last,
6440                         Prefix =>
6441                           New_Occurrence_Of (Target_Type, Loc)))),
6442              Reason => CE_Range_Check_Failed)));
6443
6444          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
6445          Analyze_And_Resolve (N, Btyp);
6446       end Real_Range_Check;
6447
6448    --  Start of processing for Expand_N_Type_Conversion
6449
6450    begin
6451       --  Nothing at all to do if conversion is to the identical type
6452       --  so remove the conversion completely, it is useless.
6453
6454       if Operand_Type = Target_Type then
6455          Rewrite (N, Relocate_Node (Operand));
6456          return;
6457       end if;
6458
6459       --  Deal with Vax floating-point cases
6460
6461       if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
6462          Expand_Vax_Conversion (N);
6463          return;
6464       end if;
6465
6466       --  Nothing to do if this is the second argument of read. This
6467       --  is a "backwards" conversion that will be handled by the
6468       --  specialized code in attribute processing.
6469
6470       if Nkind (Parent (N)) = N_Attribute_Reference
6471         and then Attribute_Name (Parent (N)) = Name_Read
6472         and then Next (First (Expressions (Parent (N)))) = N
6473       then
6474          return;
6475       end if;
6476
6477       --  Here if we may need to expand conversion
6478
6479       --  Special case of converting from non-standard boolean type
6480
6481       if Is_Boolean_Type (Operand_Type)
6482         and then (Nonzero_Is_True (Operand_Type))
6483       then
6484          Adjust_Condition (Operand);
6485          Set_Etype (Operand, Standard_Boolean);
6486          Operand_Type := Standard_Boolean;
6487       end if;
6488
6489       --  Case of converting to an access type
6490
6491       if Is_Access_Type (Target_Type) then
6492
6493          --  Apply an accessibility check if the operand is an
6494          --  access parameter. Note that other checks may still
6495          --  need to be applied below (such as tagged type checks).
6496
6497          if Is_Entity_Name (Operand)
6498            and then Ekind (Entity (Operand)) in Formal_Kind
6499            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
6500          then
6501             Apply_Accessibility_Check (Operand, Target_Type);
6502
6503          --  If the level of the operand type is statically deeper
6504          --  then the level of the target type, then force Program_Error.
6505          --  Note that this can only occur for cases where the attribute
6506          --  is within the body of an instantiation (otherwise the
6507          --  conversion will already have been rejected as illegal).
6508          --  Note: warnings are issued by the analyzer for the instance
6509          --  cases.
6510
6511          elsif In_Instance_Body
6512            and then Type_Access_Level (Operand_Type) >
6513                     Type_Access_Level (Target_Type)
6514          then
6515             Rewrite (N,
6516               Make_Raise_Program_Error (Sloc (N),
6517                 Reason => PE_Accessibility_Check_Failed));
6518             Set_Etype (N, Target_Type);
6519
6520          --  When the operand is a selected access discriminant
6521          --  the check needs to be made against the level of the
6522          --  object denoted by the prefix of the selected name.
6523          --  Force Program_Error for this case as well (this
6524          --  accessibility violation can only happen if within
6525          --  the body of an instantiation).
6526
6527          elsif In_Instance_Body
6528            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
6529            and then Nkind (Operand) = N_Selected_Component
6530            and then Object_Access_Level (Operand) >
6531                       Type_Access_Level (Target_Type)
6532          then
6533             Rewrite (N,
6534               Make_Raise_Program_Error (Sloc (N),
6535                 Reason => PE_Accessibility_Check_Failed));
6536             Set_Etype (N, Target_Type);
6537          end if;
6538       end if;
6539
6540       --  Case of conversions of tagged types and access to tagged types
6541
6542       --  When needed, that is to say when the expression is class-wide,
6543       --  Add runtime a tag check for (strict) downward conversion by using
6544       --  the membership test, generating:
6545
6546       --      [constraint_error when Operand not in Target_Type'Class]
6547
6548       --  or in the access type case
6549
6550       --      [constraint_error
6551       --        when Operand /= null
6552       --          and then Operand.all not in
6553       --            Designated_Type (Target_Type)'Class]
6554
6555       if (Is_Access_Type (Target_Type)
6556            and then Is_Tagged_Type (Designated_Type (Target_Type)))
6557         or else Is_Tagged_Type (Target_Type)
6558       then
6559          --  Do not do any expansion in the access type case if the
6560          --  parent is a renaming, since this is an error situation
6561          --  which will be caught by Sem_Ch8, and the expansion can
6562          --  intefere with this error check.
6563
6564          if Is_Access_Type (Target_Type)
6565            and then Is_Renamed_Object (N)
6566          then
6567             return;
6568          end if;
6569
6570          --  Oherwise, proceed with processing tagged conversion
6571
6572          declare
6573             Actual_Operand_Type : Entity_Id;
6574             Actual_Target_Type  : Entity_Id;
6575
6576             Cond : Node_Id;
6577
6578          begin
6579             if Is_Access_Type (Target_Type) then
6580                Actual_Operand_Type := Designated_Type (Operand_Type);
6581                Actual_Target_Type  := Designated_Type (Target_Type);
6582
6583             else
6584                Actual_Operand_Type := Operand_Type;
6585                Actual_Target_Type  := Target_Type;
6586             end if;
6587
6588             if Is_Class_Wide_Type (Actual_Operand_Type)
6589               and then Root_Type (Actual_Operand_Type) /=  Actual_Target_Type
6590               and then Is_Ancestor
6591                          (Root_Type (Actual_Operand_Type),
6592                           Actual_Target_Type)
6593               and then not Tag_Checks_Suppressed (Actual_Target_Type)
6594             then
6595                --  The conversion is valid for any descendant of the
6596                --  target type
6597
6598                Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
6599
6600                if Is_Access_Type (Target_Type) then
6601                   Cond :=
6602                      Make_And_Then (Loc,
6603                        Left_Opnd =>
6604                          Make_Op_Ne (Loc,
6605                            Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
6606                            Right_Opnd => Make_Null (Loc)),
6607
6608                        Right_Opnd =>
6609                          Make_Not_In (Loc,
6610                            Left_Opnd  =>
6611                              Make_Explicit_Dereference (Loc,
6612                                Prefix =>
6613                                  Duplicate_Subexpr_No_Checks (Operand)),
6614                            Right_Opnd =>
6615                              New_Reference_To (Actual_Target_Type, Loc)));
6616
6617                else
6618                   Cond :=
6619                     Make_Not_In (Loc,
6620                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
6621                       Right_Opnd =>
6622                         New_Reference_To (Actual_Target_Type, Loc));
6623                end if;
6624
6625                Insert_Action (N,
6626                  Make_Raise_Constraint_Error (Loc,
6627                    Condition => Cond,
6628                    Reason    => CE_Tag_Check_Failed));
6629
6630                declare
6631                   Conv : Node_Id;
6632                begin
6633                   Conv :=
6634                     Make_Unchecked_Type_Conversion (Loc,
6635                       Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
6636                       Expression => Relocate_Node (Expression (N)));
6637                   Rewrite (N, Conv);
6638                   Analyze_And_Resolve (N, Target_Type);
6639                end;
6640             end if;
6641          end;
6642
6643       --  Case of other access type conversions
6644
6645       elsif Is_Access_Type (Target_Type) then
6646          Apply_Constraint_Check (Operand, Target_Type);
6647
6648       --  Case of conversions from a fixed-point type
6649
6650       --  These conversions require special expansion and processing, found
6651       --  in the Exp_Fixd package. We ignore cases where Conversion_OK is
6652       --  set, since from a semantic point of view, these are simple integer
6653       --  conversions, which do not need further processing.
6654
6655       elsif Is_Fixed_Point_Type (Operand_Type)
6656         and then not Conversion_OK (N)
6657       then
6658          --  We should never see universal fixed at this case, since the
6659          --  expansion of the constituent divide or multiply should have
6660          --  eliminated the explicit mention of universal fixed.
6661
6662          pragma Assert (Operand_Type /= Universal_Fixed);
6663
6664          --  Check for special case of the conversion to universal real
6665          --  that occurs as a result of the use of a round attribute.
6666          --  In this case, the real type for the conversion is taken
6667          --  from the target type of the Round attribute and the
6668          --  result must be marked as rounded.
6669
6670          if Target_Type = Universal_Real
6671            and then Nkind (Parent (N)) = N_Attribute_Reference
6672            and then Attribute_Name (Parent (N)) = Name_Round
6673          then
6674             Set_Rounded_Result (N);
6675             Set_Etype (N, Etype (Parent (N)));
6676          end if;
6677
6678          --  Otherwise do correct fixed-conversion, but skip these if the
6679          --  Conversion_OK flag is set, because from a semantic point of
6680          --  view these are simple integer conversions needing no further
6681          --  processing (the backend will simply treat them as integers)
6682
6683          if not Conversion_OK (N) then
6684             if Is_Fixed_Point_Type (Etype (N)) then
6685                Expand_Convert_Fixed_To_Fixed (N);
6686                Real_Range_Check;
6687
6688             elsif Is_Integer_Type (Etype (N)) then
6689                Expand_Convert_Fixed_To_Integer (N);
6690
6691             else
6692                pragma Assert (Is_Floating_Point_Type (Etype (N)));
6693                Expand_Convert_Fixed_To_Float (N);
6694                Real_Range_Check;
6695             end if;
6696          end if;
6697
6698       --  Case of conversions to a fixed-point type
6699
6700       --  These conversions require special expansion and processing, found
6701       --  in the Exp_Fixd package. Again, ignore cases where Conversion_OK
6702       --  is set, since from a semantic point of view, these are simple
6703       --  integer conversions, which do not need further processing.
6704
6705       elsif Is_Fixed_Point_Type (Target_Type)
6706         and then not Conversion_OK (N)
6707       then
6708          if Is_Integer_Type (Operand_Type) then
6709             Expand_Convert_Integer_To_Fixed (N);
6710             Real_Range_Check;
6711          else
6712             pragma Assert (Is_Floating_Point_Type (Operand_Type));
6713             Expand_Convert_Float_To_Fixed (N);
6714             Real_Range_Check;
6715          end if;
6716
6717       --  Case of float-to-integer conversions
6718
6719       --  We also handle float-to-fixed conversions with Conversion_OK set
6720       --  since semantically the fixed-point target is treated as though it
6721       --  were an integer in such cases.
6722
6723       elsif Is_Floating_Point_Type (Operand_Type)
6724         and then
6725           (Is_Integer_Type (Target_Type)
6726             or else
6727           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
6728       then
6729          --  Special processing required if the conversion is the expression
6730          --  of a Truncation attribute reference. In this case we replace:
6731
6732          --     ityp (ftyp'Truncation (x))
6733
6734          --  by
6735
6736          --     ityp (x)
6737
6738          --  with the Float_Truncate flag set. This is clearly more efficient.
6739
6740          if Nkind (Operand) = N_Attribute_Reference
6741            and then Attribute_Name (Operand) = Name_Truncation
6742          then
6743             Rewrite (Operand,
6744               Relocate_Node (First (Expressions (Operand))));
6745             Set_Float_Truncate (N, True);
6746          end if;
6747
6748          --  One more check here, gcc is still not able to do conversions of
6749          --  this type with proper overflow checking, and so gigi is doing an
6750          --  approximation of what is required by doing floating-point compares
6751          --  with the end-point. But that can lose precision in some cases, and
6752          --  give a wrong result. Converting the operand to Long_Long_Float is
6753          --  helpful, but still does not catch all cases with 64-bit integers
6754          --  on targets with only 64-bit floats ???
6755
6756          if Do_Range_Check (Operand) then
6757             Rewrite (Operand,
6758               Make_Type_Conversion (Loc,
6759                 Subtype_Mark =>
6760                   New_Occurrence_Of (Standard_Long_Long_Float, Loc),
6761                 Expression =>
6762                   Relocate_Node (Operand)));
6763
6764             Set_Etype (Operand, Standard_Long_Long_Float);
6765             Enable_Range_Check (Operand);
6766             Set_Do_Range_Check (Expression (Operand), False);
6767          end if;
6768
6769       --  Case of array conversions
6770
6771       --  Expansion of array conversions, add required length/range checks
6772       --  but only do this if there is no change of representation. For
6773       --  handling of this case, see Handle_Changed_Representation.
6774
6775       elsif Is_Array_Type (Target_Type) then
6776
6777          if Is_Constrained (Target_Type) then
6778             Apply_Length_Check (Operand, Target_Type);
6779          else
6780             Apply_Range_Check (Operand, Target_Type);
6781          end if;
6782
6783          Handle_Changed_Representation;
6784
6785       --  Case of conversions of discriminated types
6786
6787       --  Add required discriminant checks if target is constrained. Again
6788       --  this change is skipped if we have a change of representation.
6789
6790       elsif Has_Discriminants (Target_Type)
6791         and then Is_Constrained (Target_Type)
6792       then
6793          Apply_Discriminant_Check (Operand, Target_Type);
6794          Handle_Changed_Representation;
6795
6796       --  Case of all other record conversions. The only processing required
6797       --  is to check for a change of representation requiring the special
6798       --  assignment processing.
6799
6800       elsif Is_Record_Type (Target_Type) then
6801
6802          --  Ada 2005 (AI-216): Program_Error is raised when converting from
6803          --  a derived Unchecked_Union type to an unconstrained non-Unchecked_
6804          --  Union type if the operand lacks inferable discriminants.
6805
6806          if Is_Derived_Type (Operand_Type)
6807            and then Is_Unchecked_Union (Base_Type (Operand_Type))
6808            and then not Is_Constrained (Target_Type)
6809            and then not Is_Unchecked_Union (Base_Type (Target_Type))
6810            and then not Has_Inferable_Discriminants (Operand)
6811          then
6812             --  To prevent Gigi from generating illegal code, we make a
6813             --  Program_Error node, but we give it the target type of the
6814             --  conversion.
6815
6816             declare
6817                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
6818                       Reason => PE_Unchecked_Union_Restriction);
6819
6820             begin
6821                Set_Etype (PE, Target_Type);
6822                Rewrite (N, PE);
6823
6824             end;
6825          else
6826             Handle_Changed_Representation;
6827          end if;
6828
6829       --  Case of conversions of enumeration types
6830
6831       elsif Is_Enumeration_Type (Target_Type) then
6832
6833          --  Special processing is required if there is a change of
6834          --  representation (from enumeration representation clauses)
6835
6836          if not Same_Representation (Target_Type, Operand_Type) then
6837
6838             --  Convert: x(y) to x'val (ytyp'val (y))
6839
6840             Rewrite (N,
6841                Make_Attribute_Reference (Loc,
6842                  Prefix => New_Occurrence_Of (Target_Type, Loc),
6843                  Attribute_Name => Name_Val,
6844                  Expressions => New_List (
6845                    Make_Attribute_Reference (Loc,
6846                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
6847                      Attribute_Name => Name_Pos,
6848                      Expressions => New_List (Operand)))));
6849
6850             Analyze_And_Resolve (N, Target_Type);
6851          end if;
6852
6853       --  Case of conversions to floating-point
6854
6855       elsif Is_Floating_Point_Type (Target_Type) then
6856          Real_Range_Check;
6857
6858       --  The remaining cases require no front end processing
6859
6860       else
6861          null;
6862       end if;
6863
6864       --  At this stage, either the conversion node has been transformed
6865       --  into some other equivalent expression, or left as a conversion
6866       --  that can be handled by Gigi. The conversions that Gigi can handle
6867       --  are the following:
6868
6869       --    Conversions with no change of representation or type
6870
6871       --    Numeric conversions involving integer values, floating-point
6872       --    values, and fixed-point values. Fixed-point values are allowed
6873       --    only if Conversion_OK is set, i.e. if the fixed-point values
6874       --    are to be treated as integers.
6875
6876       --  No other conversions should be passed to Gigi
6877
6878       --  Check: are these rules stated in sinfo??? if so, why restate here???
6879
6880       --  The only remaining step is to generate a range check if we still
6881       --  have a type conversion at this stage and Do_Range_Check is set.
6882       --  For now we do this only for conversions of discrete types.
6883
6884       if Nkind (N) = N_Type_Conversion
6885         and then Is_Discrete_Type (Etype (N))
6886       then
6887          declare
6888             Expr : constant Node_Id := Expression (N);
6889             Ftyp : Entity_Id;
6890             Ityp : Entity_Id;
6891
6892          begin
6893             if Do_Range_Check (Expr)
6894               and then Is_Discrete_Type (Etype (Expr))
6895             then
6896                Set_Do_Range_Check (Expr, False);
6897
6898                --  Before we do a range check, we have to deal with treating
6899                --  a fixed-point operand as an integer. The way we do this
6900                --  is simply to do an unchecked conversion to an appropriate
6901                --  integer type large enough to hold the result.
6902
6903                --  This code is not active yet, because we are only dealing
6904                --  with discrete types so far ???
6905
6906                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
6907                  and then Treat_Fixed_As_Integer (Expr)
6908                then
6909                   Ftyp := Base_Type (Etype (Expr));
6910
6911                   if Esize (Ftyp) >= Esize (Standard_Integer) then
6912                      Ityp := Standard_Long_Long_Integer;
6913                   else
6914                      Ityp := Standard_Integer;
6915                   end if;
6916
6917                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
6918                end if;
6919
6920                --  Reset overflow flag, since the range check will include
6921                --  dealing with possible overflow, and generate the check
6922                --  If Address is either source or target type, suppress
6923                --  range check to avoid typing anomalies when it is a visible
6924                --  integer type.
6925
6926                Set_Do_Overflow_Check (N, False);
6927                if not Is_Descendent_Of_Address (Etype (Expr))
6928                  and then not Is_Descendent_Of_Address (Target_Type)
6929                then
6930                   Generate_Range_Check
6931                     (Expr, Target_Type, CE_Range_Check_Failed);
6932                end if;
6933             end if;
6934          end;
6935       end if;
6936    end Expand_N_Type_Conversion;
6937
6938    -----------------------------------
6939    -- Expand_N_Unchecked_Expression --
6940    -----------------------------------
6941
6942    --  Remove the unchecked expression node from the tree. It's job was simply
6943    --  to make sure that its constituent expression was handled with checks
6944    --  off, and now that that is done, we can remove it from the tree, and
6945    --  indeed must, since gigi does not expect to see these nodes.
6946
6947    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
6948       Exp : constant Node_Id := Expression (N);
6949
6950    begin
6951       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
6952       Rewrite (N, Exp);
6953    end Expand_N_Unchecked_Expression;
6954
6955    ----------------------------------------
6956    -- Expand_N_Unchecked_Type_Conversion --
6957    ----------------------------------------
6958
6959    --  If this cannot be handled by Gigi and we haven't already made
6960    --  a temporary for it, do it now.
6961
6962    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
6963       Target_Type  : constant Entity_Id := Etype (N);
6964       Operand      : constant Node_Id   := Expression (N);
6965       Operand_Type : constant Entity_Id := Etype (Operand);
6966
6967    begin
6968       --  If we have a conversion of a compile time known value to a target
6969       --  type and the value is in range of the target type, then we can simply
6970       --  replace the construct by an integer literal of the correct type. We
6971       --  only apply this to integer types being converted. Possibly it may
6972       --  apply in other cases, but it is too much trouble to worry about.
6973
6974       --  Note that we do not do this transformation if the Kill_Range_Check
6975       --  flag is set, since then the value may be outside the expected range.
6976       --  This happens in the Normalize_Scalars case.
6977
6978       if Is_Integer_Type (Target_Type)
6979         and then Is_Integer_Type (Operand_Type)
6980         and then Compile_Time_Known_Value (Operand)
6981         and then not Kill_Range_Check (N)
6982       then
6983          declare
6984             Val : constant Uint := Expr_Value (Operand);
6985
6986          begin
6987             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
6988                  and then
6989                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
6990                  and then
6991                Val >= Expr_Value (Type_Low_Bound (Target_Type))
6992                  and then
6993                Val <= Expr_Value (Type_High_Bound (Target_Type))
6994             then
6995                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
6996
6997                --  If Address is the target type, just set the type
6998                --  to avoid a spurious type error on the literal when
6999                --  Address is a visible integer type.
7000
7001                if Is_Descendent_Of_Address (Target_Type) then
7002                   Set_Etype (N, Target_Type);
7003                else
7004                   Analyze_And_Resolve (N, Target_Type);
7005                end if;
7006
7007                return;
7008             end if;
7009          end;
7010       end if;
7011
7012       --  Nothing to do if conversion is safe
7013
7014       if Safe_Unchecked_Type_Conversion (N) then
7015          return;
7016       end if;
7017
7018       --  Otherwise force evaluation unless Assignment_OK flag is set (this
7019       --  flag indicates ??? -- more comments needed here)
7020
7021       if Assignment_OK (N) then
7022          null;
7023       else
7024          Force_Evaluation (N);
7025       end if;
7026    end Expand_N_Unchecked_Type_Conversion;
7027
7028    ----------------------------
7029    -- Expand_Record_Equality --
7030    ----------------------------
7031
7032    --  For non-variant records, Equality is expanded when needed into:
7033
7034    --      and then Lhs.Discr1 = Rhs.Discr1
7035    --      and then ...
7036    --      and then Lhs.Discrn = Rhs.Discrn
7037    --      and then Lhs.Cmp1 = Rhs.Cmp1
7038    --      and then ...
7039    --      and then Lhs.Cmpn = Rhs.Cmpn
7040
7041    --  The expression is folded by the back-end for adjacent fields. This
7042    --  function is called for tagged record in only one occasion: for imple-
7043    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
7044    --  otherwise the primitive "=" is used directly.
7045
7046    function Expand_Record_Equality
7047      (Nod    : Node_Id;
7048       Typ    : Entity_Id;
7049       Lhs    : Node_Id;
7050       Rhs    : Node_Id;
7051       Bodies : List_Id) return Node_Id
7052    is
7053       Loc : constant Source_Ptr := Sloc (Nod);
7054
7055       Result : Node_Id;
7056       C      : Entity_Id;
7057
7058       First_Time : Boolean := True;
7059
7060       function Suitable_Element (C : Entity_Id) return Entity_Id;
7061       --  Return the first field to compare beginning with C, skipping the
7062       --  inherited components.
7063
7064       ----------------------
7065       -- Suitable_Element --
7066       ----------------------
7067
7068       function Suitable_Element (C : Entity_Id) return Entity_Id is
7069       begin
7070          if No (C) then
7071             return Empty;
7072
7073          elsif Ekind (C) /= E_Discriminant
7074            and then Ekind (C) /= E_Component
7075          then
7076             return Suitable_Element (Next_Entity (C));
7077
7078          elsif Is_Tagged_Type (Typ)
7079            and then C /= Original_Record_Component (C)
7080          then
7081             return Suitable_Element (Next_Entity (C));
7082
7083          elsif Chars (C) = Name_uController
7084            or else Chars (C) = Name_uTag
7085          then
7086             return Suitable_Element (Next_Entity (C));
7087
7088          else
7089             return C;
7090          end if;
7091       end Suitable_Element;
7092
7093    --  Start of processing for Expand_Record_Equality
7094
7095    begin
7096       --  Generates the following code: (assuming that Typ has one Discr and
7097       --  component C2 is also a record)
7098
7099       --   True
7100       --     and then Lhs.Discr1 = Rhs.Discr1
7101       --     and then Lhs.C1 = Rhs.C1
7102       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
7103       --     and then ...
7104       --     and then Lhs.Cmpn = Rhs.Cmpn
7105
7106       Result := New_Reference_To (Standard_True, Loc);
7107       C := Suitable_Element (First_Entity (Typ));
7108
7109       while Present (C) loop
7110          declare
7111             New_Lhs : Node_Id;
7112             New_Rhs : Node_Id;
7113
7114          begin
7115             if First_Time then
7116                First_Time := False;
7117                New_Lhs := Lhs;
7118                New_Rhs := Rhs;
7119             else
7120                New_Lhs := New_Copy_Tree (Lhs);
7121                New_Rhs := New_Copy_Tree (Rhs);
7122             end if;
7123
7124             Result :=
7125               Make_And_Then (Loc,
7126                 Left_Opnd  => Result,
7127                 Right_Opnd =>
7128                   Expand_Composite_Equality (Nod, Etype (C),
7129                     Lhs =>
7130                       Make_Selected_Component (Loc,
7131                         Prefix => New_Lhs,
7132                         Selector_Name => New_Reference_To (C, Loc)),
7133                     Rhs =>
7134                       Make_Selected_Component (Loc,
7135                         Prefix => New_Rhs,
7136                         Selector_Name => New_Reference_To (C, Loc)),
7137                     Bodies => Bodies));
7138          end;
7139
7140          C := Suitable_Element (Next_Entity (C));
7141       end loop;
7142
7143       return Result;
7144    end Expand_Record_Equality;
7145
7146    -------------------------------------
7147    -- Fixup_Universal_Fixed_Operation --
7148    -------------------------------------
7149
7150    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
7151       Conv : constant Node_Id := Parent (N);
7152
7153    begin
7154       --  We must have a type conversion immediately above us
7155
7156       pragma Assert (Nkind (Conv) = N_Type_Conversion);
7157
7158       --  Normally the type conversion gives our target type. The exception
7159       --  occurs in the case of the Round attribute, where the conversion
7160       --  will be to universal real, and our real type comes from the Round
7161       --  attribute (as well as an indication that we must round the result)
7162
7163       if Nkind (Parent (Conv)) = N_Attribute_Reference
7164         and then Attribute_Name (Parent (Conv)) = Name_Round
7165       then
7166          Set_Etype (N, Etype (Parent (Conv)));
7167          Set_Rounded_Result (N);
7168
7169       --  Normal case where type comes from conversion above us
7170
7171       else
7172          Set_Etype (N, Etype (Conv));
7173       end if;
7174    end Fixup_Universal_Fixed_Operation;
7175
7176    ------------------------------
7177    -- Get_Allocator_Final_List --
7178    ------------------------------
7179
7180    function Get_Allocator_Final_List
7181      (N    : Node_Id;
7182       T    : Entity_Id;
7183       PtrT : Entity_Id) return Entity_Id
7184    is
7185       Loc : constant Source_Ptr := Sloc (N);
7186
7187       Owner : Entity_Id := PtrT;
7188       --  The entity whose finalisation list must be used to attach the
7189       --  allocated object.
7190
7191    begin
7192       if Ekind (PtrT) = E_Anonymous_Access_Type then
7193          if Nkind (Associated_Node_For_Itype (PtrT))
7194               in N_Subprogram_Specification
7195          then
7196             --  If the context is an access parameter, we need to create
7197             --  a non-anonymous access type in order to have a usable
7198             --  final list, because there is otherwise no pool to which
7199             --  the allocated object can belong. We create both the type
7200             --  and the finalization chain here, because freezing an
7201             --  internal type does not create such a chain. The Final_Chain
7202             --  that is thus created is shared by the access parameter.
7203
7204             Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
7205             Insert_Action (N,
7206               Make_Full_Type_Declaration (Loc,
7207                 Defining_Identifier => Owner,
7208                 Type_Definition =>
7209                    Make_Access_To_Object_Definition (Loc,
7210                      Subtype_Indication =>
7211                        New_Occurrence_Of (T, Loc))));
7212
7213             Build_Final_List (N, Owner);
7214             Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
7215
7216          else
7217             --  Case of an access discriminant, or (Ada 2005) of
7218             --  an anonymous access component: find the final list
7219             --  associated with the scope of the type.
7220
7221             Owner := Scope (PtrT);
7222          end if;
7223       end if;
7224
7225       return Find_Final_List (Owner);
7226    end Get_Allocator_Final_List;
7227
7228    ---------------------------------
7229    -- Has_Inferable_Discriminants --
7230    ---------------------------------
7231
7232    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
7233
7234       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
7235       --  Determines whether the left-most prefix of a selected component is a
7236       --  formal parameter in a subprogram. Assumes N is a selected component.
7237
7238       --------------------------------
7239       -- Prefix_Is_Formal_Parameter --
7240       --------------------------------
7241
7242       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
7243          Sel_Comp : Node_Id := N;
7244
7245       begin
7246          --  Move to the left-most prefix by climbing up the tree
7247
7248          while Present (Parent (Sel_Comp))
7249            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
7250          loop
7251             Sel_Comp := Parent (Sel_Comp);
7252          end loop;
7253
7254          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
7255       end Prefix_Is_Formal_Parameter;
7256
7257    --  Start of processing for Has_Inferable_Discriminants
7258
7259    begin
7260       --  For identifiers and indexed components, it is sufficent to have a
7261       --  constrained Unchecked_Union nominal subtype.
7262
7263       if Nkind (N) = N_Identifier
7264            or else
7265          Nkind (N) = N_Indexed_Component
7266       then
7267          return Is_Unchecked_Union (Base_Type (Etype (N)))
7268                   and then
7269                 Is_Constrained (Etype (N));
7270
7271       --  For selected components, the subtype of the selector must be a
7272       --  constrained Unchecked_Union. If the component is subject to a
7273       --  per-object constraint, then the enclosing object must have inferable
7274       --  discriminants.
7275
7276       elsif Nkind (N) = N_Selected_Component then
7277          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
7278
7279             --  A small hack. If we have a per-object constrained selected
7280             --  component of a formal parameter, return True since we do not
7281             --  know the actual parameter association yet.
7282
7283             if Prefix_Is_Formal_Parameter (N) then
7284                return True;
7285             end if;
7286
7287             --  Otherwise, check the enclosing object and the selector
7288
7289             return Has_Inferable_Discriminants (Prefix (N))
7290                      and then
7291                    Has_Inferable_Discriminants (Selector_Name (N));
7292          end if;
7293
7294          --  The call to Has_Inferable_Discriminants will determine whether
7295          --  the selector has a constrained Unchecked_Union nominal type.
7296
7297          return Has_Inferable_Discriminants (Selector_Name (N));
7298
7299       --  A qualified expression has inferable discriminants if its subtype
7300       --  mark is a constrained Unchecked_Union subtype.
7301
7302       elsif Nkind (N) = N_Qualified_Expression then
7303          return Is_Unchecked_Union (Subtype_Mark (N))
7304                   and then
7305                 Is_Constrained (Subtype_Mark (N));
7306
7307       end if;
7308
7309       return False;
7310    end Has_Inferable_Discriminants;
7311
7312    -------------------------------
7313    -- Insert_Dereference_Action --
7314    -------------------------------
7315
7316    procedure Insert_Dereference_Action (N : Node_Id) is
7317       Loc  : constant Source_Ptr := Sloc (N);
7318       Typ  : constant Entity_Id  := Etype (N);
7319       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
7320       Pnod : constant Node_Id    := Parent (N);
7321
7322       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
7323       --  Return true if type of P is derived from Checked_Pool;
7324
7325       -----------------------------
7326       -- Is_Checked_Storage_Pool --
7327       -----------------------------
7328
7329       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
7330          T : Entity_Id;
7331
7332       begin
7333          if No (P) then
7334             return False;
7335          end if;
7336
7337          T := Etype (P);
7338          while T /= Etype (T) loop
7339             if Is_RTE (T, RE_Checked_Pool) then
7340                return True;
7341             else
7342                T := Etype (T);
7343             end if;
7344          end loop;
7345
7346          return False;
7347       end Is_Checked_Storage_Pool;
7348
7349    --  Start of processing for Insert_Dereference_Action
7350
7351    begin
7352       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
7353
7354       if not (Is_Checked_Storage_Pool (Pool)
7355               and then Comes_From_Source (Original_Node (Pnod)))
7356       then
7357          return;
7358       end if;
7359
7360       Insert_Action (N,
7361         Make_Procedure_Call_Statement (Loc,
7362           Name => New_Reference_To (
7363             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
7364
7365           Parameter_Associations => New_List (
7366
7367             --  Pool
7368
7369              New_Reference_To (Pool, Loc),
7370
7371             --  Storage_Address. We use the attribute Pool_Address,
7372             --  which uses the pointer itself to find the address of
7373             --  the object, and which handles unconstrained arrays
7374             --  properly by computing the address of the template.
7375             --  i.e. the correct address of the corresponding allocation.
7376
7377              Make_Attribute_Reference (Loc,
7378                Prefix         => Duplicate_Subexpr_Move_Checks (N),
7379                Attribute_Name => Name_Pool_Address),
7380
7381             --  Size_In_Storage_Elements
7382
7383              Make_Op_Divide (Loc,
7384                Left_Opnd  =>
7385                 Make_Attribute_Reference (Loc,
7386                   Prefix         =>
7387                     Make_Explicit_Dereference (Loc,
7388                       Duplicate_Subexpr_Move_Checks (N)),
7389                   Attribute_Name => Name_Size),
7390                Right_Opnd =>
7391                  Make_Integer_Literal (Loc, System_Storage_Unit)),
7392
7393             --  Alignment
7394
7395              Make_Attribute_Reference (Loc,
7396                Prefix         =>
7397                  Make_Explicit_Dereference (Loc,
7398                    Duplicate_Subexpr_Move_Checks (N)),
7399                Attribute_Name => Name_Alignment))));
7400
7401    exception
7402       when RE_Not_Available =>
7403          return;
7404    end Insert_Dereference_Action;
7405
7406    ------------------------------
7407    -- Make_Array_Comparison_Op --
7408    ------------------------------
7409
7410    --  This is a hand-coded expansion of the following generic function:
7411
7412    --  generic
7413    --    type elem is  (<>);
7414    --    type index is (<>);
7415    --    type a is array (index range <>) of elem;
7416    --
7417    --  function Gnnn (X : a; Y: a) return boolean is
7418    --    J : index := Y'first;
7419    --
7420    --  begin
7421    --    if X'length = 0 then
7422    --       return false;
7423    --
7424    --    elsif Y'length = 0 then
7425    --       return true;
7426    --
7427    --    else
7428    --      for I in X'range loop
7429    --        if X (I) = Y (J) then
7430    --          if J = Y'last then
7431    --            exit;
7432    --          else
7433    --            J := index'succ (J);
7434    --          end if;
7435    --
7436    --        else
7437    --           return X (I) > Y (J);
7438    --        end if;
7439    --      end loop;
7440    --
7441    --      return X'length > Y'length;
7442    --    end if;
7443    --  end Gnnn;
7444
7445    --  Note that since we are essentially doing this expansion by hand, we
7446    --  do not need to generate an actual or formal generic part, just the
7447    --  instantiated function itself.
7448
7449    function Make_Array_Comparison_Op
7450      (Typ : Entity_Id;
7451       Nod : Node_Id) return Node_Id
7452    is
7453       Loc : constant Source_Ptr := Sloc (Nod);
7454
7455       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
7456       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
7457       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
7458       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
7459
7460       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
7461
7462       Loop_Statement : Node_Id;
7463       Loop_Body      : Node_Id;
7464       If_Stat        : Node_Id;
7465       Inner_If       : Node_Id;
7466       Final_Expr     : Node_Id;
7467       Func_Body      : Node_Id;
7468       Func_Name      : Entity_Id;
7469       Formals        : List_Id;
7470       Length1        : Node_Id;
7471       Length2        : Node_Id;
7472
7473    begin
7474       --  if J = Y'last then
7475       --     exit;
7476       --  else
7477       --     J := index'succ (J);
7478       --  end if;
7479
7480       Inner_If :=
7481         Make_Implicit_If_Statement (Nod,
7482           Condition =>
7483             Make_Op_Eq (Loc,
7484               Left_Opnd => New_Reference_To (J, Loc),
7485               Right_Opnd =>
7486                 Make_Attribute_Reference (Loc,
7487                   Prefix => New_Reference_To (Y, Loc),
7488                   Attribute_Name => Name_Last)),
7489
7490           Then_Statements => New_List (
7491                 Make_Exit_Statement (Loc)),
7492
7493           Else_Statements =>
7494             New_List (
7495               Make_Assignment_Statement (Loc,
7496                 Name => New_Reference_To (J, Loc),
7497                 Expression =>
7498                   Make_Attribute_Reference (Loc,
7499                     Prefix => New_Reference_To (Index, Loc),
7500                     Attribute_Name => Name_Succ,
7501                     Expressions => New_List (New_Reference_To (J, Loc))))));
7502
7503       --  if X (I) = Y (J) then
7504       --     if ... end if;
7505       --  else
7506       --     return X (I) > Y (J);
7507       --  end if;
7508
7509       Loop_Body :=
7510         Make_Implicit_If_Statement (Nod,
7511           Condition =>
7512             Make_Op_Eq (Loc,
7513               Left_Opnd =>
7514                 Make_Indexed_Component (Loc,
7515                   Prefix      => New_Reference_To (X, Loc),
7516                   Expressions => New_List (New_Reference_To (I, Loc))),
7517
7518               Right_Opnd =>
7519                 Make_Indexed_Component (Loc,
7520                   Prefix      => New_Reference_To (Y, Loc),
7521                   Expressions => New_List (New_Reference_To (J, Loc)))),
7522
7523           Then_Statements => New_List (Inner_If),
7524
7525           Else_Statements => New_List (
7526             Make_Return_Statement (Loc,
7527               Expression =>
7528                 Make_Op_Gt (Loc,
7529                   Left_Opnd =>
7530                     Make_Indexed_Component (Loc,
7531                       Prefix      => New_Reference_To (X, Loc),
7532                       Expressions => New_List (New_Reference_To (I, Loc))),
7533
7534                   Right_Opnd =>
7535                     Make_Indexed_Component (Loc,
7536                       Prefix      => New_Reference_To (Y, Loc),
7537                       Expressions => New_List (
7538                         New_Reference_To (J, Loc)))))));
7539
7540       --  for I in X'range loop
7541       --     if ... end if;
7542       --  end loop;
7543
7544       Loop_Statement :=
7545         Make_Implicit_Loop_Statement (Nod,
7546           Identifier => Empty,
7547
7548           Iteration_Scheme =>
7549             Make_Iteration_Scheme (Loc,
7550               Loop_Parameter_Specification =>
7551                 Make_Loop_Parameter_Specification (Loc,
7552                   Defining_Identifier => I,
7553                   Discrete_Subtype_Definition =>
7554                     Make_Attribute_Reference (Loc,
7555                       Prefix => New_Reference_To (X, Loc),
7556                       Attribute_Name => Name_Range))),
7557
7558           Statements => New_List (Loop_Body));
7559
7560       --    if X'length = 0 then
7561       --       return false;
7562       --    elsif Y'length = 0 then
7563       --       return true;
7564       --    else
7565       --      for ... loop ... end loop;
7566       --      return X'length > Y'length;
7567       --    end if;
7568
7569       Length1 :=
7570         Make_Attribute_Reference (Loc,
7571           Prefix => New_Reference_To (X, Loc),
7572           Attribute_Name => Name_Length);
7573
7574       Length2 :=
7575         Make_Attribute_Reference (Loc,
7576           Prefix => New_Reference_To (Y, Loc),
7577           Attribute_Name => Name_Length);
7578
7579       Final_Expr :=
7580         Make_Op_Gt (Loc,
7581           Left_Opnd  => Length1,
7582           Right_Opnd => Length2);
7583
7584       If_Stat :=
7585         Make_Implicit_If_Statement (Nod,
7586           Condition =>
7587             Make_Op_Eq (Loc,
7588               Left_Opnd =>
7589                 Make_Attribute_Reference (Loc,
7590                   Prefix => New_Reference_To (X, Loc),
7591                   Attribute_Name => Name_Length),
7592               Right_Opnd =>
7593                 Make_Integer_Literal (Loc, 0)),
7594
7595           Then_Statements =>
7596             New_List (
7597               Make_Return_Statement (Loc,
7598                 Expression => New_Reference_To (Standard_False, Loc))),
7599
7600           Elsif_Parts => New_List (
7601             Make_Elsif_Part (Loc,
7602               Condition =>
7603                 Make_Op_Eq (Loc,
7604                   Left_Opnd =>
7605                     Make_Attribute_Reference (Loc,
7606                       Prefix => New_Reference_To (Y, Loc),
7607                       Attribute_Name => Name_Length),
7608                   Right_Opnd =>
7609                     Make_Integer_Literal (Loc, 0)),
7610
7611               Then_Statements =>
7612                 New_List (
7613                   Make_Return_Statement (Loc,
7614                      Expression => New_Reference_To (Standard_True, Loc))))),
7615
7616           Else_Statements => New_List (
7617             Loop_Statement,
7618             Make_Return_Statement (Loc,
7619               Expression => Final_Expr)));
7620
7621       --  (X : a; Y: a)
7622
7623       Formals := New_List (
7624         Make_Parameter_Specification (Loc,
7625           Defining_Identifier => X,
7626           Parameter_Type      => New_Reference_To (Typ, Loc)),
7627
7628         Make_Parameter_Specification (Loc,
7629           Defining_Identifier => Y,
7630           Parameter_Type      => New_Reference_To (Typ, Loc)));
7631
7632       --  function Gnnn (...) return boolean is
7633       --    J : index := Y'first;
7634       --  begin
7635       --    if ... end if;
7636       --  end Gnnn;
7637
7638       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
7639
7640       Func_Body :=
7641         Make_Subprogram_Body (Loc,
7642           Specification =>
7643             Make_Function_Specification (Loc,
7644               Defining_Unit_Name       => Func_Name,
7645               Parameter_Specifications => Formals,
7646               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
7647
7648           Declarations => New_List (
7649             Make_Object_Declaration (Loc,
7650               Defining_Identifier => J,
7651               Object_Definition   => New_Reference_To (Index, Loc),
7652               Expression =>
7653                 Make_Attribute_Reference (Loc,
7654                   Prefix => New_Reference_To (Y, Loc),
7655                   Attribute_Name => Name_First))),
7656
7657           Handled_Statement_Sequence =>
7658             Make_Handled_Sequence_Of_Statements (Loc,
7659               Statements => New_List (If_Stat)));
7660
7661       return Func_Body;
7662
7663    end Make_Array_Comparison_Op;
7664
7665    ---------------------------
7666    -- Make_Boolean_Array_Op --
7667    ---------------------------
7668
7669    --  For logical operations on boolean arrays, expand in line the
7670    --  following, replacing 'and' with 'or' or 'xor' where needed:
7671
7672    --    function Annn (A : typ; B: typ) return typ is
7673    --       C : typ;
7674    --    begin
7675    --       for J in A'range loop
7676    --          C (J) := A (J) op B (J);
7677    --       end loop;
7678    --       return C;
7679    --    end Annn;
7680
7681    --  Here typ is the boolean array type
7682
7683    function Make_Boolean_Array_Op
7684      (Typ : Entity_Id;
7685       N   : Node_Id) return Node_Id
7686    is
7687       Loc : constant Source_Ptr := Sloc (N);
7688
7689       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
7690       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
7691       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
7692       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
7693
7694       A_J : Node_Id;
7695       B_J : Node_Id;
7696       C_J : Node_Id;
7697       Op  : Node_Id;
7698
7699       Formals        : List_Id;
7700       Func_Name      : Entity_Id;
7701       Func_Body      : Node_Id;
7702       Loop_Statement : Node_Id;
7703
7704    begin
7705       A_J :=
7706         Make_Indexed_Component (Loc,
7707           Prefix      => New_Reference_To (A, Loc),
7708           Expressions => New_List (New_Reference_To (J, Loc)));
7709
7710       B_J :=
7711         Make_Indexed_Component (Loc,
7712           Prefix      => New_Reference_To (B, Loc),
7713           Expressions => New_List (New_Reference_To (J, Loc)));
7714
7715       C_J :=
7716         Make_Indexed_Component (Loc,
7717           Prefix      => New_Reference_To (C, Loc),
7718           Expressions => New_List (New_Reference_To (J, Loc)));
7719
7720       if Nkind (N) = N_Op_And then
7721          Op :=
7722            Make_Op_And (Loc,
7723              Left_Opnd  => A_J,
7724              Right_Opnd => B_J);
7725
7726       elsif Nkind (N) = N_Op_Or then
7727          Op :=
7728            Make_Op_Or (Loc,
7729              Left_Opnd  => A_J,
7730              Right_Opnd => B_J);
7731
7732       else
7733          Op :=
7734            Make_Op_Xor (Loc,
7735              Left_Opnd  => A_J,
7736              Right_Opnd => B_J);
7737       end if;
7738
7739       Loop_Statement :=
7740         Make_Implicit_Loop_Statement (N,
7741           Identifier => Empty,
7742
7743           Iteration_Scheme =>
7744             Make_Iteration_Scheme (Loc,
7745               Loop_Parameter_Specification =>
7746                 Make_Loop_Parameter_Specification (Loc,
7747                   Defining_Identifier => J,
7748                   Discrete_Subtype_Definition =>
7749                     Make_Attribute_Reference (Loc,
7750                       Prefix => New_Reference_To (A, Loc),
7751                       Attribute_Name => Name_Range))),
7752
7753           Statements => New_List (
7754             Make_Assignment_Statement (Loc,
7755               Name       => C_J,
7756               Expression => Op)));
7757
7758       Formals := New_List (
7759         Make_Parameter_Specification (Loc,
7760           Defining_Identifier => A,
7761           Parameter_Type      => New_Reference_To (Typ, Loc)),
7762
7763         Make_Parameter_Specification (Loc,
7764           Defining_Identifier => B,
7765           Parameter_Type      => New_Reference_To (Typ, Loc)));
7766
7767       Func_Name :=
7768         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
7769       Set_Is_Inlined (Func_Name);
7770
7771       Func_Body :=
7772         Make_Subprogram_Body (Loc,
7773           Specification =>
7774             Make_Function_Specification (Loc,
7775               Defining_Unit_Name       => Func_Name,
7776               Parameter_Specifications => Formals,
7777               Subtype_Mark             => New_Reference_To (Typ, Loc)),
7778
7779           Declarations => New_List (
7780             Make_Object_Declaration (Loc,
7781               Defining_Identifier => C,
7782               Object_Definition   => New_Reference_To (Typ, Loc))),
7783
7784           Handled_Statement_Sequence =>
7785             Make_Handled_Sequence_Of_Statements (Loc,
7786               Statements => New_List (
7787                 Loop_Statement,
7788                 Make_Return_Statement (Loc,
7789                   Expression => New_Reference_To (C, Loc)))));
7790
7791       return Func_Body;
7792    end Make_Boolean_Array_Op;
7793
7794    ------------------------
7795    -- Rewrite_Comparison --
7796    ------------------------
7797
7798    procedure Rewrite_Comparison (N : Node_Id) is
7799       Typ : constant Entity_Id := Etype (N);
7800       Op1 : constant Node_Id   := Left_Opnd (N);
7801       Op2 : constant Node_Id   := Right_Opnd (N);
7802
7803       Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
7804       --  Res indicates if compare outcome can be determined at compile time
7805
7806       True_Result  : Boolean;
7807       False_Result : Boolean;
7808
7809    begin
7810       case N_Op_Compare (Nkind (N)) is
7811          when N_Op_Eq =>
7812             True_Result  := Res = EQ;
7813             False_Result := Res = LT or else Res = GT or else Res = NE;
7814
7815          when N_Op_Ge =>
7816             True_Result  := Res in Compare_GE;
7817             False_Result := Res = LT;
7818
7819          when N_Op_Gt =>
7820             True_Result  := Res = GT;
7821             False_Result := Res in Compare_LE;
7822
7823          when N_Op_Lt =>
7824             True_Result  := Res = LT;
7825             False_Result := Res in Compare_GE;
7826
7827          when N_Op_Le =>
7828             True_Result  := Res in Compare_LE;
7829             False_Result := Res = GT;
7830
7831          when N_Op_Ne =>
7832             True_Result  := Res = NE;
7833             False_Result := Res = LT or else Res = GT or else Res = EQ;
7834       end case;
7835
7836       if True_Result then
7837          Rewrite (N,
7838            Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
7839          Analyze_And_Resolve (N, Typ);
7840          Warn_On_Known_Condition (N);
7841
7842       elsif False_Result then
7843          Rewrite (N,
7844            Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
7845          Analyze_And_Resolve (N, Typ);
7846          Warn_On_Known_Condition (N);
7847       end if;
7848    end Rewrite_Comparison;
7849
7850    ----------------------------
7851    -- Safe_In_Place_Array_Op --
7852    ----------------------------
7853
7854    function Safe_In_Place_Array_Op
7855      (Lhs : Node_Id;
7856       Op1 : Node_Id;
7857       Op2 : Node_Id) return Boolean
7858    is
7859       Target : Entity_Id;
7860
7861       function Is_Safe_Operand (Op : Node_Id) return Boolean;
7862       --  Operand is safe if it cannot overlap part of the target of the
7863       --  operation. If the operand and the target are identical, the operand
7864       --  is safe. The operand can be empty in the case of negation.
7865
7866       function Is_Unaliased (N : Node_Id) return Boolean;
7867       --  Check that N is a stand-alone entity
7868
7869       ------------------
7870       -- Is_Unaliased --
7871       ------------------
7872
7873       function Is_Unaliased (N : Node_Id) return Boolean is
7874       begin
7875          return
7876            Is_Entity_Name (N)
7877              and then No (Address_Clause (Entity (N)))
7878              and then No (Renamed_Object (Entity (N)));
7879       end Is_Unaliased;
7880
7881       ---------------------
7882       -- Is_Safe_Operand --
7883       ---------------------
7884
7885       function Is_Safe_Operand (Op : Node_Id) return Boolean is
7886       begin
7887          if No (Op) then
7888             return True;
7889
7890          elsif Is_Entity_Name (Op) then
7891             return Is_Unaliased (Op);
7892
7893          elsif Nkind (Op) = N_Indexed_Component
7894            or else Nkind (Op) = N_Selected_Component
7895          then
7896             return Is_Unaliased (Prefix (Op));
7897
7898          elsif Nkind (Op) = N_Slice then
7899             return
7900               Is_Unaliased (Prefix (Op))
7901                 and then Entity (Prefix (Op)) /= Target;
7902
7903          elsif Nkind (Op) = N_Op_Not then
7904             return Is_Safe_Operand (Right_Opnd (Op));
7905
7906          else
7907             return False;
7908          end if;
7909       end Is_Safe_Operand;
7910
7911       --  Start of processing for Is_Safe_In_Place_Array_Op
7912
7913    begin
7914       --  We skip this processing if the component size is not the
7915       --  same as a system storage unit (since at least for NOT
7916       --  this would cause problems).
7917
7918       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
7919          return False;
7920
7921       --  Cannot do in place stuff on Java_VM since cannot pass addresses
7922
7923       elsif Java_VM then
7924          return False;
7925
7926       --  Cannot do in place stuff if non-standard Boolean representation
7927
7928       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
7929          return False;
7930
7931       elsif not Is_Unaliased (Lhs) then
7932          return False;
7933       else
7934          Target := Entity (Lhs);
7935
7936          return
7937            Is_Safe_Operand (Op1)
7938              and then Is_Safe_Operand (Op2);
7939       end if;
7940    end Safe_In_Place_Array_Op;
7941
7942    -----------------------
7943    -- Tagged_Membership --
7944    -----------------------
7945
7946    --  There are two different cases to consider depending on whether
7947    --  the right operand is a class-wide type or not. If not we just
7948    --  compare the actual tag of the left expr to the target type tag:
7949    --
7950    --     Left_Expr.Tag = Right_Type'Tag;
7951    --
7952    --  If it is a class-wide type we use the RT function CW_Membership which
7953    --  is usually implemented by looking in the ancestor tables contained in
7954    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
7955
7956    function Tagged_Membership (N : Node_Id) return Node_Id is
7957       Left  : constant Node_Id    := Left_Opnd  (N);
7958       Right : constant Node_Id    := Right_Opnd (N);
7959       Loc   : constant Source_Ptr := Sloc (N);
7960
7961       Left_Type  : Entity_Id;
7962       Right_Type : Entity_Id;
7963       Obj_Tag    : Node_Id;
7964
7965    begin
7966       Left_Type  := Etype (Left);
7967       Right_Type := Etype (Right);
7968
7969       if Is_Class_Wide_Type (Left_Type) then
7970          Left_Type := Root_Type (Left_Type);
7971       end if;
7972
7973       Obj_Tag :=
7974         Make_Selected_Component (Loc,
7975           Prefix        => Relocate_Node (Left),
7976           Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
7977
7978       if Is_Class_Wide_Type (Right_Type) then
7979          return
7980            Make_DT_Access_Action (Left_Type,
7981              Action => CW_Membership,
7982              Args   => New_List (
7983                Obj_Tag,
7984                New_Reference_To (
7985                  Access_Disp_Table (Root_Type (Right_Type)), Loc)));
7986       else
7987          return
7988            Make_Op_Eq (Loc,
7989            Left_Opnd  => Obj_Tag,
7990            Right_Opnd =>
7991              New_Reference_To (Access_Disp_Table (Right_Type), Loc));
7992       end if;
7993
7994    end Tagged_Membership;
7995
7996    ------------------------------
7997    -- Unary_Op_Validity_Checks --
7998    ------------------------------
7999
8000    procedure Unary_Op_Validity_Checks (N : Node_Id) is
8001    begin
8002       if Validity_Checks_On and Validity_Check_Operands then
8003          Ensure_Valid (Right_Opnd (N));
8004       end if;
8005    end Unary_Op_Validity_Checks;
8006
8007 end Exp_Ch4;