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