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