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