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