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