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