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 (N, 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 (N, 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 (N, 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_Simple_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_Simple_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_Simple_Return_Statement (Loc,
1760                       Expression =>
1761                         New_Occurrence_Of (Standard_False, Loc)))),
1762
1763                 Handle_One_Dimension (1, First_Index (Ltyp)),
1764
1765                 Make_Simple_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_Simple_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
2645         (Declare_Stmts, Make_Simple_Return_Statement (Loc, Expression => R));
2646
2647       --  Construct the declare block
2648
2649       Declare_Block := Make_Block_Statement (Loc,
2650         Declarations               => Declare_Decls,
2651         Handled_Statement_Sequence =>
2652           Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
2653
2654       --  Construct the list of function statements
2655
2656       Func_Stmts := New_List (If_Stmt, Declare_Block);
2657
2658       --  Construct the function body
2659
2660       Func_Body :=
2661         Make_Subprogram_Body (Loc,
2662           Specification              => Func_Spec,
2663           Declarations               => Func_Decls,
2664           Handled_Statement_Sequence =>
2665             Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
2666
2667       --  Insert the newly generated function in the code. This is analyzed
2668       --  with all checks off, since we have completed all the checks.
2669
2670       --  Note that this does *not* fix the array concatenation bug when the
2671       --  low bound is Integer'first sibce that bug comes from the pointer
2672       --  dereferencing an unconstrained array. An there we need a constraint
2673       --  check to make sure the length of the concatenated array is ok. ???
2674
2675       Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
2676
2677       --  Construct list of arguments for the function call
2678
2679       Params := New_List;
2680       Operand  := First (Opnds);
2681       for I in 1 .. Nb_Opnds loop
2682          Append_To (Params, Relocate_Node (Operand));
2683          Next (Operand);
2684       end loop;
2685
2686       --  Insert the function call
2687
2688       Rewrite
2689         (Cnode,
2690          Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
2691
2692       Analyze_And_Resolve (Cnode, Base_Typ);
2693       Set_Is_Inlined (Func_Id);
2694    end Expand_Concatenate_Other;
2695
2696    -------------------------------
2697    -- Expand_Concatenate_String --
2698    -------------------------------
2699
2700    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
2701       Loc   : constant Source_Ptr := Sloc (Cnode);
2702       Opnd1 : constant Node_Id    := First (Opnds);
2703       Opnd2 : constant Node_Id    := Next (Opnd1);
2704       Typ1  : constant Entity_Id  := Base_Type (Etype (Opnd1));
2705       Typ2  : constant Entity_Id  := Base_Type (Etype (Opnd2));
2706
2707       R : RE_Id;
2708       --  RE_Id value for function to be called
2709
2710    begin
2711       --  In all cases, we build a call to a routine giving the list of
2712       --  arguments as the parameter list to the routine.
2713
2714       case List_Length (Opnds) is
2715          when 2 =>
2716             if Typ1 = Standard_Character then
2717                if Typ2 = Standard_Character then
2718                   R := RE_Str_Concat_CC;
2719
2720                else
2721                   pragma Assert (Typ2 = Standard_String);
2722                   R := RE_Str_Concat_CS;
2723                end if;
2724
2725             elsif Typ1 = Standard_String then
2726                if Typ2 = Standard_Character then
2727                   R := RE_Str_Concat_SC;
2728
2729                else
2730                   pragma Assert (Typ2 = Standard_String);
2731                   R := RE_Str_Concat;
2732                end if;
2733
2734             --  If we have anything other than Standard_Character or
2735             --  Standard_String, then we must have had a serious error
2736             --  earlier, so we just abandon the attempt at expansion.
2737
2738             else
2739                pragma Assert (Serious_Errors_Detected > 0);
2740                return;
2741             end if;
2742
2743          when 3 =>
2744             R := RE_Str_Concat_3;
2745
2746          when 4 =>
2747             R := RE_Str_Concat_4;
2748
2749          when 5 =>
2750             R := RE_Str_Concat_5;
2751
2752          when others =>
2753             R := RE_Null;
2754             raise Program_Error;
2755       end case;
2756
2757       --  Now generate the appropriate call
2758
2759       Rewrite (Cnode,
2760         Make_Function_Call (Sloc (Cnode),
2761           Name => New_Occurrence_Of (RTE (R), Loc),
2762           Parameter_Associations => Opnds));
2763
2764       Analyze_And_Resolve (Cnode, Standard_String);
2765
2766    exception
2767       when RE_Not_Available =>
2768          return;
2769    end Expand_Concatenate_String;
2770
2771    ------------------------
2772    -- Expand_N_Allocator --
2773    ------------------------
2774
2775    procedure Expand_N_Allocator (N : Node_Id) is
2776       PtrT  : constant Entity_Id  := Etype (N);
2777       Dtyp  : constant Entity_Id  := Designated_Type (PtrT);
2778       Etyp  : constant Entity_Id  := Etype (Expression (N));
2779       Loc   : constant Source_Ptr := Sloc (N);
2780       Desig : Entity_Id;
2781       Temp  : Entity_Id;
2782       Nod   : Node_Id;
2783
2784       procedure Complete_Coextension_Finalization;
2785       --  Generate finalization calls for all nested coextensions of N. This
2786       --  routine may allocate list controllers if necessary.
2787
2788       procedure Rewrite_Coextension (N : Node_Id);
2789       --  Static coextensions have the same lifetime as the entity they
2790       --  constrain. Such occurences can be rewritten as aliased objects
2791       --  and their unrestricted access used instead of the coextension.
2792
2793       ---------------------------------------
2794       -- Complete_Coextension_Finalization --
2795       ---------------------------------------
2796
2797       procedure Complete_Coextension_Finalization is
2798          Coext      : Node_Id;
2799          Coext_Elmt : Elmt_Id;
2800          Flist      : Node_Id;
2801          Ref        : Node_Id;
2802
2803          function Inside_A_Return_Statement (N : Node_Id) return Boolean;
2804          --  Determine whether node N is part of a return statement
2805
2806          function Needs_Initialization_Call (N : Node_Id) return Boolean;
2807          --  Determine whether node N is a subtype indicator allocator which
2808          --  asts a coextension. Such coextensions need initialization.
2809
2810          -------------------------------
2811          -- Inside_A_Return_Statement --
2812          -------------------------------
2813
2814          function Inside_A_Return_Statement (N : Node_Id) return Boolean is
2815             P : Node_Id;
2816
2817          begin
2818             P := Parent (N);
2819             while Present (P) loop
2820                if Nkind (P) = N_Extended_Return_Statement
2821                  or else Nkind (P) = N_Simple_Return_Statement
2822                then
2823                   return True;
2824
2825                --  Stop the traversal when we reach a subprogram body
2826
2827                elsif Nkind (P) = N_Subprogram_Body then
2828                   return False;
2829                end if;
2830
2831                P := Parent (P);
2832             end loop;
2833
2834             return False;
2835          end Inside_A_Return_Statement;
2836
2837          -------------------------------
2838          -- Needs_Initialization_Call --
2839          -------------------------------
2840
2841          function Needs_Initialization_Call (N : Node_Id) return Boolean is
2842             Obj_Decl : Node_Id;
2843
2844          begin
2845             if Nkind (N) = N_Explicit_Dereference
2846               and then Nkind (Prefix (N)) = N_Identifier
2847               and then Nkind (Parent (Entity (Prefix (N)))) =
2848                          N_Object_Declaration
2849             then
2850                Obj_Decl := Parent (Entity (Prefix (N)));
2851
2852                return
2853                  Present (Expression (Obj_Decl))
2854                    and then Nkind (Expression (Obj_Decl)) = N_Allocator
2855                    and then Nkind (Expression (Expression (Obj_Decl))) /=
2856                               N_Qualified_Expression;
2857             end if;
2858
2859             return False;
2860          end Needs_Initialization_Call;
2861
2862       --  Start of processing for Complete_Coextension_Finalization
2863
2864       begin
2865          --  When a coextension root is inside a return statement, we need to
2866          --  use the finalization chain of the function's scope. This does not
2867          --  apply for controlled named access types because in those cases we
2868          --  can use the finalization chain of the type itself.
2869
2870          if Inside_A_Return_Statement (N)
2871            and then
2872              (Ekind (PtrT) = E_Anonymous_Access_Type
2873                 or else
2874                   (Ekind (PtrT) = E_Access_Type
2875                      and then No (Associated_Final_Chain (PtrT))))
2876          then
2877             declare
2878                Decl    : Node_Id;
2879                Outer_S : Entity_Id;
2880                S       : Entity_Id := Current_Scope;
2881
2882             begin
2883                while Present (S) and then S /= Standard_Standard loop
2884                   if Ekind (S) = E_Function then
2885                      Outer_S := Scope (S);
2886
2887                      --  Retrieve the declaration of the body
2888
2889                      Decl := Parent (Parent (
2890                                Corresponding_Body (Parent (Parent (S)))));
2891                      exit;
2892                   end if;
2893
2894                   S := Scope (S);
2895                end loop;
2896
2897                --  Push the scope of the function body since we are inserting
2898                --  the list before the body, but we are currently in the body
2899                --  itself. Override the finalization list of PtrT since the
2900                --  finalization context is now different.
2901
2902                Push_Scope (Outer_S);
2903                Build_Final_List (Decl, PtrT);
2904                Pop_Scope;
2905             end;
2906
2907          --  The root allocator may not be controlled, but it still needs a
2908          --  finalization list for all nested coextensions.
2909
2910          elsif No (Associated_Final_Chain (PtrT)) then
2911             Build_Final_List (N, PtrT);
2912          end if;
2913
2914          Flist :=
2915            Make_Selected_Component (Loc,
2916              Prefix =>
2917                New_Reference_To (Associated_Final_Chain (PtrT), Loc),
2918              Selector_Name =>
2919                Make_Identifier (Loc, Name_F));
2920
2921          Coext_Elmt := First_Elmt (Coextensions (N));
2922          while Present (Coext_Elmt) loop
2923             Coext := Node (Coext_Elmt);
2924
2925             --  Generate:
2926             --    typ! (coext.all)
2927
2928             if Nkind (Coext) = N_Identifier then
2929                Ref := Make_Unchecked_Type_Conversion (Loc,
2930                         Subtype_Mark =>
2931                           New_Reference_To (Etype (Coext), Loc),
2932                         Expression =>
2933                           Make_Explicit_Dereference (Loc,
2934                             New_Copy_Tree (Coext)));
2935             else
2936                Ref := New_Copy_Tree (Coext);
2937             end if;
2938
2939             --  Generate:
2940             --    initialize (Ref)
2941             --    attach_to_final_list (Ref, Flist, 2)
2942
2943             if Needs_Initialization_Call (Coext) then
2944                Insert_Actions (N,
2945                  Make_Init_Call (
2946                    Ref         => Ref,
2947                    Typ         => Etype (Coext),
2948                    Flist_Ref   => Flist,
2949                    With_Attach => Make_Integer_Literal (Loc, Uint_2)));
2950
2951             --  Generate:
2952             --    attach_to_final_list (Ref, Flist, 2)
2953
2954             else
2955                Insert_Action (N,
2956                  Make_Attach_Call (
2957                    Obj_Ref     => Ref,
2958                    Flist_Ref   => New_Copy_Tree (Flist),
2959                    With_Attach => Make_Integer_Literal (Loc, Uint_2)));
2960             end if;
2961
2962             Next_Elmt (Coext_Elmt);
2963          end loop;
2964       end Complete_Coextension_Finalization;
2965
2966       -------------------------
2967       -- Rewrite_Coextension --
2968       -------------------------
2969
2970       procedure Rewrite_Coextension (N : Node_Id) is
2971          Temp : constant Node_Id :=
2972                   Make_Defining_Identifier (Loc,
2973                     New_Internal_Name ('C'));
2974
2975          --  Generate:
2976          --    Cnn : aliased Etyp;
2977
2978          Decl : constant Node_Id :=
2979                   Make_Object_Declaration (Loc,
2980                     Defining_Identifier => Temp,
2981                     Aliased_Present     => True,
2982                     Object_Definition   =>
2983                       New_Occurrence_Of (Etyp, Loc));
2984          Nod  : Node_Id;
2985
2986       begin
2987          if Nkind (Expression (N)) = N_Qualified_Expression then
2988             Set_Expression (Decl, Expression (Expression (N)));
2989          end if;
2990
2991          --  Find the proper insertion node for the declaration
2992
2993          Nod := Parent (N);
2994          while Present (Nod) loop
2995             exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call
2996               or else Nkind (Nod) = N_Procedure_Call_Statement
2997               or else Nkind (Nod) in N_Declaration;
2998             Nod := Parent (Nod);
2999          end loop;
3000
3001          Insert_Before (Nod, Decl);
3002          Analyze (Decl);
3003
3004          Rewrite (N,
3005            Make_Attribute_Reference (Loc,
3006              Prefix         => New_Occurrence_Of (Temp, Loc),
3007              Attribute_Name => Name_Unrestricted_Access));
3008
3009          Analyze_And_Resolve (N, PtrT);
3010       end Rewrite_Coextension;
3011
3012    --  Start of processing for Expand_N_Allocator
3013
3014    begin
3015       --  RM E.2.3(22). We enforce that the expected type of an allocator
3016       --  shall not be a remote access-to-class-wide-limited-private type
3017
3018       --  Why is this being done at expansion time, seems clearly wrong ???
3019
3020       Validate_Remote_Access_To_Class_Wide_Type (N);
3021
3022       --  Set the Storage Pool
3023
3024       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
3025
3026       if Present (Storage_Pool (N)) then
3027          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
3028             if VM_Target = No_VM then
3029                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
3030             end if;
3031
3032          elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
3033             Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
3034
3035          else
3036             Set_Procedure_To_Call (N,
3037               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
3038          end if;
3039       end if;
3040
3041       --  Under certain circumstances we can replace an allocator by an
3042       --  access to statically allocated storage. The conditions, as noted
3043       --  in AARM 3.10 (10c) are as follows:
3044
3045       --    Size and initial value is known at compile time
3046       --    Access type is access-to-constant
3047
3048       --  The allocator is not part of a constraint on a record component,
3049       --  because in that case the inserted actions are delayed until the
3050       --  record declaration is fully analyzed, which is too late for the
3051       --  analysis of the rewritten allocator.
3052
3053       if Is_Access_Constant (PtrT)
3054         and then Nkind (Expression (N)) = N_Qualified_Expression
3055         and then Compile_Time_Known_Value (Expression (Expression (N)))
3056         and then Size_Known_At_Compile_Time (Etype (Expression
3057                                                     (Expression (N))))
3058         and then not Is_Record_Type (Current_Scope)
3059       then
3060          --  Here we can do the optimization. For the allocator
3061
3062          --    new x'(y)
3063
3064          --  We insert an object declaration
3065
3066          --    Tnn : aliased x := y;
3067
3068          --  and replace the allocator by Tnn'Unrestricted_Access.
3069          --  Tnn is marked as requiring static allocation.
3070
3071          Temp :=
3072            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3073
3074          Desig := Subtype_Mark (Expression (N));
3075
3076          --  If context is constrained, use constrained subtype directly,
3077          --  so that the constant is not labelled as having a nomimally
3078          --  unconstrained subtype.
3079
3080          if Entity (Desig) = Base_Type (Dtyp) then
3081             Desig := New_Occurrence_Of (Dtyp, Loc);
3082          end if;
3083
3084          Insert_Action (N,
3085            Make_Object_Declaration (Loc,
3086              Defining_Identifier => Temp,
3087              Aliased_Present     => True,
3088              Constant_Present    => Is_Access_Constant (PtrT),
3089              Object_Definition   => Desig,
3090              Expression          => Expression (Expression (N))));
3091
3092          Rewrite (N,
3093            Make_Attribute_Reference (Loc,
3094              Prefix => New_Occurrence_Of (Temp, Loc),
3095              Attribute_Name => Name_Unrestricted_Access));
3096
3097          Analyze_And_Resolve (N, PtrT);
3098
3099          --  We set the variable as statically allocated, since we don't
3100          --  want it going on the stack of the current procedure!
3101
3102          Set_Is_Statically_Allocated (Temp);
3103          return;
3104       end if;
3105
3106       --  Same if the allocator is an access discriminant for a local object:
3107       --  instead of an allocator we create a local value and constrain the
3108       --  the enclosing object with the corresponding access attribute.
3109
3110       if Is_Static_Coextension (N) then
3111          Rewrite_Coextension (N);
3112          return;
3113       end if;
3114
3115       --  The current allocator creates an object which may contain nested
3116       --  coextensions. Use the current allocator's finalization list to
3117       --  generate finalization call for all nested coextensions.
3118
3119       if Is_Coextension_Root (N) then
3120          Complete_Coextension_Finalization;
3121       end if;
3122
3123       --  Handle case of qualified expression (other than optimization above)
3124
3125       if Nkind (Expression (N)) = N_Qualified_Expression then
3126          Expand_Allocator_Expression (N);
3127          return;
3128       end if;
3129
3130       --  If the allocator is for a type which requires initialization, and
3131       --  there is no initial value (i.e. operand is a subtype indication
3132       --  rather than a qualifed expression), then we must generate a call
3133       --  to the initialization routine. This is done using an expression
3134       --  actions node:
3135
3136       --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3137
3138       --  Here ptr_T is the pointer type for the allocator, and T is the
3139       --  subtype of the allocator. A special case arises if the designated
3140       --  type of the access type is a task or contains tasks. In this case
3141       --  the call to Init (Temp.all ...) is replaced by code that ensures
3142       --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3143       --  for details). In addition, if the type T is a task T, then the
3144       --  first argument to Init must be converted to the task record type.
3145
3146       declare
3147          T            : constant Entity_Id := Entity (Expression (N));
3148          Init         : Entity_Id;
3149          Arg1         : Node_Id;
3150          Args         : List_Id;
3151          Decls        : List_Id;
3152          Decl         : Node_Id;
3153          Discr        : Elmt_Id;
3154          Flist        : Node_Id;
3155          Temp_Decl    : Node_Id;
3156          Temp_Type    : Entity_Id;
3157          Attach_Level : Uint;
3158
3159       begin
3160          if No_Initialization (N) then
3161             null;
3162
3163          --  Case of no initialization procedure present
3164
3165          elsif not Has_Non_Null_Base_Init_Proc (T) then
3166
3167             --  Case of simple initialization required
3168
3169             if Needs_Simple_Initialization (T) then
3170                Rewrite (Expression (N),
3171                  Make_Qualified_Expression (Loc,
3172                    Subtype_Mark => New_Occurrence_Of (T, Loc),
3173                    Expression   => Get_Simple_Init_Val (T, Loc)));
3174
3175                Analyze_And_Resolve (Expression (Expression (N)), T);
3176                Analyze_And_Resolve (Expression (N), T);
3177                Set_Paren_Count     (Expression (Expression (N)), 1);
3178                Expand_N_Allocator  (N);
3179
3180             --  No initialization required
3181
3182             else
3183                null;
3184             end if;
3185
3186          --  Case of initialization procedure present, must be called
3187
3188          else
3189             Init := Base_Init_Proc (T);
3190             Nod  := N;
3191             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3192
3193             --  Construct argument list for the initialization routine call.
3194             --  The CPP constructor needs the address directly
3195
3196             if Is_CPP_Class (T) then
3197                Arg1 := New_Reference_To (Temp, Loc);
3198                Temp_Type := T;
3199
3200             else
3201                Arg1 := Make_Explicit_Dereference (Loc,
3202                          Prefix => New_Reference_To (Temp, Loc));
3203                Set_Assignment_OK (Arg1);
3204                Temp_Type := PtrT;
3205
3206                --  The initialization procedure expects a specific type. if
3207                --  the context is access to class wide, indicate that the
3208                --  object being allocated has the right specific type.
3209
3210                if Is_Class_Wide_Type (Dtyp) then
3211                   Arg1 := Unchecked_Convert_To (T, Arg1);
3212                end if;
3213             end if;
3214
3215             --  If designated type is a concurrent type or if it is private
3216             --  type whose definition is a concurrent type, the first argument
3217             --  in the Init routine has to be unchecked conversion to the
3218             --  corresponding record type. If the designated type is a derived
3219             --  type, we also convert the argument to its root type.
3220
3221             if Is_Concurrent_Type (T) then
3222                Arg1 :=
3223                  Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
3224
3225             elsif Is_Private_Type (T)
3226               and then Present (Full_View (T))
3227               and then Is_Concurrent_Type (Full_View (T))
3228             then
3229                Arg1 :=
3230                  Unchecked_Convert_To
3231                    (Corresponding_Record_Type (Full_View (T)), Arg1);
3232
3233             elsif Etype (First_Formal (Init)) /= Base_Type (T) then
3234                declare
3235                   Ftyp : constant Entity_Id := Etype (First_Formal (Init));
3236
3237                begin
3238                   Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
3239                   Set_Etype (Arg1, Ftyp);
3240                end;
3241             end if;
3242
3243             Args := New_List (Arg1);
3244
3245             --  For the task case, pass the Master_Id of the access type as
3246             --  the value of the _Master parameter, and _Chain as the value
3247             --  of the _Chain parameter (_Chain will be defined as part of
3248             --  the generated code for the allocator).
3249
3250             --  In Ada 2005, the context may be a function that returns an
3251             --  anonymous access type. In that case the Master_Id has been
3252             --  created when expanding the function declaration.
3253
3254             if Has_Task (T) then
3255                if No (Master_Id (Base_Type (PtrT))) then
3256
3257                   --  If we have a non-library level task with the restriction
3258                   --  No_Task_Hierarchy set, then no point in expanding.
3259
3260                   if not Is_Library_Level_Entity (T)
3261                     and then Restriction_Active (No_Task_Hierarchy)
3262                   then
3263                      return;
3264                   end if;
3265
3266                   --  The designated type was an incomplete type, and the
3267                   --  access type did not get expanded. Salvage it now.
3268
3269                   pragma Assert (Present (Parent (Base_Type (PtrT))));
3270                   Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT)));
3271                end if;
3272
3273                --  If the context of the allocator is a declaration or an
3274                --  assignment, we can generate a meaningful image for it,
3275                --  even though subsequent assignments might remove the
3276                --  connection between task and entity. We build this image
3277                --  when the left-hand side is a simple variable, a simple
3278                --  indexed assignment or a simple selected component.
3279
3280                if Nkind (Parent (N)) = N_Assignment_Statement then
3281                   declare
3282                      Nam : constant Node_Id := Name (Parent (N));
3283
3284                   begin
3285                      if Is_Entity_Name (Nam) then
3286                         Decls :=
3287                           Build_Task_Image_Decls (
3288                             Loc,
3289                               New_Occurrence_Of
3290                                 (Entity (Nam), Sloc (Nam)), T);
3291
3292                      elsif (Nkind (Nam) = N_Indexed_Component
3293                              or else Nkind (Nam) = N_Selected_Component)
3294                        and then Is_Entity_Name (Prefix (Nam))
3295                      then
3296                         Decls :=
3297                           Build_Task_Image_Decls
3298                             (Loc, Nam, Etype (Prefix (Nam)));
3299                      else
3300                         Decls := Build_Task_Image_Decls (Loc, T, T);
3301                      end if;
3302                   end;
3303
3304                elsif Nkind (Parent (N)) = N_Object_Declaration then
3305                   Decls :=
3306                     Build_Task_Image_Decls (
3307                        Loc, Defining_Identifier (Parent (N)), T);
3308
3309                else
3310                   Decls := Build_Task_Image_Decls (Loc, T, T);
3311                end if;
3312
3313                Append_To (Args,
3314                  New_Reference_To
3315                    (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
3316                Append_To (Args, Make_Identifier (Loc, Name_uChain));
3317
3318                Decl := Last (Decls);
3319                Append_To (Args,
3320                  New_Occurrence_Of (Defining_Identifier (Decl), Loc));
3321
3322             --  Has_Task is false, Decls not used
3323
3324             else
3325                Decls := No_List;
3326             end if;
3327
3328             --  Add discriminants if discriminated type
3329
3330             declare
3331                Dis : Boolean := False;
3332                Typ : Entity_Id;
3333
3334             begin
3335                if Has_Discriminants (T) then
3336                   Dis := True;
3337                   Typ := T;
3338
3339                elsif Is_Private_Type (T)
3340                  and then Present (Full_View (T))
3341                  and then Has_Discriminants (Full_View (T))
3342                then
3343                   Dis := True;
3344                   Typ := Full_View (T);
3345                end if;
3346
3347                if Dis then
3348                   --  If the allocated object will be constrained by the
3349                   --  default values for discriminants, then build a
3350                   --  subtype with those defaults, and change the allocated
3351                   --  subtype to that. Note that this happens in fewer
3352                   --  cases in Ada 2005 (AI-363).
3353
3354                   if not Is_Constrained (Typ)
3355                     and then Present (Discriminant_Default_Value
3356                                        (First_Discriminant (Typ)))
3357                     and then (Ada_Version < Ada_05
3358                                or else not Has_Constrained_Partial_View (Typ))
3359                   then
3360                      Typ := Build_Default_Subtype (Typ, N);
3361                      Set_Expression (N, New_Reference_To (Typ, Loc));
3362                   end if;
3363
3364                   Discr := First_Elmt (Discriminant_Constraint (Typ));
3365                   while Present (Discr) loop
3366                      Nod := Node (Discr);
3367                      Append (New_Copy_Tree (Node (Discr)), Args);
3368
3369                      --  AI-416: when the discriminant constraint is an
3370                      --  anonymous access type make sure an accessibility
3371                      --  check is inserted if necessary (3.10.2(22.q/2))
3372
3373                      if Ada_Version >= Ada_05
3374                        and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type
3375                      then
3376                         Apply_Accessibility_Check (Nod, Typ);
3377                      end if;
3378
3379                      Next_Elmt (Discr);
3380                   end loop;
3381                end if;
3382             end;
3383
3384             --  We set the allocator as analyzed so that when we analyze the
3385             --  expression actions node, we do not get an unwanted recursive
3386             --  expansion of the allocator expression.
3387
3388             Set_Analyzed (N, True);
3389             Nod := Relocate_Node (N);
3390
3391             --  Here is the transformation:
3392             --    input:  new T
3393             --    output: Temp : constant ptr_T := new T;
3394             --            Init (Temp.all, ...);
3395             --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
3396             --    <CTRL>  Initialize (Finalizable (Temp.all));
3397
3398             --  Here ptr_T is the pointer type for the allocator, and is the
3399             --  subtype of the allocator.
3400
3401             Temp_Decl :=
3402               Make_Object_Declaration (Loc,
3403                 Defining_Identifier => Temp,
3404                 Constant_Present    => True,
3405                 Object_Definition   => New_Reference_To (Temp_Type, Loc),
3406                 Expression          => Nod);
3407
3408             Set_Assignment_OK (Temp_Decl);
3409
3410             if Is_CPP_Class (T) then
3411                Set_Aliased_Present (Temp_Decl);
3412             end if;
3413
3414             Insert_Action (N, Temp_Decl, Suppress => All_Checks);
3415
3416             --  If the designated type is a task type or contains tasks,
3417             --  create block to activate created tasks, and insert
3418             --  declaration for Task_Image variable ahead of call.
3419
3420             if Has_Task (T) then
3421                declare
3422                   L   : constant List_Id := New_List;
3423                   Blk : Node_Id;
3424
3425                begin
3426                   Build_Task_Allocate_Block (L, Nod, Args);
3427                   Blk := Last (L);
3428
3429                   Insert_List_Before (First (Declarations (Blk)), Decls);
3430                   Insert_Actions (N, L);
3431                end;
3432
3433             else
3434                Insert_Action (N,
3435                  Make_Procedure_Call_Statement (Loc,
3436                    Name => New_Reference_To (Init, Loc),
3437                    Parameter_Associations => Args));
3438             end if;
3439
3440             if Controlled_Type (T) then
3441
3442                --  Postpone the generation of a finalization call for the
3443                --  current allocator if it acts as a coextension.
3444
3445                if Is_Dynamic_Coextension (N) then
3446                   if No (Coextensions (N)) then
3447                      Set_Coextensions (N, New_Elmt_List);
3448                   end if;
3449
3450                   Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
3451
3452                else
3453                   Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
3454
3455                   --  Anonymous access types created for access parameters
3456                   --  are attached to an explicitly constructed controller,
3457                   --  which ensures that they can be finalized properly, even
3458                   --  if their deallocation might not happen. The list
3459                   --  associated with the controller is doubly-linked. For
3460                   --  other anonymous access types, the object may end up
3461                   --  on the global final list which is singly-linked.
3462                   --  Work needed for access discriminants in Ada 2005 ???
3463
3464                   if Ekind (PtrT) = E_Anonymous_Access_Type
3465                        and then
3466                          Nkind (Associated_Node_For_Itype (PtrT))
3467                            not in N_Subprogram_Specification
3468                   then
3469                      Attach_Level := Uint_1;
3470                   else
3471                      Attach_Level := Uint_2;
3472                   end if;
3473
3474                   Insert_Actions (N,
3475                     Make_Init_Call (
3476                       Ref          => New_Copy_Tree (Arg1),
3477                       Typ          => T,
3478                       Flist_Ref    => Flist,
3479                       With_Attach  => Make_Integer_Literal
3480                                         (Loc, Attach_Level)));
3481                end if;
3482             end if;
3483
3484             if Is_CPP_Class (T) then
3485                Rewrite (N,
3486                  Make_Attribute_Reference (Loc,
3487                    Prefix => New_Reference_To (Temp, Loc),
3488                    Attribute_Name => Name_Unchecked_Access));
3489             else
3490                Rewrite (N, New_Reference_To (Temp, Loc));
3491             end if;
3492
3493             Analyze_And_Resolve (N, PtrT);
3494          end if;
3495       end;
3496
3497       --  Ada 2005 (AI-251): If the allocator is for a class-wide interface
3498       --  object that has been rewritten as a reference, we displace "this"
3499       --  to reference properly its secondary dispatch table.
3500
3501       if Nkind (N) = N_Identifier
3502         and then Is_Interface (Dtyp)
3503       then
3504          Displace_Allocator_Pointer (N);
3505       end if;
3506
3507    exception
3508       when RE_Not_Available =>
3509          return;
3510    end Expand_N_Allocator;
3511
3512    -----------------------
3513    -- Expand_N_And_Then --
3514    -----------------------
3515
3516    --  Expand into conditional expression if Actions present, and also deal
3517    --  with optimizing case of arguments being True or False.
3518
3519    procedure Expand_N_And_Then (N : Node_Id) is
3520       Loc     : constant Source_Ptr := Sloc (N);
3521       Typ     : constant Entity_Id  := Etype (N);
3522       Left    : constant Node_Id    := Left_Opnd (N);
3523       Right   : constant Node_Id    := Right_Opnd (N);
3524       Actlist : List_Id;
3525
3526    begin
3527       --  Deal with non-standard booleans
3528
3529       if Is_Boolean_Type (Typ) then
3530          Adjust_Condition (Left);
3531          Adjust_Condition (Right);
3532          Set_Etype (N, Standard_Boolean);
3533       end if;
3534
3535       --  Check for cases of left argument is True or False
3536
3537       if Nkind (Left) = N_Identifier then
3538
3539          --  If left argument is True, change (True and then Right) to Right.
3540          --  Any actions associated with Right will be executed unconditionally
3541          --  and can thus be inserted into the tree unconditionally.
3542
3543          if Entity (Left) = Standard_True then
3544             if Present (Actions (N)) then
3545                Insert_Actions (N, Actions (N));
3546             end if;
3547
3548             Rewrite (N, Right);
3549             Adjust_Result_Type (N, Typ);
3550             return;
3551
3552          --  If left argument is False, change (False and then Right) to False.
3553          --  In this case we can forget the actions associated with Right,
3554          --  since they will never be executed.
3555
3556          elsif Entity (Left) = Standard_False then
3557             Kill_Dead_Code (Right);
3558             Kill_Dead_Code (Actions (N));
3559             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3560             Adjust_Result_Type (N, Typ);
3561             return;
3562          end if;
3563       end if;
3564
3565       --  If Actions are present, we expand
3566
3567       --     left and then right
3568
3569       --  into
3570
3571       --     if left then right else false end
3572
3573       --  with the actions becoming the Then_Actions of the conditional
3574       --  expression. This conditional expression is then further expanded
3575       --  (and will eventually disappear)
3576
3577       if Present (Actions (N)) then
3578          Actlist := Actions (N);
3579          Rewrite (N,
3580             Make_Conditional_Expression (Loc,
3581               Expressions => New_List (
3582                 Left,
3583                 Right,
3584                 New_Occurrence_Of (Standard_False, Loc))));
3585
3586          Set_Then_Actions (N, Actlist);
3587          Analyze_And_Resolve (N, Standard_Boolean);
3588          Adjust_Result_Type (N, Typ);
3589          return;
3590       end if;
3591
3592       --  No actions present, check for cases of right argument True/False
3593
3594       if Nkind (Right) = N_Identifier then
3595
3596          --  Change (Left and then True) to Left. Note that we know there
3597          --  are no actions associated with the True operand, since we
3598          --  just checked for this case above.
3599
3600          if Entity (Right) = Standard_True then
3601             Rewrite (N, Left);
3602
3603          --  Change (Left and then False) to False, making sure to preserve
3604          --  any side effects associated with the Left operand.
3605
3606          elsif Entity (Right) = Standard_False then
3607             Remove_Side_Effects (Left);
3608             Rewrite
3609               (N, New_Occurrence_Of (Standard_False, Loc));
3610          end if;
3611       end if;
3612
3613       Adjust_Result_Type (N, Typ);
3614    end Expand_N_And_Then;
3615
3616    -------------------------------------
3617    -- Expand_N_Conditional_Expression --
3618    -------------------------------------
3619
3620    --  Expand into expression actions if then/else actions present
3621
3622    procedure Expand_N_Conditional_Expression (N : Node_Id) is
3623       Loc    : constant Source_Ptr := Sloc (N);
3624       Cond   : constant Node_Id    := First (Expressions (N));
3625       Thenx  : constant Node_Id    := Next (Cond);
3626       Elsex  : constant Node_Id    := Next (Thenx);
3627       Typ    : constant Entity_Id  := Etype (N);
3628       Cnn    : Entity_Id;
3629       New_If : Node_Id;
3630
3631    begin
3632       --  If either then or else actions are present, then given:
3633
3634       --     if cond then then-expr else else-expr end
3635
3636       --  we insert the following sequence of actions (using Insert_Actions):
3637
3638       --      Cnn : typ;
3639       --      if cond then
3640       --         <<then actions>>
3641       --         Cnn := then-expr;
3642       --      else
3643       --         <<else actions>>
3644       --         Cnn := else-expr
3645       --      end if;
3646
3647       --  and replace the conditional expression by a reference to Cnn
3648
3649       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
3650          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
3651
3652          New_If :=
3653            Make_Implicit_If_Statement (N,
3654              Condition => Relocate_Node (Cond),
3655
3656              Then_Statements => New_List (
3657                Make_Assignment_Statement (Sloc (Thenx),
3658                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
3659                  Expression => Relocate_Node (Thenx))),
3660
3661              Else_Statements => New_List (
3662                Make_Assignment_Statement (Sloc (Elsex),
3663                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
3664                  Expression => Relocate_Node (Elsex))));
3665
3666          Set_Assignment_OK (Name (First (Then_Statements (New_If))));
3667          Set_Assignment_OK (Name (First (Else_Statements (New_If))));
3668
3669          if Present (Then_Actions (N)) then
3670             Insert_List_Before
3671               (First (Then_Statements (New_If)), Then_Actions (N));
3672          end if;
3673
3674          if Present (Else_Actions (N)) then
3675             Insert_List_Before
3676               (First (Else_Statements (New_If)), Else_Actions (N));
3677          end if;
3678
3679          Rewrite (N, New_Occurrence_Of (Cnn, Loc));
3680
3681          Insert_Action (N,
3682            Make_Object_Declaration (Loc,
3683              Defining_Identifier => Cnn,
3684              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
3685
3686          Insert_Action (N, New_If);
3687          Analyze_And_Resolve (N, Typ);
3688       end if;
3689    end Expand_N_Conditional_Expression;
3690
3691    -----------------------------------
3692    -- Expand_N_Explicit_Dereference --
3693    -----------------------------------
3694
3695    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
3696    begin
3697       --  Insert explicit dereference call for the checked storage pool case
3698
3699       Insert_Dereference_Action (Prefix (N));
3700    end Expand_N_Explicit_Dereference;
3701
3702    -----------------
3703    -- Expand_N_In --
3704    -----------------
3705
3706    procedure Expand_N_In (N : Node_Id) is
3707       Loc    : constant Source_Ptr := Sloc (N);
3708       Rtyp   : constant Entity_Id  := Etype (N);
3709       Lop    : constant Node_Id    := Left_Opnd (N);
3710       Rop    : constant Node_Id    := Right_Opnd (N);
3711       Static : constant Boolean    := Is_OK_Static_Expression (N);
3712
3713       procedure Substitute_Valid_Check;
3714       --  Replaces node N by Lop'Valid. This is done when we have an explicit
3715       --  test for the left operand being in range of its subtype.
3716
3717       ----------------------------
3718       -- Substitute_Valid_Check --
3719       ----------------------------
3720
3721       procedure Substitute_Valid_Check is
3722       begin
3723          Rewrite (N,
3724            Make_Attribute_Reference (Loc,
3725              Prefix         => Relocate_Node (Lop),
3726              Attribute_Name => Name_Valid));
3727
3728          Analyze_And_Resolve (N, Rtyp);
3729
3730          Error_Msg_N ("?explicit membership test may be optimized away", N);
3731          Error_Msg_N ("\?use ''Valid attribute instead", N);
3732          return;
3733       end Substitute_Valid_Check;
3734
3735    --  Start of processing for Expand_N_In
3736
3737    begin
3738       --  Check case of explicit test for an expression in range of its
3739       --  subtype. This is suspicious usage and we replace it with a 'Valid
3740       --  test and give a warning.
3741
3742       if Is_Scalar_Type (Etype (Lop))
3743         and then Nkind (Rop) in N_Has_Entity
3744         and then Etype (Lop) = Entity (Rop)
3745         and then Comes_From_Source (N)
3746         and then VM_Target = No_VM
3747       then
3748          Substitute_Valid_Check;
3749          return;
3750       end if;
3751
3752       --  Do validity check on operands
3753
3754       if Validity_Checks_On and Validity_Check_Operands then
3755          Ensure_Valid (Left_Opnd (N));
3756          Validity_Check_Range (Right_Opnd (N));
3757       end if;
3758
3759       --  Case of explicit range
3760
3761       if Nkind (Rop) = N_Range then
3762          declare
3763             Lo : constant Node_Id := Low_Bound (Rop);
3764             Hi : constant Node_Id := High_Bound (Rop);
3765
3766             Ltyp : constant Entity_Id := Etype (Lop);
3767
3768             Lo_Orig : constant Node_Id := Original_Node (Lo);
3769             Hi_Orig : constant Node_Id := Original_Node (Hi);
3770
3771             Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
3772             Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
3773
3774             Warn1 : constant Boolean :=
3775                       Constant_Condition_Warnings
3776                         and then Comes_From_Source (N);
3777             --  This must be true for any of the optimization warnings, we
3778             --  clearly want to give them only for source with the flag on.
3779
3780             Warn2 : constant Boolean :=
3781                       Warn1
3782                         and then Nkind (Original_Node (Rop)) = N_Range
3783                         and then Is_Integer_Type (Etype (Lo));
3784             --  For the case where only one bound warning is elided, we also
3785             --  insist on an explicit range and an integer type. The reason is
3786             --  that the use of enumeration ranges including an end point is
3787             --  common, as is the use of a subtype name, one of whose bounds
3788             --  is the same as the type of the expression.
3789
3790          begin
3791             --  If test is explicit x'first .. x'last, replace by valid check
3792
3793             if Is_Scalar_Type (Ltyp)
3794               and then Nkind (Lo_Orig) = N_Attribute_Reference
3795               and then Attribute_Name (Lo_Orig) = Name_First
3796               and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
3797               and then Entity (Prefix (Lo_Orig)) = Ltyp
3798               and then Nkind (Hi_Orig) = N_Attribute_Reference
3799               and then Attribute_Name (Hi_Orig) = Name_Last
3800               and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
3801               and then Entity (Prefix (Hi_Orig)) = Ltyp
3802               and then Comes_From_Source (N)
3803               and then VM_Target = No_VM
3804             then
3805                Substitute_Valid_Check;
3806                return;
3807             end if;
3808
3809             --  If bounds of type are known at compile time, and the end points
3810             --  are known at compile time and identical, this is another case
3811             --  for substituting a valid test. We only do this for discrete
3812             --  types, since it won't arise in practice for float types.
3813
3814             if Comes_From_Source (N)
3815               and then Is_Discrete_Type (Ltyp)
3816               and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
3817               and then Compile_Time_Known_Value (Type_Low_Bound  (Ltyp))
3818               and then Compile_Time_Known_Value (Lo)
3819               and then Compile_Time_Known_Value (Hi)
3820               and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
3821               and then Expr_Value (Type_Low_Bound  (Ltyp)) = Expr_Value (Lo)
3822             then
3823                Substitute_Valid_Check;
3824                return;
3825             end if;
3826
3827             --  If we have an explicit range, do a bit of optimization based
3828             --  on range analysis (we may be able to kill one or both checks).
3829
3830             --  If either check is known to fail, replace result by False since
3831             --  the other check does not matter. Preserve the static flag for
3832             --  legality checks, because we are constant-folding beyond RM 4.9.
3833
3834             if Lcheck = LT or else Ucheck = GT then
3835                if Warn1 then
3836                   Error_Msg_N ("?range test optimized away", N);
3837                   Error_Msg_N ("\?value is known to be out of range", N);
3838                end if;
3839
3840                Rewrite (N,
3841                  New_Reference_To (Standard_False, Loc));
3842                Analyze_And_Resolve (N, Rtyp);
3843                Set_Is_Static_Expression (N, Static);
3844
3845                return;
3846
3847             --  If both checks are known to succeed, replace result
3848             --  by True, since we know we are in range.
3849
3850             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
3851                if Warn1 then
3852                   Error_Msg_N ("?range test optimized away", N);
3853                   Error_Msg_N ("\?value is known to be in range", N);
3854                end if;
3855
3856                Rewrite (N,
3857                  New_Reference_To (Standard_True, Loc));
3858                Analyze_And_Resolve (N, Rtyp);
3859                Set_Is_Static_Expression (N, Static);
3860
3861                return;
3862
3863             --  If lower bound check succeeds and upper bound check is not
3864             --  known to succeed or fail, then replace the range check with
3865             --  a comparison against the upper bound.
3866
3867             elsif Lcheck in Compare_GE then
3868                if Warn2 then
3869                   Error_Msg_N ("?lower bound test optimized away", Lo);
3870                   Error_Msg_N ("\?value is known to be in range", Lo);
3871                end if;
3872
3873                Rewrite (N,
3874                  Make_Op_Le (Loc,
3875                    Left_Opnd  => Lop,
3876                    Right_Opnd => High_Bound (Rop)));
3877                Analyze_And_Resolve (N, Rtyp);
3878
3879                return;
3880
3881             --  If upper bound check succeeds and lower bound check is not
3882             --  known to succeed or fail, then replace the range check with
3883             --  a comparison against the lower bound.
3884
3885             elsif Ucheck in Compare_LE then
3886                if Warn2 then
3887                   Error_Msg_N ("?upper bound test optimized away", Hi);
3888                   Error_Msg_N ("\?value is known to be in range", Hi);
3889                end if;
3890
3891                Rewrite (N,
3892                  Make_Op_Ge (Loc,
3893                    Left_Opnd  => Lop,
3894                    Right_Opnd => Low_Bound (Rop)));
3895                Analyze_And_Resolve (N, Rtyp);
3896
3897                return;
3898             end if;
3899          end;
3900
3901          --  For all other cases of an explicit range, nothing to be done
3902
3903          return;
3904
3905       --  Here right operand is a subtype mark
3906
3907       else
3908          declare
3909             Typ    : Entity_Id        := Etype (Rop);
3910             Is_Acc : constant Boolean := Is_Access_Type (Typ);
3911             Obj    : Node_Id          := Lop;
3912             Cond   : Node_Id          := Empty;
3913
3914          begin
3915             Remove_Side_Effects (Obj);
3916
3917             --  For tagged type, do tagged membership operation
3918
3919             if Is_Tagged_Type (Typ) then
3920
3921                --  No expansion will be performed when VM_Target, as the VM
3922                --  back-ends will handle the membership tests directly (tags
3923                --  are not explicitly represented in Java objects, so the
3924                --  normal tagged membership expansion is not what we want).
3925
3926                if VM_Target = No_VM then
3927                   Rewrite (N, Tagged_Membership (N));
3928                   Analyze_And_Resolve (N, Rtyp);
3929                end if;
3930
3931                return;
3932
3933             --  If type is scalar type, rewrite as x in t'first .. t'last.
3934             --  This reason we do this is that the bounds may have the wrong
3935             --  type if they come from the original type definition.
3936
3937             elsif Is_Scalar_Type (Typ) then
3938                Rewrite (Rop,
3939                  Make_Range (Loc,
3940                    Low_Bound =>
3941                      Make_Attribute_Reference (Loc,
3942                        Attribute_Name => Name_First,
3943                        Prefix => New_Reference_To (Typ, Loc)),
3944
3945                    High_Bound =>
3946                      Make_Attribute_Reference (Loc,
3947                        Attribute_Name => Name_Last,
3948                        Prefix => New_Reference_To (Typ, Loc))));
3949                Analyze_And_Resolve (N, Rtyp);
3950                return;
3951
3952             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
3953             --  a membership test if the subtype mark denotes a constrained
3954             --  Unchecked_Union subtype and the expression lacks inferable
3955             --  discriminants.
3956
3957             elsif Is_Unchecked_Union (Base_Type (Typ))
3958               and then Is_Constrained (Typ)
3959               and then not Has_Inferable_Discriminants (Lop)
3960             then
3961                Insert_Action (N,
3962                  Make_Raise_Program_Error (Loc,
3963                    Reason => PE_Unchecked_Union_Restriction));
3964
3965                --  Prevent Gigi from generating incorrect code by rewriting
3966                --  the test as a standard False.
3967
3968                Rewrite (N,
3969                  New_Occurrence_Of (Standard_False, Loc));
3970
3971                return;
3972             end if;
3973
3974             --  Here we have a non-scalar type
3975
3976             if Is_Acc then
3977                Typ := Designated_Type (Typ);
3978             end if;
3979
3980             if not Is_Constrained (Typ) then
3981                Rewrite (N,
3982                  New_Reference_To (Standard_True, Loc));
3983                Analyze_And_Resolve (N, Rtyp);
3984
3985             --  For the constrained array case, we have to check the
3986             --  subscripts for an exact match if the lengths are
3987             --  non-zero (the lengths must match in any case).
3988
3989             elsif Is_Array_Type (Typ) then
3990
3991                Check_Subscripts : declare
3992                   function Construct_Attribute_Reference
3993                     (E   : Node_Id;
3994                      Nam : Name_Id;
3995                      Dim : Nat) return Node_Id;
3996                   --  Build attribute reference E'Nam(Dim)
3997
3998                   -----------------------------------
3999                   -- Construct_Attribute_Reference --
4000                   -----------------------------------
4001
4002                   function Construct_Attribute_Reference
4003                     (E   : Node_Id;
4004                      Nam : Name_Id;
4005                      Dim : Nat) return Node_Id
4006                   is
4007                   begin
4008                      return
4009                        Make_Attribute_Reference (Loc,
4010                          Prefix => E,
4011                          Attribute_Name => Nam,
4012                          Expressions => New_List (
4013                            Make_Integer_Literal (Loc, Dim)));
4014                   end Construct_Attribute_Reference;
4015
4016                --  Start processing for Check_Subscripts
4017
4018                begin
4019                   for J in 1 .. Number_Dimensions (Typ) loop
4020                      Evolve_And_Then (Cond,
4021                        Make_Op_Eq (Loc,
4022                          Left_Opnd  =>
4023                            Construct_Attribute_Reference
4024                              (Duplicate_Subexpr_No_Checks (Obj),
4025                               Name_First, J),
4026                          Right_Opnd =>
4027                            Construct_Attribute_Reference
4028                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
4029
4030                      Evolve_And_Then (Cond,
4031                        Make_Op_Eq (Loc,
4032                          Left_Opnd  =>
4033                            Construct_Attribute_Reference
4034                              (Duplicate_Subexpr_No_Checks (Obj),
4035                               Name_Last, J),
4036                          Right_Opnd =>
4037                            Construct_Attribute_Reference
4038                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
4039                   end loop;
4040
4041                   if Is_Acc then
4042                      Cond :=
4043                        Make_Or_Else (Loc,
4044                          Left_Opnd =>
4045                            Make_Op_Eq (Loc,
4046                              Left_Opnd  => Obj,
4047                              Right_Opnd => Make_Null (Loc)),
4048                          Right_Opnd => Cond);
4049                   end if;
4050
4051                   Rewrite (N, Cond);
4052                   Analyze_And_Resolve (N, Rtyp);
4053                end Check_Subscripts;
4054
4055             --  These are the cases where constraint checks may be
4056             --  required, e.g. records with possible discriminants
4057
4058             else
4059                --  Expand the test into a series of discriminant comparisons.
4060                --  The expression that is built is the negation of the one
4061                --  that is used for checking discriminant constraints.
4062
4063                Obj := Relocate_Node (Left_Opnd (N));
4064
4065                if Has_Discriminants (Typ) then
4066                   Cond := Make_Op_Not (Loc,
4067                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
4068
4069                   if Is_Acc then
4070                      Cond := Make_Or_Else (Loc,
4071                        Left_Opnd =>
4072                          Make_Op_Eq (Loc,
4073                            Left_Opnd  => Obj,
4074                            Right_Opnd => Make_Null (Loc)),
4075                        Right_Opnd => Cond);
4076                   end if;
4077
4078                else
4079                   Cond := New_Occurrence_Of (Standard_True, Loc);
4080                end if;
4081
4082                Rewrite (N, Cond);
4083                Analyze_And_Resolve (N, Rtyp);
4084             end if;
4085          end;
4086       end if;
4087    end Expand_N_In;
4088
4089    --------------------------------
4090    -- Expand_N_Indexed_Component --
4091    --------------------------------
4092
4093    procedure Expand_N_Indexed_Component (N : Node_Id) is
4094       Loc : constant Source_Ptr := Sloc (N);
4095       Typ : constant Entity_Id  := Etype (N);
4096       P   : constant Node_Id    := Prefix (N);
4097       T   : constant Entity_Id  := Etype (P);
4098
4099    begin
4100       --  A special optimization, if we have an indexed component that
4101       --  is selecting from a slice, then we can eliminate the slice,
4102       --  since, for example, x (i .. j)(k) is identical to x(k). The
4103       --  only difference is the range check required by the slice. The
4104       --  range check for the slice itself has already been generated.
4105       --  The range check for the subscripting operation is ensured
4106       --  by converting the subject to the subtype of the slice.
4107
4108       --  This optimization not only generates better code, avoiding
4109       --  slice messing especially in the packed case, but more importantly
4110       --  bypasses some problems in handling this peculiar case, for
4111       --  example, the issue of dealing specially with object renamings.
4112
4113       if Nkind (P) = N_Slice then
4114          Rewrite (N,
4115            Make_Indexed_Component (Loc,
4116              Prefix => Prefix (P),
4117              Expressions => New_List (
4118                Convert_To
4119                  (Etype (First_Index (Etype (P))),
4120                   First (Expressions (N))))));
4121          Analyze_And_Resolve (N, Typ);
4122          return;
4123       end if;
4124
4125       --  If the prefix is an access type, then we unconditionally rewrite
4126       --  if as an explicit deference. This simplifies processing for several
4127       --  cases, including packed array cases and certain cases in which
4128       --  checks must be generated. We used to try to do this only when it
4129       --  was necessary, but it cleans up the code to do it all the time.
4130
4131       if Is_Access_Type (T) then
4132          Insert_Explicit_Dereference (P);
4133          Analyze_And_Resolve (P, Designated_Type (T));
4134       end if;
4135
4136       --  Generate index and validity checks
4137
4138       Generate_Index_Checks (N);
4139
4140       if Validity_Checks_On and then Validity_Check_Subscripts then
4141          Apply_Subscript_Validity_Checks (N);
4142       end if;
4143
4144       --  All done for the non-packed case
4145
4146       if not Is_Packed (Etype (Prefix (N))) then
4147          return;
4148       end if;
4149
4150       --  For packed arrays that are not bit-packed (i.e. the case of an array
4151       --  with one or more index types with a non-coniguous enumeration type),
4152       --  we can always use the normal packed element get circuit.
4153
4154       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
4155          Expand_Packed_Element_Reference (N);
4156          return;
4157       end if;
4158
4159       --  For a reference to a component of a bit packed array, we have to
4160       --  convert it to a reference to the corresponding Packed_Array_Type.
4161       --  We only want to do this for simple references, and not for:
4162
4163       --    Left side of assignment, or prefix of left side of assignment,
4164       --    or prefix of the prefix, to handle packed arrays of packed arrays,
4165       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4166
4167       --    Renaming objects in renaming associations
4168       --      This case is handled when a use of the renamed variable occurs
4169
4170       --    Actual parameters for a procedure call
4171       --      This case is handled in Exp_Ch6.Expand_Actuals
4172
4173       --    The second expression in a 'Read attribute reference
4174
4175       --    The prefix of an address or size attribute reference
4176
4177       --  The following circuit detects these exceptions
4178
4179       declare
4180          Child : Node_Id := N;
4181          Parnt : Node_Id := Parent (N);
4182
4183       begin
4184          loop
4185             if Nkind (Parnt) = N_Unchecked_Expression then
4186                null;
4187
4188             elsif Nkind (Parnt) = N_Object_Renaming_Declaration
4189               or else Nkind (Parnt) = N_Procedure_Call_Statement
4190               or else (Nkind (Parnt) = N_Parameter_Association
4191                         and then
4192                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
4193             then
4194                return;
4195
4196             elsif Nkind (Parnt) = N_Attribute_Reference
4197               and then (Attribute_Name (Parnt) = Name_Address
4198                          or else
4199                         Attribute_Name (Parnt) = Name_Size)
4200               and then Prefix (Parnt) = Child
4201             then
4202                return;
4203
4204             elsif Nkind (Parnt) = N_Assignment_Statement
4205               and then Name (Parnt) = Child
4206             then
4207                return;
4208
4209             --  If the expression is an index of an indexed component,
4210             --  it must be expanded regardless of context.
4211
4212             elsif Nkind (Parnt) = N_Indexed_Component
4213               and then Child /= Prefix (Parnt)
4214             then
4215                Expand_Packed_Element_Reference (N);
4216                return;
4217
4218             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
4219               and then Name (Parent (Parnt)) = Parnt
4220             then
4221                return;
4222
4223             elsif Nkind (Parnt) = N_Attribute_Reference
4224               and then Attribute_Name (Parnt) = Name_Read
4225               and then Next (First (Expressions (Parnt))) = Child
4226             then
4227                return;
4228
4229             elsif (Nkind (Parnt) = N_Indexed_Component
4230                     or else Nkind (Parnt) = N_Selected_Component)
4231                and then Prefix (Parnt) = Child
4232             then
4233                null;
4234
4235             else
4236                Expand_Packed_Element_Reference (N);
4237                return;
4238             end if;
4239
4240             --  Keep looking up tree for unchecked expression, or if we are
4241             --  the prefix of a possible assignment left side.
4242
4243             Child := Parnt;
4244             Parnt := Parent (Child);
4245          end loop;
4246       end;
4247    end Expand_N_Indexed_Component;
4248
4249    ---------------------
4250    -- Expand_N_Not_In --
4251    ---------------------
4252
4253    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
4254    --  can be done. This avoids needing to duplicate this expansion code.
4255
4256    procedure Expand_N_Not_In (N : Node_Id) is
4257       Loc : constant Source_Ptr := Sloc (N);
4258       Typ : constant Entity_Id  := Etype (N);
4259       Cfs : constant Boolean    := Comes_From_Source (N);
4260
4261    begin
4262       Rewrite (N,
4263         Make_Op_Not (Loc,
4264           Right_Opnd =>
4265             Make_In (Loc,
4266               Left_Opnd  => Left_Opnd (N),
4267               Right_Opnd => Right_Opnd (N))));
4268
4269       --  We want this to appear as coming from source if original does (see
4270       --  tranformations in Expand_N_In).
4271
4272       Set_Comes_From_Source (N, Cfs);
4273       Set_Comes_From_Source (Right_Opnd (N), Cfs);
4274
4275       --  Now analyze tranformed node
4276
4277       Analyze_And_Resolve (N, Typ);
4278    end Expand_N_Not_In;
4279
4280    -------------------
4281    -- Expand_N_Null --
4282    -------------------
4283
4284    --  The only replacement required is for the case of a null of type
4285    --  that is an access to protected subprogram. We represent such
4286    --  access values as a record, and so we must replace the occurrence
4287    --  of null by the equivalent record (with a null address and a null
4288    --  pointer in it), so that the backend creates the proper value.
4289
4290    procedure Expand_N_Null (N : Node_Id) is
4291       Loc : constant Source_Ptr := Sloc (N);
4292       Typ : constant Entity_Id  := Etype (N);
4293       Agg : Node_Id;
4294
4295    begin
4296       if Is_Access_Protected_Subprogram_Type (Typ) then
4297          Agg :=
4298            Make_Aggregate (Loc,
4299              Expressions => New_List (
4300                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
4301                Make_Null (Loc)));
4302
4303          Rewrite (N, Agg);
4304          Analyze_And_Resolve (N, Equivalent_Type (Typ));
4305
4306          --  For subsequent semantic analysis, the node must retain its
4307          --  type. Gigi in any case replaces this type by the corresponding
4308          --  record type before processing the node.
4309
4310          Set_Etype (N, Typ);
4311       end if;
4312
4313    exception
4314       when RE_Not_Available =>
4315          return;
4316    end Expand_N_Null;
4317
4318    ---------------------
4319    -- Expand_N_Op_Abs --
4320    ---------------------
4321
4322    procedure Expand_N_Op_Abs (N : Node_Id) is
4323       Loc  : constant Source_Ptr := Sloc (N);
4324       Expr : constant Node_Id := Right_Opnd (N);
4325
4326    begin
4327       Unary_Op_Validity_Checks (N);
4328
4329       --  Deal with software overflow checking
4330
4331       if not Backend_Overflow_Checks_On_Target
4332          and then Is_Signed_Integer_Type (Etype (N))
4333          and then Do_Overflow_Check (N)
4334       then
4335          --  The only case to worry about is when the argument is
4336          --  equal to the largest negative number, so what we do is
4337          --  to insert the check:
4338
4339          --     [constraint_error when Expr = typ'Base'First]
4340
4341          --  with the usual Duplicate_Subexpr use coding for expr
4342
4343          Insert_Action (N,
4344            Make_Raise_Constraint_Error (Loc,
4345              Condition =>
4346                Make_Op_Eq (Loc,
4347                  Left_Opnd  => Duplicate_Subexpr (Expr),
4348                  Right_Opnd =>
4349                    Make_Attribute_Reference (Loc,
4350                      Prefix =>
4351                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
4352                      Attribute_Name => Name_First)),
4353              Reason => CE_Overflow_Check_Failed));
4354       end if;
4355
4356       --  Vax floating-point types case
4357
4358       if Vax_Float (Etype (N)) then
4359          Expand_Vax_Arith (N);
4360       end if;
4361    end Expand_N_Op_Abs;
4362
4363    ---------------------
4364    -- Expand_N_Op_Add --
4365    ---------------------
4366
4367    procedure Expand_N_Op_Add (N : Node_Id) is
4368       Typ : constant Entity_Id := Etype (N);
4369
4370    begin
4371       Binary_Op_Validity_Checks (N);
4372
4373       --  N + 0 = 0 + N = N for integer types
4374
4375       if Is_Integer_Type (Typ) then
4376          if Compile_Time_Known_Value (Right_Opnd (N))
4377            and then Expr_Value (Right_Opnd (N)) = Uint_0
4378          then
4379             Rewrite (N, Left_Opnd (N));
4380             return;
4381
4382          elsif Compile_Time_Known_Value (Left_Opnd (N))
4383            and then Expr_Value (Left_Opnd (N)) = Uint_0
4384          then
4385             Rewrite (N, Right_Opnd (N));
4386             return;
4387          end if;
4388       end if;
4389
4390       --  Arithmetic overflow checks for signed integer/fixed point types
4391
4392       if Is_Signed_Integer_Type (Typ)
4393         or else Is_Fixed_Point_Type (Typ)
4394       then
4395          Apply_Arithmetic_Overflow_Check (N);
4396          return;
4397
4398       --  Vax floating-point types case
4399
4400       elsif Vax_Float (Typ) then
4401          Expand_Vax_Arith (N);
4402       end if;
4403    end Expand_N_Op_Add;
4404
4405    ---------------------
4406    -- Expand_N_Op_And --
4407    ---------------------
4408
4409    procedure Expand_N_Op_And (N : Node_Id) is
4410       Typ : constant Entity_Id := Etype (N);
4411
4412    begin
4413       Binary_Op_Validity_Checks (N);
4414
4415       if Is_Array_Type (Etype (N)) then
4416          Expand_Boolean_Operator (N);
4417
4418       elsif Is_Boolean_Type (Etype (N)) then
4419          Adjust_Condition (Left_Opnd (N));
4420          Adjust_Condition (Right_Opnd (N));
4421          Set_Etype (N, Standard_Boolean);
4422          Adjust_Result_Type (N, Typ);
4423       end if;
4424    end Expand_N_Op_And;
4425
4426    ------------------------
4427    -- Expand_N_Op_Concat --
4428    ------------------------
4429
4430    Max_Available_String_Operands : Int := -1;
4431    --  This is initialized the first time this routine is called. It records
4432    --  a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
4433    --  available in the run-time:
4434    --
4435    --    0  None available
4436    --    2  RE_Str_Concat available, RE_Str_Concat_3 not available
4437    --    3  RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
4438    --    4  RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
4439    --    5  All routines including RE_Str_Concat_5 available
4440
4441    Char_Concat_Available : Boolean;
4442    --  Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
4443    --  all three are available, False if any one of these is unavailable.
4444
4445    procedure Expand_N_Op_Concat (N : Node_Id) is
4446       Opnds : List_Id;
4447       --  List of operands to be concatenated
4448
4449       Opnd  : Node_Id;
4450       --  Single operand for concatenation
4451
4452       Cnode : Node_Id;
4453       --  Node which is to be replaced by the result of concatenating
4454       --  the nodes in the list Opnds.
4455
4456       Atyp : Entity_Id;
4457       --  Array type of concatenation result type
4458
4459       Ctyp : Entity_Id;
4460       --  Component type of concatenation represented by Cnode
4461
4462    begin
4463       --  Initialize global variables showing run-time status
4464
4465       if Max_Available_String_Operands < 1 then
4466
4467          --  In No_Run_Time mode, consider that no entities are available
4468
4469          --  This seems wrong, RTE_Available should return False for any entity
4470          --  that is not in the special No_Run_Time list of allowed entities???
4471
4472          if No_Run_Time_Mode then
4473             Max_Available_String_Operands := 0;
4474
4475          --  Otherwise see what routines are available and set max operand
4476          --  count according to the highest count available in the run-time.
4477
4478          elsif not RTE_Available (RE_Str_Concat) then
4479             Max_Available_String_Operands := 0;
4480
4481          elsif not RTE_Available (RE_Str_Concat_3) then
4482             Max_Available_String_Operands := 2;
4483
4484          elsif not RTE_Available (RE_Str_Concat_4) then
4485             Max_Available_String_Operands := 3;
4486
4487          elsif not RTE_Available (RE_Str_Concat_5) then
4488             Max_Available_String_Operands := 4;
4489
4490          else
4491             Max_Available_String_Operands := 5;
4492          end if;
4493
4494          Char_Concat_Available :=
4495            not No_Run_Time_Mode
4496              and then
4497            RTE_Available (RE_Str_Concat_CC)
4498              and then
4499            RTE_Available (RE_Str_Concat_CS)
4500              and then
4501            RTE_Available (RE_Str_Concat_SC);
4502       end if;
4503
4504       --  Ensure validity of both operands
4505
4506       Binary_Op_Validity_Checks (N);
4507
4508       --  If we are the left operand of a concatenation higher up the
4509       --  tree, then do nothing for now, since we want to deal with a
4510       --  series of concatenations as a unit.
4511
4512       if Nkind (Parent (N)) = N_Op_Concat
4513         and then N = Left_Opnd (Parent (N))
4514       then
4515          return;
4516       end if;
4517
4518       --  We get here with a concatenation whose left operand may be a
4519       --  concatenation itself with a consistent type. We need to process
4520       --  these concatenation operands from left to right, which means
4521       --  from the deepest node in the tree to the highest node.
4522
4523       Cnode := N;
4524       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
4525          Cnode := Left_Opnd (Cnode);
4526       end loop;
4527
4528       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
4529       --  nodes above, so now we process bottom up, doing the operations. We
4530       --  gather a string that is as long as possible up to five operands
4531
4532       --  The outer loop runs more than once if there are more than five
4533       --  concatenations of type Standard.String, the most we handle for
4534       --  this case, or if more than one concatenation type is involved.
4535
4536       Outer : loop
4537          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
4538          Set_Parent (Opnds, N);
4539
4540          --  The inner loop gathers concatenation operands. We gather any
4541          --  number of these in the non-string case, or if no concatenation
4542          --  routines are available for string (since in that case we will
4543          --  treat string like any other non-string case). Otherwise we only
4544          --  gather as many operands as can be handled by the available
4545          --  procedures in the run-time library (normally 5, but may be
4546          --  less for the configurable run-time case).
4547
4548          Inner : while Cnode /= N
4549                    and then (Base_Type (Etype (Cnode)) /= Standard_String
4550                                or else
4551                              Max_Available_String_Operands = 0
4552                                or else
4553                              List_Length (Opnds) <
4554                                                Max_Available_String_Operands)
4555                    and then Base_Type (Etype (Cnode)) =
4556                             Base_Type (Etype (Parent (Cnode)))
4557          loop
4558             Cnode := Parent (Cnode);
4559             Append (Right_Opnd (Cnode), Opnds);
4560          end loop Inner;
4561
4562          --  Here we process the collected operands. First we convert
4563          --  singleton operands to singleton aggregates. This is skipped
4564          --  however for the case of two operands of type String, since
4565          --  we have special routines for these cases.
4566
4567          Atyp := Base_Type (Etype (Cnode));
4568          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
4569
4570          if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
4571            or else not Char_Concat_Available
4572          then
4573             Opnd := First (Opnds);
4574             loop
4575                if Base_Type (Etype (Opnd)) = Ctyp then
4576                   Rewrite (Opnd,
4577                     Make_Aggregate (Sloc (Cnode),
4578                       Expressions => New_List (Relocate_Node (Opnd))));
4579                   Analyze_And_Resolve (Opnd, Atyp);
4580                end if;
4581
4582                Next (Opnd);
4583                exit when No (Opnd);
4584             end loop;
4585          end if;
4586
4587          --  Now call appropriate continuation routine
4588
4589          if Atyp = Standard_String
4590            and then Max_Available_String_Operands > 0
4591          then
4592             Expand_Concatenate_String (Cnode, Opnds);
4593          else
4594             Expand_Concatenate_Other (Cnode, Opnds);
4595          end if;
4596
4597          exit Outer when Cnode = N;
4598          Cnode := Parent (Cnode);
4599       end loop Outer;
4600    end Expand_N_Op_Concat;
4601
4602    ------------------------
4603    -- Expand_N_Op_Divide --
4604    ------------------------
4605
4606    procedure Expand_N_Op_Divide (N : Node_Id) is
4607       Loc   : constant Source_Ptr := Sloc (N);
4608       Lopnd : constant Node_Id    := Left_Opnd (N);
4609       Ropnd : constant Node_Id    := Right_Opnd (N);
4610       Ltyp  : constant Entity_Id  := Etype (Lopnd);
4611       Rtyp  : constant Entity_Id  := Etype (Ropnd);
4612       Typ   : Entity_Id           := Etype (N);
4613       Rknow : constant Boolean    := Is_Integer_Type (Typ)
4614                                        and then
4615                                          Compile_Time_Known_Value (Ropnd);
4616       Rval  : Uint;
4617
4618    begin
4619       Binary_Op_Validity_Checks (N);
4620
4621       if Rknow then
4622          Rval := Expr_Value (Ropnd);
4623       end if;
4624
4625       --  N / 1 = N for integer types
4626
4627       if Rknow and then Rval = Uint_1 then
4628          Rewrite (N, Lopnd);
4629          return;
4630       end if;
4631
4632       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
4633       --  Is_Power_Of_2_For_Shift is set means that we know that our left
4634       --  operand is an unsigned integer, as required for this to work.
4635
4636       if Nkind (Ropnd) = N_Op_Expon
4637         and then Is_Power_Of_2_For_Shift (Ropnd)
4638
4639       --  We cannot do this transformation in configurable run time mode if we
4640       --  have 64-bit --  integers and long shifts are not available.
4641
4642         and then
4643           (Esize (Ltyp) <= 32
4644              or else Support_Long_Shifts_On_Target)
4645       then
4646          Rewrite (N,
4647            Make_Op_Shift_Right (Loc,
4648              Left_Opnd  => Lopnd,
4649              Right_Opnd =>
4650                Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
4651          Analyze_And_Resolve (N, Typ);
4652          return;
4653       end if;
4654
4655       --  Do required fixup of universal fixed operation
4656
4657       if Typ = Universal_Fixed then
4658          Fixup_Universal_Fixed_Operation (N);
4659          Typ := Etype (N);
4660       end if;
4661
4662       --  Divisions with fixed-point results
4663
4664       if Is_Fixed_Point_Type (Typ) then
4665
4666          --  No special processing if Treat_Fixed_As_Integer is set,
4667          --  since from a semantic point of view such operations are
4668          --  simply integer operations and will be treated that way.
4669
4670          if not Treat_Fixed_As_Integer (N) then
4671             if Is_Integer_Type (Rtyp) then
4672                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
4673             else
4674                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
4675             end if;
4676          end if;
4677
4678       --  Other cases of division of fixed-point operands. Again we
4679       --  exclude the case where Treat_Fixed_As_Integer is set.
4680
4681       elsif (Is_Fixed_Point_Type (Ltyp) or else
4682              Is_Fixed_Point_Type (Rtyp))
4683         and then not Treat_Fixed_As_Integer (N)
4684       then
4685          if Is_Integer_Type (Typ) then
4686             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
4687          else
4688             pragma Assert (Is_Floating_Point_Type (Typ));
4689             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
4690          end if;
4691
4692       --  Mixed-mode operations can appear in a non-static universal
4693       --  context, in  which case the integer argument must be converted
4694       --  explicitly.
4695
4696       elsif Typ = Universal_Real
4697         and then Is_Integer_Type (Rtyp)
4698       then
4699          Rewrite (Ropnd,
4700            Convert_To (Universal_Real, Relocate_Node (Ropnd)));
4701
4702          Analyze_And_Resolve (Ropnd, Universal_Real);
4703
4704       elsif Typ = Universal_Real
4705         and then Is_Integer_Type (Ltyp)
4706       then
4707          Rewrite (Lopnd,
4708            Convert_To (Universal_Real, Relocate_Node (Lopnd)));
4709
4710          Analyze_And_Resolve (Lopnd, Universal_Real);
4711
4712       --  Non-fixed point cases, do integer zero divide and overflow checks
4713
4714       elsif Is_Integer_Type (Typ) then
4715          Apply_Divide_Check (N);
4716
4717          --  Check for 64-bit division available, or long shifts if the divisor
4718          --  is a small power of 2 (since such divides will be converted into
4719          --  long shifts.
4720
4721          if Esize (Ltyp) > 32
4722            and then not Support_64_Bit_Divides_On_Target
4723            and then
4724              (not Rknow
4725                 or else not Support_Long_Shifts_On_Target
4726                 or else (Rval /= Uint_2  and then
4727                          Rval /= Uint_4  and then
4728                          Rval /= Uint_8  and then
4729                          Rval /= Uint_16 and then
4730                          Rval /= Uint_32 and then
4731                          Rval /= Uint_64))
4732          then
4733             Error_Msg_CRT ("64-bit division", N);
4734          end if;
4735
4736       --  Deal with Vax_Float
4737
4738       elsif Vax_Float (Typ) then
4739          Expand_Vax_Arith (N);
4740          return;
4741       end if;
4742    end Expand_N_Op_Divide;
4743
4744    --------------------
4745    -- Expand_N_Op_Eq --
4746    --------------------
4747
4748    procedure Expand_N_Op_Eq (N : Node_Id) is
4749       Loc    : constant Source_Ptr := Sloc (N);
4750       Typ    : constant Entity_Id  := Etype (N);
4751       Lhs    : constant Node_Id    := Left_Opnd (N);
4752       Rhs    : constant Node_Id    := Right_Opnd (N);
4753       Bodies : constant List_Id    := New_List;
4754       A_Typ  : constant Entity_Id  := Etype (Lhs);
4755
4756       Typl    : Entity_Id := A_Typ;
4757       Op_Name : Entity_Id;
4758       Prim    : Elmt_Id;
4759
4760       procedure Build_Equality_Call (Eq : Entity_Id);
4761       --  If a constructed equality exists for the type or for its parent,
4762       --  build and analyze call, adding conversions if the operation is
4763       --  inherited.
4764
4765       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
4766       --  Determines whether a type has a subcompoment of an unconstrained
4767       --  Unchecked_Union subtype. Typ is a record type.
4768
4769       -------------------------
4770       -- Build_Equality_Call --
4771       -------------------------
4772
4773       procedure Build_Equality_Call (Eq : Entity_Id) is
4774          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
4775          L_Exp   : Node_Id := Relocate_Node (Lhs);
4776          R_Exp   : Node_Id := Relocate_Node (Rhs);
4777
4778       begin
4779          if Base_Type (Op_Type) /= Base_Type (A_Typ)
4780            and then not Is_Class_Wide_Type (A_Typ)
4781          then
4782             L_Exp := OK_Convert_To (Op_Type, L_Exp);
4783             R_Exp := OK_Convert_To (Op_Type, R_Exp);
4784          end if;
4785
4786          --  If we have an Unchecked_Union, we need to add the inferred
4787          --  discriminant values as actuals in the function call. At this
4788          --  point, the expansion has determined that both operands have
4789          --  inferable discriminants.
4790
4791          if Is_Unchecked_Union (Op_Type) then
4792             declare
4793                Lhs_Type      : constant Node_Id := Etype (L_Exp);
4794                Rhs_Type      : constant Node_Id := Etype (R_Exp);
4795                Lhs_Discr_Val : Node_Id;
4796                Rhs_Discr_Val : Node_Id;
4797
4798             begin
4799                --  Per-object constrained selected components require special
4800                --  attention. If the enclosing scope of the component is an
4801                --  Unchecked_Union, we cannot reference its discriminants
4802                --  directly. This is why we use the two extra parameters of
4803                --  the equality function of the enclosing Unchecked_Union.
4804
4805                --  type UU_Type (Discr : Integer := 0) is
4806                --     . . .
4807                --  end record;
4808                --  pragma Unchecked_Union (UU_Type);
4809
4810                --  1. Unchecked_Union enclosing record:
4811
4812                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
4813                --        . . .
4814                --        Comp : UU_Type (Discr);
4815                --        . . .
4816                --     end Enclosing_UU_Type;
4817                --     pragma Unchecked_Union (Enclosing_UU_Type);
4818
4819                --     Obj1 : Enclosing_UU_Type;
4820                --     Obj2 : Enclosing_UU_Type (1);
4821
4822                --     [. . .] Obj1 = Obj2 [. . .]
4823
4824                --     Generated code:
4825
4826                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
4827
4828                --  A and B are the formal parameters of the equality function
4829                --  of Enclosing_UU_Type. The function always has two extra
4830                --  formals to capture the inferred discriminant values.
4831
4832                --  2. Non-Unchecked_Union enclosing record:
4833
4834                --     type
4835                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
4836                --     is record
4837                --        . . .
4838                --        Comp : UU_Type (Discr);
4839                --        . . .
4840                --     end Enclosing_Non_UU_Type;
4841
4842                --     Obj1 : Enclosing_Non_UU_Type;
4843                --     Obj2 : Enclosing_Non_UU_Type (1);
4844
4845                --     ...  Obj1 = Obj2 ...
4846
4847                --     Generated code:
4848
4849                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
4850                --                        obj1.discr, obj2.discr)) then
4851
4852                --  In this case we can directly reference the discriminants of
4853                --  the enclosing record.
4854
4855                --  Lhs of equality
4856
4857                if Nkind (Lhs) = N_Selected_Component
4858                  and then Has_Per_Object_Constraint
4859                             (Entity (Selector_Name (Lhs)))
4860                then
4861                   --  Enclosing record is an Unchecked_Union, use formal A
4862
4863                   if Is_Unchecked_Union (Scope
4864                        (Entity (Selector_Name (Lhs))))
4865                   then
4866                      Lhs_Discr_Val :=
4867                        Make_Identifier (Loc,
4868                          Chars => Name_A);
4869
4870                   --  Enclosing record is of a non-Unchecked_Union type, it is
4871                   --  possible to reference the discriminant.
4872
4873                   else
4874                      Lhs_Discr_Val :=
4875                        Make_Selected_Component (Loc,
4876                          Prefix => Prefix (Lhs),
4877                          Selector_Name =>
4878                            New_Copy
4879                              (Get_Discriminant_Value
4880                                 (First_Discriminant (Lhs_Type),
4881                                  Lhs_Type,
4882                                  Stored_Constraint (Lhs_Type))));
4883                   end if;
4884
4885                --  Comment needed here ???
4886
4887                else
4888                   --  Infer the discriminant value
4889
4890                   Lhs_Discr_Val :=
4891                     New_Copy
4892                       (Get_Discriminant_Value
4893                          (First_Discriminant (Lhs_Type),
4894                           Lhs_Type,
4895                           Stored_Constraint (Lhs_Type)));
4896                end if;
4897
4898                --  Rhs of equality
4899
4900                if Nkind (Rhs) = N_Selected_Component
4901                  and then Has_Per_Object_Constraint
4902                             (Entity (Selector_Name (Rhs)))
4903                then
4904                   if Is_Unchecked_Union
4905                        (Scope (Entity (Selector_Name (Rhs))))
4906                   then
4907                      Rhs_Discr_Val :=
4908                        Make_Identifier (Loc,
4909                          Chars => Name_B);
4910
4911                   else
4912                      Rhs_Discr_Val :=
4913                        Make_Selected_Component (Loc,
4914                          Prefix => Prefix (Rhs),
4915                          Selector_Name =>
4916                            New_Copy (Get_Discriminant_Value (
4917                              First_Discriminant (Rhs_Type),
4918                              Rhs_Type,
4919                              Stored_Constraint (Rhs_Type))));
4920
4921                   end if;
4922                else
4923                   Rhs_Discr_Val :=
4924                     New_Copy (Get_Discriminant_Value (
4925                       First_Discriminant (Rhs_Type),
4926                       Rhs_Type,
4927                       Stored_Constraint (Rhs_Type)));
4928
4929                end if;
4930
4931                Rewrite (N,
4932                  Make_Function_Call (Loc,
4933                    Name => New_Reference_To (Eq, Loc),
4934                    Parameter_Associations => New_List (
4935                      L_Exp,
4936                      R_Exp,
4937                      Lhs_Discr_Val,
4938                      Rhs_Discr_Val)));
4939             end;
4940
4941          --  Normal case, not an unchecked union
4942
4943          else
4944             Rewrite (N,
4945               Make_Function_Call (Loc,
4946                 Name => New_Reference_To (Eq, Loc),
4947                 Parameter_Associations => New_List (L_Exp, R_Exp)));
4948          end if;
4949
4950          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
4951       end Build_Equality_Call;
4952
4953       ------------------------------------
4954       -- Has_Unconstrained_UU_Component --
4955       ------------------------------------
4956
4957       function Has_Unconstrained_UU_Component
4958         (Typ : Node_Id) return Boolean
4959       is
4960          Tdef  : constant Node_Id :=
4961                    Type_Definition (Declaration_Node (Base_Type (Typ)));
4962          Clist : Node_Id;
4963          Vpart : Node_Id;
4964
4965          function Component_Is_Unconstrained_UU
4966            (Comp : Node_Id) return Boolean;
4967          --  Determines whether the subtype of the component is an
4968          --  unconstrained Unchecked_Union.
4969
4970          function Variant_Is_Unconstrained_UU
4971            (Variant : Node_Id) return Boolean;
4972          --  Determines whether a component of the variant has an unconstrained
4973          --  Unchecked_Union subtype.
4974
4975          -----------------------------------
4976          -- Component_Is_Unconstrained_UU --
4977          -----------------------------------
4978
4979          function Component_Is_Unconstrained_UU
4980            (Comp : Node_Id) return Boolean
4981          is
4982          begin
4983             if Nkind (Comp) /= N_Component_Declaration then
4984                return False;
4985             end if;
4986
4987             declare
4988                Sindic : constant Node_Id :=
4989                           Subtype_Indication (Component_Definition (Comp));
4990
4991             begin
4992                --  Unconstrained nominal type. In the case of a constraint
4993                --  present, the node kind would have been N_Subtype_Indication.
4994
4995                if Nkind (Sindic) = N_Identifier then
4996                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
4997                end if;
4998
4999                return False;
5000             end;
5001          end Component_Is_Unconstrained_UU;
5002
5003          ---------------------------------
5004          -- Variant_Is_Unconstrained_UU --
5005          ---------------------------------
5006
5007          function Variant_Is_Unconstrained_UU
5008            (Variant : Node_Id) return Boolean
5009          is
5010             Clist : constant Node_Id := Component_List (Variant);
5011
5012          begin
5013             if Is_Empty_List (Component_Items (Clist)) then
5014                return False;
5015             end if;
5016
5017             --  We only need to test one component
5018
5019             declare
5020                Comp : Node_Id := First (Component_Items (Clist));
5021
5022             begin
5023                while Present (Comp) loop
5024                   if Component_Is_Unconstrained_UU (Comp) then
5025                      return True;
5026                   end if;
5027
5028                   Next (Comp);
5029                end loop;
5030             end;
5031
5032             --  None of the components withing the variant were of
5033             --  unconstrained Unchecked_Union type.
5034
5035             return False;
5036          end Variant_Is_Unconstrained_UU;
5037
5038       --  Start of processing for Has_Unconstrained_UU_Component
5039
5040       begin
5041          if Null_Present (Tdef) then
5042             return False;
5043          end if;
5044
5045          Clist := Component_List (Tdef);
5046          Vpart := Variant_Part (Clist);
5047
5048          --  Inspect available components
5049
5050          if Present (Component_Items (Clist)) then
5051             declare
5052                Comp : Node_Id := First (Component_Items (Clist));
5053
5054             begin
5055                while Present (Comp) loop
5056
5057                   --  One component is sufficent
5058
5059                   if Component_Is_Unconstrained_UU (Comp) then
5060                      return True;
5061                   end if;
5062
5063                   Next (Comp);
5064                end loop;
5065             end;
5066          end if;
5067
5068          --  Inspect available components withing variants
5069
5070          if Present (Vpart) then
5071             declare
5072                Variant : Node_Id := First (Variants (Vpart));
5073
5074             begin
5075                while Present (Variant) loop
5076
5077                   --  One component within a variant is sufficent
5078
5079                   if Variant_Is_Unconstrained_UU (Variant) then
5080                      return True;
5081                   end if;
5082
5083                   Next (Variant);
5084                end loop;
5085             end;
5086          end if;
5087
5088          --  Neither the available components, nor the components inside the
5089          --  variant parts were of an unconstrained Unchecked_Union subtype.
5090
5091          return False;
5092       end Has_Unconstrained_UU_Component;
5093
5094    --  Start of processing for Expand_N_Op_Eq
5095
5096    begin
5097       Binary_Op_Validity_Checks (N);
5098
5099       if Ekind (Typl) = E_Private_Type then
5100          Typl := Underlying_Type (Typl);
5101       elsif Ekind (Typl) = E_Private_Subtype then
5102          Typl := Underlying_Type (Base_Type (Typl));
5103       else
5104          null;
5105       end if;
5106
5107       --  It may happen in error situations that the underlying type is not
5108       --  set. The error will be detected later, here we just defend the
5109       --  expander code.
5110
5111       if No (Typl) then
5112          return;
5113       end if;
5114
5115       Typl := Base_Type (Typl);
5116
5117       --  Boolean types (requiring handling of non-standard case)
5118
5119       if Is_Boolean_Type (Typl) then
5120          Adjust_Condition (Left_Opnd (N));
5121          Adjust_Condition (Right_Opnd (N));
5122          Set_Etype (N, Standard_Boolean);
5123          Adjust_Result_Type (N, Typ);
5124
5125       --  Array types
5126
5127       elsif Is_Array_Type (Typl) then
5128
5129          --  If we are doing full validity checking, then expand out array
5130          --  comparisons to make sure that we check the array elements.
5131
5132          if Validity_Check_Operands then
5133             declare
5134                Save_Force_Validity_Checks : constant Boolean :=
5135                                               Force_Validity_Checks;
5136             begin
5137                Force_Validity_Checks := True;
5138                Rewrite (N,
5139                  Expand_Array_Equality
5140                   (N,
5141                    Relocate_Node (Lhs),
5142                    Relocate_Node (Rhs),
5143                    Bodies,
5144                    Typl));
5145                Insert_Actions (N, Bodies);
5146                Analyze_And_Resolve (N, Standard_Boolean);
5147                Force_Validity_Checks := Save_Force_Validity_Checks;
5148             end;
5149
5150          --  Packed case where both operands are known aligned
5151
5152          elsif Is_Bit_Packed_Array (Typl)
5153            and then not Is_Possibly_Unaligned_Object (Lhs)
5154            and then not Is_Possibly_Unaligned_Object (Rhs)
5155          then
5156             Expand_Packed_Eq (N);
5157
5158          --  Where the component type is elementary we can use a block bit
5159          --  comparison (if supported on the target) exception in the case
5160          --  of floating-point (negative zero issues require element by
5161          --  element comparison), and atomic types (where we must be sure
5162          --  to load elements independently) and possibly unaligned arrays.
5163
5164          elsif Is_Elementary_Type (Component_Type (Typl))
5165            and then not Is_Floating_Point_Type (Component_Type (Typl))
5166            and then not Is_Atomic (Component_Type (Typl))
5167            and then not Is_Possibly_Unaligned_Object (Lhs)
5168            and then not Is_Possibly_Unaligned_Object (Rhs)
5169            and then Support_Composite_Compare_On_Target
5170          then
5171             null;
5172
5173          --  For composite and floating-point cases, expand equality loop
5174          --  to make sure of using proper comparisons for tagged types,
5175          --  and correctly handling the floating-point case.
5176
5177          else
5178             Rewrite (N,
5179               Expand_Array_Equality
5180                 (N,
5181                  Relocate_Node (Lhs),
5182                  Relocate_Node (Rhs),
5183                  Bodies,
5184                  Typl));
5185             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5186             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5187          end if;
5188
5189       --  Record Types
5190
5191       elsif Is_Record_Type (Typl) then
5192
5193          --  For tagged types, use the primitive "="
5194
5195          if Is_Tagged_Type (Typl) then
5196
5197             --  No need to do anything else compiling under restriction
5198             --  No_Dispatching_Calls. During the semantic analysis we
5199             --  already notified such violation.
5200
5201             if Restriction_Active (No_Dispatching_Calls) then
5202                return;
5203             end if;
5204
5205             --  If this is derived from an untagged private type completed
5206             --  with a tagged type, it does not have a full view, so we
5207             --  use the primitive operations of the private type.
5208             --  This check should no longer be necessary when these
5209             --  types receive their full views ???
5210
5211             if Is_Private_Type (A_Typ)
5212               and then not Is_Tagged_Type (A_Typ)
5213               and then Is_Derived_Type (A_Typ)
5214               and then No (Full_View (A_Typ))
5215             then
5216                --  Search for equality operation, checking that the
5217                --  operands have the same type. Note that we must find
5218                --  a matching entry, or something is very wrong!
5219
5220                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
5221
5222                while Present (Prim) loop
5223                   exit when Chars (Node (Prim)) = Name_Op_Eq
5224                     and then Etype (First_Formal (Node (Prim))) =
5225                              Etype (Next_Formal (First_Formal (Node (Prim))))
5226                     and then
5227                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5228
5229                   Next_Elmt (Prim);
5230                end loop;
5231
5232                pragma Assert (Present (Prim));
5233                Op_Name := Node (Prim);
5234
5235             --  Find the type's predefined equality or an overriding
5236             --  user-defined equality. The reason for not simply calling
5237             --  Find_Prim_Op here is that there may be a user-defined
5238             --  overloaded equality op that precedes the equality that
5239             --  we want, so we have to explicitly search (e.g., there
5240             --  could be an equality with two different parameter types).
5241
5242             else
5243                if Is_Class_Wide_Type (Typl) then
5244                   Typl := Root_Type (Typl);
5245                end if;
5246
5247                Prim := First_Elmt (Primitive_Operations (Typl));
5248                while Present (Prim) loop
5249                   exit when Chars (Node (Prim)) = Name_Op_Eq
5250                     and then Etype (First_Formal (Node (Prim))) =
5251                              Etype (Next_Formal (First_Formal (Node (Prim))))
5252                     and then
5253                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5254
5255                   Next_Elmt (Prim);
5256                end loop;
5257
5258                pragma Assert (Present (Prim));
5259                Op_Name := Node (Prim);
5260             end if;
5261
5262             Build_Equality_Call (Op_Name);
5263
5264          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
5265          --  predefined equality operator for a type which has a subcomponent
5266          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
5267
5268          elsif Has_Unconstrained_UU_Component (Typl) then
5269             Insert_Action (N,
5270               Make_Raise_Program_Error (Loc,
5271                 Reason => PE_Unchecked_Union_Restriction));
5272
5273             --  Prevent Gigi from generating incorrect code by rewriting the
5274             --  equality as a standard False.
5275
5276             Rewrite (N,
5277               New_Occurrence_Of (Standard_False, Loc));
5278
5279          elsif Is_Unchecked_Union (Typl) then
5280
5281             --  If we can infer the discriminants of the operands, we make a
5282             --  call to the TSS equality function.
5283
5284             if Has_Inferable_Discriminants (Lhs)
5285                  and then
5286                Has_Inferable_Discriminants (Rhs)
5287             then
5288                Build_Equality_Call
5289                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
5290
5291             else
5292                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
5293                --  the predefined equality operator for an Unchecked_Union type
5294                --  if either of the operands lack inferable discriminants.
5295
5296                Insert_Action (N,
5297                  Make_Raise_Program_Error (Loc,
5298                    Reason => PE_Unchecked_Union_Restriction));
5299
5300                --  Prevent Gigi from generating incorrect code by rewriting
5301                --  the equality as a standard False.
5302
5303                Rewrite (N,
5304                  New_Occurrence_Of (Standard_False, Loc));
5305
5306             end if;
5307
5308          --  If a type support function is present (for complex cases), use it
5309
5310          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
5311             Build_Equality_Call
5312               (TSS (Root_Type (Typl), TSS_Composite_Equality));
5313
5314          --  Otherwise expand the component by component equality. Note that
5315          --  we never use block-bit coparisons for records, because of the
5316          --  problems with gaps. The backend will often be able to recombine
5317          --  the separate comparisons that we generate here.
5318
5319          else
5320             Remove_Side_Effects (Lhs);
5321             Remove_Side_Effects (Rhs);
5322             Rewrite (N,
5323               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
5324
5325             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5326             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5327          end if;
5328       end if;
5329
5330       --  Test if result is known at compile time
5331
5332       Rewrite_Comparison (N);
5333
5334       --  If we still have comparison for Vax_Float, process it
5335
5336       if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare  then
5337          Expand_Vax_Comparison (N);
5338          return;
5339       end if;
5340    end Expand_N_Op_Eq;
5341
5342    -----------------------
5343    -- Expand_N_Op_Expon --
5344    -----------------------
5345
5346    procedure Expand_N_Op_Expon (N : Node_Id) is
5347       Loc    : constant Source_Ptr := Sloc (N);
5348       Typ    : constant Entity_Id  := Etype (N);
5349       Rtyp   : constant Entity_Id  := Root_Type (Typ);
5350       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
5351       Bastyp : constant Node_Id    := Etype (Base);
5352       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
5353       Exptyp : constant Entity_Id  := Etype (Exp);
5354       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
5355       Expv   : Uint;
5356       Xnode  : Node_Id;
5357       Temp   : Node_Id;
5358       Rent   : RE_Id;
5359       Ent    : Entity_Id;
5360       Etyp   : Entity_Id;
5361
5362    begin
5363       Binary_Op_Validity_Checks (N);
5364
5365       --  If either operand is of a private type, then we have the use of
5366       --  an intrinsic operator, and we get rid of the privateness, by using
5367       --  root types of underlying types for the actual operation. Otherwise
5368       --  the private types will cause trouble if we expand multiplications
5369       --  or shifts etc. We also do this transformation if the result type
5370       --  is different from the base type.
5371
5372       if Is_Private_Type (Etype (Base))
5373            or else
5374          Is_Private_Type (Typ)
5375            or else
5376          Is_Private_Type (Exptyp)
5377            or else
5378          Rtyp /= Root_Type (Bastyp)
5379       then
5380          declare
5381             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
5382             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
5383
5384          begin
5385             Rewrite (N,
5386               Unchecked_Convert_To (Typ,
5387                 Make_Op_Expon (Loc,
5388                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
5389                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
5390             Analyze_And_Resolve (N, Typ);
5391             return;
5392          end;
5393       end if;
5394
5395       --  Test for case of known right argument
5396
5397       if Compile_Time_Known_Value (Exp) then
5398          Expv := Expr_Value (Exp);
5399
5400          --  We only fold small non-negative exponents. You might think we
5401          --  could fold small negative exponents for the real case, but we
5402          --  can't because we are required to raise Constraint_Error for
5403          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
5404          --  See ACVC test C4A012B.
5405
5406          if Expv >= 0 and then Expv <= 4 then
5407
5408             --  X ** 0 = 1 (or 1.0)
5409
5410             if Expv = 0 then
5411                if Ekind (Typ) in Integer_Kind then
5412                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
5413                else
5414                   Xnode := Make_Real_Literal (Loc, Ureal_1);
5415                end if;
5416
5417             --  X ** 1 = X
5418
5419             elsif Expv = 1 then
5420                Xnode := Base;
5421
5422             --  X ** 2 = X * X
5423
5424             elsif Expv = 2 then
5425                Xnode :=
5426                  Make_Op_Multiply (Loc,
5427                    Left_Opnd  => Duplicate_Subexpr (Base),
5428                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
5429
5430             --  X ** 3 = X * X * X
5431
5432             elsif Expv = 3 then
5433                Xnode :=
5434                  Make_Op_Multiply (Loc,
5435                    Left_Opnd =>
5436                      Make_Op_Multiply (Loc,
5437                        Left_Opnd  => Duplicate_Subexpr (Base),
5438                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
5439                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
5440
5441             --  X ** 4  ->
5442             --    En : constant base'type := base * base;
5443             --    ...
5444             --    En * En
5445
5446             else -- Expv = 4
5447                Temp :=
5448                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
5449
5450                Insert_Actions (N, New_List (
5451                  Make_Object_Declaration (Loc,
5452                    Defining_Identifier => Temp,
5453                    Constant_Present    => True,
5454                    Object_Definition   => New_Reference_To (Typ, Loc),
5455                    Expression =>
5456                      Make_Op_Multiply (Loc,
5457                        Left_Opnd  => Duplicate_Subexpr (Base),
5458                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
5459
5460                Xnode :=
5461                  Make_Op_Multiply (Loc,
5462                    Left_Opnd  => New_Reference_To (Temp, Loc),
5463                    Right_Opnd => New_Reference_To (Temp, Loc));
5464             end if;
5465
5466             Rewrite (N, Xnode);
5467             Analyze_And_Resolve (N, Typ);
5468             return;
5469          end if;
5470       end if;
5471
5472       --  Case of (2 ** expression) appearing as an argument of an integer
5473       --  multiplication, or as the right argument of a division of a non-
5474       --  negative integer. In such cases we leave the node untouched, setting
5475       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
5476       --  of the higher level node converts it into a shift.
5477
5478       if Nkind (Base) = N_Integer_Literal
5479         and then Intval (Base) = 2
5480         and then Is_Integer_Type (Root_Type (Exptyp))
5481         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
5482         and then Is_Unsigned_Type (Exptyp)
5483         and then not Ovflo
5484         and then Nkind (Parent (N)) in N_Binary_Op
5485       then
5486          declare
5487             P : constant Node_Id := Parent (N);
5488             L : constant Node_Id := Left_Opnd (P);
5489             R : constant Node_Id := Right_Opnd (P);
5490
5491          begin
5492             if (Nkind (P) = N_Op_Multiply
5493                  and then
5494                    ((Is_Integer_Type (Etype (L)) and then R = N)
5495                        or else
5496                     (Is_Integer_Type (Etype (R)) and then L = N))
5497                  and then not Do_Overflow_Check (P))
5498
5499               or else
5500                 (Nkind (P) = N_Op_Divide
5501                   and then Is_Integer_Type (Etype (L))
5502                   and then Is_Unsigned_Type (Etype (L))
5503                   and then R = N
5504                   and then not Do_Overflow_Check (P))
5505             then
5506                Set_Is_Power_Of_2_For_Shift (N);
5507                return;
5508             end if;
5509          end;
5510       end if;
5511
5512       --  Fall through if exponentiation must be done using a runtime routine
5513
5514       --  First deal with modular case
5515
5516       if Is_Modular_Integer_Type (Rtyp) then
5517
5518          --  Non-binary case, we call the special exponentiation routine for
5519          --  the non-binary case, converting the argument to Long_Long_Integer
5520          --  and passing the modulus value. Then the result is converted back
5521          --  to the base type.
5522
5523          if Non_Binary_Modulus (Rtyp) then
5524             Rewrite (N,
5525               Convert_To (Typ,
5526                 Make_Function_Call (Loc,
5527                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
5528                   Parameter_Associations => New_List (
5529                     Convert_To (Standard_Integer, Base),
5530                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
5531                     Exp))));
5532
5533          --  Binary case, in this case, we call one of two routines, either
5534          --  the unsigned integer case, or the unsigned long long integer
5535          --  case, with a final "and" operation to do the required mod.
5536
5537          else
5538             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
5539                Ent := RTE (RE_Exp_Unsigned);
5540             else
5541                Ent := RTE (RE_Exp_Long_Long_Unsigned);
5542             end if;
5543
5544             Rewrite (N,
5545               Convert_To (Typ,
5546                 Make_Op_And (Loc,
5547                   Left_Opnd =>
5548                     Make_Function_Call (Loc,
5549                       Name => New_Reference_To (Ent, Loc),
5550                       Parameter_Associations => New_List (
5551                         Convert_To (Etype (First_Formal (Ent)), Base),
5552                         Exp)),
5553                    Right_Opnd =>
5554                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
5555
5556          end if;
5557
5558          --  Common exit point for modular type case
5559
5560          Analyze_And_Resolve (N, Typ);
5561          return;
5562
5563       --  Signed integer cases, done using either Integer or Long_Long_Integer.
5564       --  It is not worth having routines for Short_[Short_]Integer, since for
5565       --  most machines it would not help, and it would generate more code that
5566       --  might need certification when a certified run time is required.
5567
5568       --  In the integer cases, we have two routines, one for when overflow
5569       --  checks are required, and one when they are not required, since there
5570       --  is a real gain in omitting checks on many machines.
5571
5572       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
5573         or else (Rtyp = Base_Type (Standard_Long_Integer)
5574                    and then
5575                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
5576         or else (Rtyp = Universal_Integer)
5577       then
5578          Etyp := Standard_Long_Long_Integer;
5579
5580          if Ovflo then
5581             Rent := RE_Exp_Long_Long_Integer;
5582          else
5583             Rent := RE_Exn_Long_Long_Integer;
5584          end if;
5585
5586       elsif Is_Signed_Integer_Type (Rtyp) then
5587          Etyp := Standard_Integer;
5588
5589          if Ovflo then
5590             Rent := RE_Exp_Integer;
5591          else
5592             Rent := RE_Exn_Integer;
5593          end if;
5594
5595       --  Floating-point cases, always done using Long_Long_Float. We do not
5596       --  need separate routines for the overflow case here, since in the case
5597       --  of floating-point, we generate infinities anyway as a rule (either
5598       --  that or we automatically trap overflow), and if there is an infinity
5599       --  generated and a range check is required, the check will fail anyway.
5600
5601       else
5602          pragma Assert (Is_Floating_Point_Type (Rtyp));
5603          Etyp := Standard_Long_Long_Float;
5604          Rent := RE_Exn_Long_Long_Float;
5605       end if;
5606
5607       --  Common processing for integer cases and floating-point cases.
5608       --  If we are in the right type, we can call runtime routine directly
5609
5610       if Typ = Etyp
5611         and then Rtyp /= Universal_Integer
5612         and then Rtyp /= Universal_Real
5613       then
5614          Rewrite (N,
5615            Make_Function_Call (Loc,
5616              Name => New_Reference_To (RTE (Rent), Loc),
5617              Parameter_Associations => New_List (Base, Exp)));
5618
5619       --  Otherwise we have to introduce conversions (conversions are also
5620       --  required in the universal cases, since the runtime routine is
5621       --  typed using one of the standard types.
5622
5623       else
5624          Rewrite (N,
5625            Convert_To (Typ,
5626              Make_Function_Call (Loc,
5627                Name => New_Reference_To (RTE (Rent), Loc),
5628                Parameter_Associations => New_List (
5629                  Convert_To (Etyp, Base),
5630                  Exp))));
5631       end if;
5632
5633       Analyze_And_Resolve (N, Typ);
5634       return;
5635
5636    exception
5637       when RE_Not_Available =>
5638          return;
5639    end Expand_N_Op_Expon;
5640
5641    --------------------
5642    -- Expand_N_Op_Ge --
5643    --------------------
5644
5645    procedure Expand_N_Op_Ge (N : Node_Id) is
5646       Typ  : constant Entity_Id := Etype (N);
5647       Op1  : constant Node_Id   := Left_Opnd (N);
5648       Op2  : constant Node_Id   := Right_Opnd (N);
5649       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5650
5651    begin
5652       Binary_Op_Validity_Checks (N);
5653
5654       if Is_Array_Type (Typ1) then
5655          Expand_Array_Comparison (N);
5656          return;
5657       end if;
5658
5659       if Is_Boolean_Type (Typ1) then
5660          Adjust_Condition (Op1);
5661          Adjust_Condition (Op2);
5662          Set_Etype (N, Standard_Boolean);
5663          Adjust_Result_Type (N, Typ);
5664       end if;
5665
5666       Rewrite_Comparison (N);
5667
5668       --  If we still have comparison, and Vax_Float type, process it
5669
5670       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5671          Expand_Vax_Comparison (N);
5672          return;
5673       end if;
5674    end Expand_N_Op_Ge;
5675
5676    --------------------
5677    -- Expand_N_Op_Gt --
5678    --------------------
5679
5680    procedure Expand_N_Op_Gt (N : Node_Id) is
5681       Typ  : constant Entity_Id := Etype (N);
5682       Op1  : constant Node_Id   := Left_Opnd (N);
5683       Op2  : constant Node_Id   := Right_Opnd (N);
5684       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5685
5686    begin
5687       Binary_Op_Validity_Checks (N);
5688
5689       if Is_Array_Type (Typ1) then
5690          Expand_Array_Comparison (N);
5691          return;
5692       end if;
5693
5694       if Is_Boolean_Type (Typ1) then
5695          Adjust_Condition (Op1);
5696          Adjust_Condition (Op2);
5697          Set_Etype (N, Standard_Boolean);
5698          Adjust_Result_Type (N, Typ);
5699       end if;
5700
5701       Rewrite_Comparison (N);
5702
5703       --  If we still have comparison, and Vax_Float type, process it
5704
5705       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5706          Expand_Vax_Comparison (N);
5707          return;
5708       end if;
5709    end Expand_N_Op_Gt;
5710
5711    --------------------
5712    -- Expand_N_Op_Le --
5713    --------------------
5714
5715    procedure Expand_N_Op_Le (N : Node_Id) is
5716       Typ  : constant Entity_Id := Etype (N);
5717       Op1  : constant Node_Id   := Left_Opnd (N);
5718       Op2  : constant Node_Id   := Right_Opnd (N);
5719       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5720
5721    begin
5722       Binary_Op_Validity_Checks (N);
5723
5724       if Is_Array_Type (Typ1) then
5725          Expand_Array_Comparison (N);
5726          return;
5727       end if;
5728
5729       if Is_Boolean_Type (Typ1) then
5730          Adjust_Condition (Op1);
5731          Adjust_Condition (Op2);
5732          Set_Etype (N, Standard_Boolean);
5733          Adjust_Result_Type (N, Typ);
5734       end if;
5735
5736       Rewrite_Comparison (N);
5737
5738       --  If we still have comparison, and Vax_Float type, process it
5739
5740       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5741          Expand_Vax_Comparison (N);
5742          return;
5743       end if;
5744    end Expand_N_Op_Le;
5745
5746    --------------------
5747    -- Expand_N_Op_Lt --
5748    --------------------
5749
5750    procedure Expand_N_Op_Lt (N : Node_Id) is
5751       Typ  : constant Entity_Id := Etype (N);
5752       Op1  : constant Node_Id   := Left_Opnd (N);
5753       Op2  : constant Node_Id   := Right_Opnd (N);
5754       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
5755
5756    begin
5757       Binary_Op_Validity_Checks (N);
5758
5759       if Is_Array_Type (Typ1) then
5760          Expand_Array_Comparison (N);
5761          return;
5762       end if;
5763
5764       if Is_Boolean_Type (Typ1) then
5765          Adjust_Condition (Op1);
5766          Adjust_Condition (Op2);
5767          Set_Etype (N, Standard_Boolean);
5768          Adjust_Result_Type (N, Typ);
5769       end if;
5770
5771       Rewrite_Comparison (N);
5772
5773       --  If we still have comparison, and Vax_Float type, process it
5774
5775       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
5776          Expand_Vax_Comparison (N);
5777          return;
5778       end if;
5779    end Expand_N_Op_Lt;
5780
5781    -----------------------
5782    -- Expand_N_Op_Minus --
5783    -----------------------
5784
5785    procedure Expand_N_Op_Minus (N : Node_Id) is
5786       Loc : constant Source_Ptr := Sloc (N);
5787       Typ : constant Entity_Id  := Etype (N);
5788
5789    begin
5790       Unary_Op_Validity_Checks (N);
5791
5792       if not Backend_Overflow_Checks_On_Target
5793          and then Is_Signed_Integer_Type (Etype (N))
5794          and then Do_Overflow_Check (N)
5795       then
5796          --  Software overflow checking expands -expr into (0 - expr)
5797
5798          Rewrite (N,
5799            Make_Op_Subtract (Loc,
5800              Left_Opnd  => Make_Integer_Literal (Loc, 0),
5801              Right_Opnd => Right_Opnd (N)));
5802
5803          Analyze_And_Resolve (N, Typ);
5804
5805       --  Vax floating-point types case
5806
5807       elsif Vax_Float (Etype (N)) then
5808          Expand_Vax_Arith (N);
5809       end if;
5810    end Expand_N_Op_Minus;
5811
5812    ---------------------
5813    -- Expand_N_Op_Mod --
5814    ---------------------
5815
5816    procedure Expand_N_Op_Mod (N : Node_Id) is
5817       Loc   : constant Source_Ptr := Sloc (N);
5818       Typ   : constant Entity_Id  := Etype (N);
5819       Left  : constant Node_Id    := Left_Opnd (N);
5820       Right : constant Node_Id    := Right_Opnd (N);
5821       DOC   : constant Boolean    := Do_Overflow_Check (N);
5822       DDC   : constant Boolean    := Do_Division_Check (N);
5823
5824       LLB : Uint;
5825       Llo : Uint;
5826       Lhi : Uint;
5827       LOK : Boolean;
5828       Rlo : Uint;
5829       Rhi : Uint;
5830       ROK : Boolean;
5831
5832    begin
5833       Binary_Op_Validity_Checks (N);
5834
5835       Determine_Range (Right, ROK, Rlo, Rhi);
5836       Determine_Range (Left,  LOK, Llo, Lhi);
5837
5838       --  Convert mod to rem if operands are known non-negative. We do this
5839       --  since it is quite likely that this will improve the quality of code,
5840       --  (the operation now corresponds to the hardware remainder), and it
5841       --  does not seem likely that it could be harmful.
5842
5843       if LOK and then Llo >= 0
5844            and then
5845          ROK and then Rlo >= 0
5846       then
5847          Rewrite (N,
5848            Make_Op_Rem (Sloc (N),
5849              Left_Opnd  => Left_Opnd (N),
5850              Right_Opnd => Right_Opnd (N)));
5851
5852          --  Instead of reanalyzing the node we do the analysis manually.
5853          --  This avoids anomalies when the replacement is done in an
5854          --  instance and is epsilon more efficient.
5855
5856          Set_Entity            (N, Standard_Entity (S_Op_Rem));
5857          Set_Etype             (N, Typ);
5858          Set_Do_Overflow_Check (N, DOC);
5859          Set_Do_Division_Check (N, DDC);
5860          Expand_N_Op_Rem (N);
5861          Set_Analyzed (N);
5862
5863       --  Otherwise, normal mod processing
5864
5865       else
5866          if Is_Integer_Type (Etype (N)) then
5867             Apply_Divide_Check (N);
5868          end if;
5869
5870          --  Apply optimization x mod 1 = 0. We don't really need that with
5871          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
5872          --  certainly harmless.
5873
5874          if Is_Integer_Type (Etype (N))
5875            and then Compile_Time_Known_Value (Right)
5876            and then Expr_Value (Right) = Uint_1
5877          then
5878             Rewrite (N, Make_Integer_Literal (Loc, 0));
5879             Analyze_And_Resolve (N, Typ);
5880             return;
5881          end if;
5882
5883          --  Deal with annoying case of largest negative number remainder
5884          --  minus one. Gigi does not handle this case correctly, because
5885          --  it generates a divide instruction which may trap in this case.
5886
5887          --  In fact the check is quite easy, if the right operand is -1,
5888          --  then the mod value is always 0, and we can just ignore the
5889          --  left operand completely in this case.
5890
5891          --  The operand type may be private (e.g. in the expansion of an
5892          --  an intrinsic operation) so we must use the underlying type to
5893          --  get the bounds, and convert the literals explicitly.
5894
5895          LLB :=
5896            Expr_Value
5897              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
5898
5899          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
5900            and then
5901             ((not LOK) or else (Llo = LLB))
5902          then
5903             Rewrite (N,
5904               Make_Conditional_Expression (Loc,
5905                 Expressions => New_List (
5906                   Make_Op_Eq (Loc,
5907                     Left_Opnd => Duplicate_Subexpr (Right),
5908                     Right_Opnd =>
5909                       Unchecked_Convert_To (Typ,
5910                         Make_Integer_Literal (Loc, -1))),
5911                   Unchecked_Convert_To (Typ,
5912                     Make_Integer_Literal (Loc, Uint_0)),
5913                   Relocate_Node (N))));
5914
5915             Set_Analyzed (Next (Next (First (Expressions (N)))));
5916             Analyze_And_Resolve (N, Typ);
5917          end if;
5918       end if;
5919    end Expand_N_Op_Mod;
5920
5921    --------------------------
5922    -- Expand_N_Op_Multiply --
5923    --------------------------
5924
5925    procedure Expand_N_Op_Multiply (N : Node_Id) is
5926       Loc  : constant Source_Ptr := Sloc (N);
5927       Lop  : constant Node_Id    := Left_Opnd (N);
5928       Rop  : constant Node_Id    := Right_Opnd (N);
5929
5930       Lp2  : constant Boolean :=
5931                Nkind (Lop) = N_Op_Expon
5932                  and then Is_Power_Of_2_For_Shift (Lop);
5933
5934       Rp2  : constant Boolean :=
5935                Nkind (Rop) = N_Op_Expon
5936                  and then Is_Power_Of_2_For_Shift (Rop);
5937
5938       Ltyp : constant Entity_Id  := Etype (Lop);
5939       Rtyp : constant Entity_Id  := Etype (Rop);
5940       Typ  : Entity_Id           := Etype (N);
5941
5942    begin
5943       Binary_Op_Validity_Checks (N);
5944
5945       --  Special optimizations for integer types
5946
5947       if Is_Integer_Type (Typ) then
5948
5949          --  N * 0 = 0 * N = 0 for integer types
5950
5951          if (Compile_Time_Known_Value (Rop)
5952               and then Expr_Value (Rop) = Uint_0)
5953            or else
5954             (Compile_Time_Known_Value (Lop)
5955               and then Expr_Value (Lop) = Uint_0)
5956          then
5957             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
5958             Analyze_And_Resolve (N, Typ);
5959             return;
5960          end if;
5961
5962          --  N * 1 = 1 * N = N for integer types
5963
5964          --  This optimisation is not done if we are going to
5965          --  rewrite the product 1 * 2 ** N to a shift.
5966
5967          if Compile_Time_Known_Value (Rop)
5968            and then Expr_Value (Rop) = Uint_1
5969            and then not Lp2
5970          then
5971             Rewrite (N, Lop);
5972             return;
5973
5974          elsif Compile_Time_Known_Value (Lop)
5975            and then Expr_Value (Lop) = Uint_1
5976            and then not Rp2
5977          then
5978             Rewrite (N, Rop);
5979             return;
5980          end if;
5981       end if;
5982
5983       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
5984       --  Is_Power_Of_2_For_Shift is set means that we know that our left
5985       --  operand is an integer, as required for this to work.
5986
5987       if Rp2 then
5988          if Lp2 then
5989
5990             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
5991
5992             Rewrite (N,
5993               Make_Op_Expon (Loc,
5994                 Left_Opnd => Make_Integer_Literal (Loc, 2),
5995                 Right_Opnd =>
5996                   Make_Op_Add (Loc,
5997                     Left_Opnd  => Right_Opnd (Lop),
5998                     Right_Opnd => Right_Opnd (Rop))));
5999             Analyze_And_Resolve (N, Typ);
6000             return;
6001
6002          else
6003             Rewrite (N,
6004               Make_Op_Shift_Left (Loc,
6005                 Left_Opnd  => Lop,
6006                 Right_Opnd =>
6007                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
6008             Analyze_And_Resolve (N, Typ);
6009             return;
6010          end if;
6011
6012       --  Same processing for the operands the other way round
6013
6014       elsif Lp2 then
6015          Rewrite (N,
6016            Make_Op_Shift_Left (Loc,
6017              Left_Opnd  => Rop,
6018              Right_Opnd =>
6019                Convert_To (Standard_Natural, Right_Opnd (Lop))));
6020          Analyze_And_Resolve (N, Typ);
6021          return;
6022       end if;
6023
6024       --  Do required fixup of universal fixed operation
6025
6026       if Typ = Universal_Fixed then
6027          Fixup_Universal_Fixed_Operation (N);
6028          Typ := Etype (N);
6029       end if;
6030
6031       --  Multiplications with fixed-point results
6032
6033       if Is_Fixed_Point_Type (Typ) then
6034
6035          --  No special processing if Treat_Fixed_As_Integer is set,
6036          --  since from a semantic point of view such operations are
6037          --  simply integer operations and will be treated that way.
6038
6039          if not Treat_Fixed_As_Integer (N) then
6040
6041             --  Case of fixed * integer => fixed
6042
6043             if Is_Integer_Type (Rtyp) then
6044                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
6045
6046             --  Case of integer * fixed => fixed
6047
6048             elsif Is_Integer_Type (Ltyp) then
6049                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
6050
6051             --  Case of fixed * fixed => fixed
6052
6053             else
6054                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
6055             end if;
6056          end if;
6057
6058       --  Other cases of multiplication of fixed-point operands. Again
6059       --  we exclude the cases where Treat_Fixed_As_Integer flag is set.
6060
6061       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6062         and then not Treat_Fixed_As_Integer (N)
6063       then
6064          if Is_Integer_Type (Typ) then
6065             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
6066          else
6067             pragma Assert (Is_Floating_Point_Type (Typ));
6068             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
6069          end if;
6070
6071       --  Mixed-mode operations can appear in a non-static universal
6072       --  context, in  which case the integer argument must be converted
6073       --  explicitly.
6074
6075       elsif Typ = Universal_Real
6076         and then Is_Integer_Type (Rtyp)
6077       then
6078          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
6079
6080          Analyze_And_Resolve (Rop, Universal_Real);
6081
6082       elsif Typ = Universal_Real
6083         and then Is_Integer_Type (Ltyp)
6084       then
6085          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
6086
6087          Analyze_And_Resolve (Lop, Universal_Real);
6088
6089       --  Non-fixed point cases, check software overflow checking required
6090
6091       elsif Is_Signed_Integer_Type (Etype (N)) then
6092          Apply_Arithmetic_Overflow_Check (N);
6093
6094       --  Deal with VAX float case
6095
6096       elsif Vax_Float (Typ) then
6097          Expand_Vax_Arith (N);
6098          return;
6099       end if;
6100    end Expand_N_Op_Multiply;
6101
6102    --------------------
6103    -- Expand_N_Op_Ne --
6104    --------------------
6105
6106    procedure Expand_N_Op_Ne (N : Node_Id) is
6107       Typ : constant Entity_Id := Etype (Left_Opnd (N));
6108
6109    begin
6110       --  Case of elementary type with standard operator
6111
6112       if Is_Elementary_Type (Typ)
6113         and then Sloc (Entity (N)) = Standard_Location
6114       then
6115          Binary_Op_Validity_Checks (N);
6116
6117          --  Boolean types (requiring handling of non-standard case)
6118
6119          if Is_Boolean_Type (Typ) then
6120             Adjust_Condition (Left_Opnd (N));
6121             Adjust_Condition (Right_Opnd (N));
6122             Set_Etype (N, Standard_Boolean);
6123             Adjust_Result_Type (N, Typ);
6124          end if;
6125
6126          Rewrite_Comparison (N);
6127
6128          --  If we still have comparison for Vax_Float, process it
6129
6130          if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare  then
6131             Expand_Vax_Comparison (N);
6132             return;
6133          end if;
6134
6135       --  For all cases other than elementary types, we rewrite node as the
6136       --  negation of an equality operation, and reanalyze. The equality to be
6137       --  used is defined in the same scope and has the same signature. This
6138       --  signature must be set explicitly since in an instance it may not have
6139       --  the same visibility as in the generic unit. This avoids duplicating
6140       --  or factoring the complex code for record/array equality tests etc.
6141
6142       else
6143          declare
6144             Loc : constant Source_Ptr := Sloc (N);
6145             Neg : Node_Id;
6146             Ne  : constant Entity_Id := Entity (N);
6147
6148          begin
6149             Binary_Op_Validity_Checks (N);
6150
6151             Neg :=
6152               Make_Op_Not (Loc,
6153                 Right_Opnd =>
6154                   Make_Op_Eq (Loc,
6155                     Left_Opnd =>  Left_Opnd (N),
6156                     Right_Opnd => Right_Opnd (N)));
6157             Set_Paren_Count (Right_Opnd (Neg), 1);
6158
6159             if Scope (Ne) /= Standard_Standard then
6160                Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
6161             end if;
6162
6163             --  For navigation purposes, the inequality is treated as an
6164             --  implicit reference to the corresponding equality. Preserve the
6165             --  Comes_From_ source flag so that the proper Xref entry is
6166             --  generated.
6167
6168             Preserve_Comes_From_Source (Neg, N);
6169             Preserve_Comes_From_Source (Right_Opnd (Neg), N);
6170             Rewrite (N, Neg);
6171             Analyze_And_Resolve (N, Standard_Boolean);
6172          end;
6173       end if;
6174    end Expand_N_Op_Ne;
6175
6176    ---------------------
6177    -- Expand_N_Op_Not --
6178    ---------------------
6179
6180    --  If the argument is other than a Boolean array type, there is no
6181    --  special expansion required.
6182
6183    --  For the packed case, we call the special routine in Exp_Pakd, except
6184    --  that if the component size is greater than one, we use the standard
6185    --  routine generating a gruesome loop (it is so peculiar to have packed
6186    --  arrays with non-standard Boolean representations anyway, so it does
6187    --  not matter that we do not handle this case efficiently).
6188
6189    --  For the unpacked case (and for the special packed case where we have
6190    --  non standard Booleans, as discussed above), we generate and insert
6191    --  into the tree the following function definition:
6192
6193    --     function Nnnn (A : arr) is
6194    --       B : arr;
6195    --     begin
6196    --       for J in a'range loop
6197    --          B (J) := not A (J);
6198    --       end loop;
6199    --       return B;
6200    --     end Nnnn;
6201
6202    --  Here arr is the actual subtype of the parameter (and hence always
6203    --  constrained). Then we replace the not with a call to this function.
6204
6205    procedure Expand_N_Op_Not (N : Node_Id) is
6206       Loc  : constant Source_Ptr := Sloc (N);
6207       Typ  : constant Entity_Id  := Etype (N);
6208       Opnd : Node_Id;
6209       Arr  : Entity_Id;
6210       A    : Entity_Id;
6211       B    : Entity_Id;
6212       J    : Entity_Id;
6213       A_J  : Node_Id;
6214       B_J  : Node_Id;
6215
6216       Func_Name      : Entity_Id;
6217       Loop_Statement : Node_Id;
6218
6219    begin
6220       Unary_Op_Validity_Checks (N);
6221
6222       --  For boolean operand, deal with non-standard booleans
6223
6224       if Is_Boolean_Type (Typ) then
6225          Adjust_Condition (Right_Opnd (N));
6226          Set_Etype (N, Standard_Boolean);
6227          Adjust_Result_Type (N, Typ);
6228          return;
6229       end if;
6230
6231       --  Only array types need any other processing
6232
6233       if not Is_Array_Type (Typ) then
6234          return;
6235       end if;
6236
6237       --  Case of array operand. If bit packed with a component size of 1,
6238       --  handle it in Exp_Pakd if the operand is known to be aligned.
6239
6240       if Is_Bit_Packed_Array (Typ)
6241         and then Component_Size (Typ) = 1
6242         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
6243       then
6244          Expand_Packed_Not (N);
6245          return;
6246       end if;
6247
6248       --  Case of array operand which is not bit-packed. If the context is
6249       --  a safe assignment, call in-place operation, If context is a larger
6250       --  boolean expression in the context of a safe assignment, expansion is
6251       --  done by enclosing operation.
6252
6253       Opnd := Relocate_Node (Right_Opnd (N));
6254       Convert_To_Actual_Subtype (Opnd);
6255       Arr := Etype (Opnd);
6256       Ensure_Defined (Arr, N);
6257
6258       if Nkind (Parent (N)) = N_Assignment_Statement then
6259          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
6260             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6261             return;
6262
6263          --  Special case the negation of a binary operation
6264
6265          elsif (Nkind (Opnd) = N_Op_And
6266                  or else Nkind (Opnd) = N_Op_Or
6267                  or else Nkind (Opnd) = N_Op_Xor)
6268            and then Safe_In_Place_Array_Op
6269              (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
6270          then
6271             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6272             return;
6273          end if;
6274
6275       elsif Nkind (Parent (N)) in N_Binary_Op
6276         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
6277       then
6278          declare
6279             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
6280             Op2 : constant Node_Id := Right_Opnd (Parent (N));
6281             Lhs : constant Node_Id := Name (Parent (Parent (N)));
6282
6283          begin
6284             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
6285                if N = Op1
6286                  and then Nkind (Op2) = N_Op_Not
6287                then
6288                   --  (not A) op (not B) can be reduced to a single call
6289
6290                   return;
6291
6292                elsif N = Op2
6293                  and then Nkind (Parent (N)) = N_Op_Xor
6294                then
6295                   --  A xor (not B) can also be special-cased
6296
6297                   return;
6298                end if;
6299             end if;
6300          end;
6301       end if;
6302
6303       A := Make_Defining_Identifier (Loc, Name_uA);
6304       B := Make_Defining_Identifier (Loc, Name_uB);
6305       J := Make_Defining_Identifier (Loc, Name_uJ);
6306
6307       A_J :=
6308         Make_Indexed_Component (Loc,
6309           Prefix      => New_Reference_To (A, Loc),
6310           Expressions => New_List (New_Reference_To (J, Loc)));
6311
6312       B_J :=
6313         Make_Indexed_Component (Loc,
6314           Prefix      => New_Reference_To (B, Loc),
6315           Expressions => New_List (New_Reference_To (J, Loc)));
6316
6317       Loop_Statement :=
6318         Make_Implicit_Loop_Statement (N,
6319           Identifier => Empty,
6320
6321           Iteration_Scheme =>
6322             Make_Iteration_Scheme (Loc,
6323               Loop_Parameter_Specification =>
6324                 Make_Loop_Parameter_Specification (Loc,
6325                   Defining_Identifier => J,
6326                   Discrete_Subtype_Definition =>
6327                     Make_Attribute_Reference (Loc,
6328                       Prefix => Make_Identifier (Loc, Chars (A)),
6329                       Attribute_Name => Name_Range))),
6330
6331           Statements => New_List (
6332             Make_Assignment_Statement (Loc,
6333               Name       => B_J,
6334               Expression => Make_Op_Not (Loc, A_J))));
6335
6336       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
6337       Set_Is_Inlined (Func_Name);
6338
6339       Insert_Action (N,
6340         Make_Subprogram_Body (Loc,
6341           Specification =>
6342             Make_Function_Specification (Loc,
6343               Defining_Unit_Name => Func_Name,
6344               Parameter_Specifications => New_List (
6345                 Make_Parameter_Specification (Loc,
6346                   Defining_Identifier => A,
6347                   Parameter_Type      => New_Reference_To (Typ, Loc))),
6348               Result_Definition => New_Reference_To (Typ, Loc)),
6349
6350           Declarations => New_List (
6351             Make_Object_Declaration (Loc,
6352               Defining_Identifier => B,
6353               Object_Definition   => New_Reference_To (Arr, Loc))),
6354
6355           Handled_Statement_Sequence =>
6356             Make_Handled_Sequence_Of_Statements (Loc,
6357               Statements => New_List (
6358                 Loop_Statement,
6359                 Make_Simple_Return_Statement (Loc,
6360                   Expression =>
6361                     Make_Identifier (Loc, Chars (B)))))));
6362
6363       Rewrite (N,
6364         Make_Function_Call (Loc,
6365           Name => New_Reference_To (Func_Name, Loc),
6366           Parameter_Associations => New_List (Opnd)));
6367
6368       Analyze_And_Resolve (N, Typ);
6369    end Expand_N_Op_Not;
6370
6371    --------------------
6372    -- Expand_N_Op_Or --
6373    --------------------
6374
6375    procedure Expand_N_Op_Or (N : Node_Id) is
6376       Typ : constant Entity_Id := Etype (N);
6377
6378    begin
6379       Binary_Op_Validity_Checks (N);
6380
6381       if Is_Array_Type (Etype (N)) then
6382          Expand_Boolean_Operator (N);
6383
6384       elsif Is_Boolean_Type (Etype (N)) then
6385          Adjust_Condition (Left_Opnd (N));
6386          Adjust_Condition (Right_Opnd (N));
6387          Set_Etype (N, Standard_Boolean);
6388          Adjust_Result_Type (N, Typ);
6389       end if;
6390    end Expand_N_Op_Or;
6391
6392    ----------------------
6393    -- Expand_N_Op_Plus --
6394    ----------------------
6395
6396    procedure Expand_N_Op_Plus (N : Node_Id) is
6397    begin
6398       Unary_Op_Validity_Checks (N);
6399    end Expand_N_Op_Plus;
6400
6401    ---------------------
6402    -- Expand_N_Op_Rem --
6403    ---------------------
6404
6405    procedure Expand_N_Op_Rem (N : Node_Id) is
6406       Loc : constant Source_Ptr := Sloc (N);
6407       Typ : constant Entity_Id  := Etype (N);
6408
6409       Left  : constant Node_Id := Left_Opnd (N);
6410       Right : constant Node_Id := Right_Opnd (N);
6411
6412       LLB : Uint;
6413       Llo : Uint;
6414       Lhi : Uint;
6415       LOK : Boolean;
6416       Rlo : Uint;
6417       Rhi : Uint;
6418       ROK : Boolean;
6419
6420    begin
6421       Binary_Op_Validity_Checks (N);
6422
6423       if Is_Integer_Type (Etype (N)) then
6424          Apply_Divide_Check (N);
6425       end if;
6426
6427       --  Apply optimization x rem 1 = 0. We don't really need that with
6428       --  gcc, but it is useful with other back ends (e.g. AAMP), and is
6429       --  certainly harmless.
6430
6431       if Is_Integer_Type (Etype (N))
6432         and then Compile_Time_Known_Value (Right)
6433         and then Expr_Value (Right) = Uint_1
6434       then
6435          Rewrite (N, Make_Integer_Literal (Loc, 0));
6436          Analyze_And_Resolve (N, Typ);
6437          return;
6438       end if;
6439
6440       --  Deal with annoying case of largest negative number remainder
6441       --  minus one. Gigi does not handle this case correctly, because
6442       --  it generates a divide instruction which may trap in this case.
6443
6444       --  In fact the check is quite easy, if the right operand is -1,
6445       --  then the remainder is always 0, and we can just ignore the
6446       --  left operand completely in this case.
6447
6448       Determine_Range (Right, ROK, Rlo, Rhi);
6449       Determine_Range (Left, LOK, Llo, Lhi);
6450
6451       --  The operand type may be private (e.g. in the expansion of an
6452       --  an intrinsic operation) so we must use the underlying type to
6453       --  get the bounds, and convert the literals explicitly.
6454
6455       LLB :=
6456         Expr_Value
6457           (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
6458
6459       --  Now perform the test, generating code only if needed
6460
6461       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
6462         and then
6463          ((not LOK) or else (Llo = LLB))
6464       then
6465          Rewrite (N,
6466            Make_Conditional_Expression (Loc,
6467              Expressions => New_List (
6468                Make_Op_Eq (Loc,
6469                  Left_Opnd => Duplicate_Subexpr (Right),
6470                  Right_Opnd =>
6471                    Unchecked_Convert_To (Typ,
6472                      Make_Integer_Literal (Loc, -1))),
6473
6474                Unchecked_Convert_To (Typ,
6475                  Make_Integer_Literal (Loc, Uint_0)),
6476
6477                Relocate_Node (N))));
6478
6479          Set_Analyzed (Next (Next (First (Expressions (N)))));
6480          Analyze_And_Resolve (N, Typ);
6481       end if;
6482    end Expand_N_Op_Rem;
6483
6484    -----------------------------
6485    -- Expand_N_Op_Rotate_Left --
6486    -----------------------------
6487
6488    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
6489    begin
6490       Binary_Op_Validity_Checks (N);
6491    end Expand_N_Op_Rotate_Left;
6492
6493    ------------------------------
6494    -- Expand_N_Op_Rotate_Right --
6495    ------------------------------
6496
6497    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
6498    begin
6499       Binary_Op_Validity_Checks (N);
6500    end Expand_N_Op_Rotate_Right;
6501
6502    ----------------------------
6503    -- Expand_N_Op_Shift_Left --
6504    ----------------------------
6505
6506    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
6507    begin
6508       Binary_Op_Validity_Checks (N);
6509    end Expand_N_Op_Shift_Left;
6510
6511    -----------------------------
6512    -- Expand_N_Op_Shift_Right --
6513    -----------------------------
6514
6515    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
6516    begin
6517       Binary_Op_Validity_Checks (N);
6518    end Expand_N_Op_Shift_Right;
6519
6520    ----------------------------------------
6521    -- Expand_N_Op_Shift_Right_Arithmetic --
6522    ----------------------------------------
6523
6524    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
6525    begin
6526       Binary_Op_Validity_Checks (N);
6527    end Expand_N_Op_Shift_Right_Arithmetic;
6528
6529    --------------------------
6530    -- Expand_N_Op_Subtract --
6531    --------------------------
6532
6533    procedure Expand_N_Op_Subtract (N : Node_Id) is
6534       Typ : constant Entity_Id := Etype (N);
6535
6536    begin
6537       Binary_Op_Validity_Checks (N);
6538
6539       --  N - 0 = N for integer types
6540
6541       if Is_Integer_Type (Typ)
6542         and then Compile_Time_Known_Value (Right_Opnd (N))
6543         and then Expr_Value (Right_Opnd (N)) = 0
6544       then
6545          Rewrite (N, Left_Opnd (N));
6546          return;
6547       end if;
6548
6549       --  Arithemtic overflow checks for signed integer/fixed point types
6550
6551       if Is_Signed_Integer_Type (Typ)
6552         or else Is_Fixed_Point_Type (Typ)
6553       then
6554          Apply_Arithmetic_Overflow_Check (N);
6555
6556       --  Vax floating-point types case
6557
6558       elsif Vax_Float (Typ) then
6559          Expand_Vax_Arith (N);
6560       end if;
6561    end Expand_N_Op_Subtract;
6562
6563    ---------------------
6564    -- Expand_N_Op_Xor --
6565    ---------------------
6566
6567    procedure Expand_N_Op_Xor (N : Node_Id) is
6568       Typ : constant Entity_Id := Etype (N);
6569
6570    begin
6571       Binary_Op_Validity_Checks (N);
6572
6573       if Is_Array_Type (Etype (N)) then
6574          Expand_Boolean_Operator (N);
6575
6576       elsif Is_Boolean_Type (Etype (N)) then
6577          Adjust_Condition (Left_Opnd (N));
6578          Adjust_Condition (Right_Opnd (N));
6579          Set_Etype (N, Standard_Boolean);
6580          Adjust_Result_Type (N, Typ);
6581       end if;
6582    end Expand_N_Op_Xor;
6583
6584    ----------------------
6585    -- Expand_N_Or_Else --
6586    ----------------------
6587
6588    --  Expand into conditional expression if Actions present, and also
6589    --  deal with optimizing case of arguments being True or False.
6590
6591    procedure Expand_N_Or_Else (N : Node_Id) is
6592       Loc     : constant Source_Ptr := Sloc (N);
6593       Typ     : constant Entity_Id  := Etype (N);
6594       Left    : constant Node_Id    := Left_Opnd (N);
6595       Right   : constant Node_Id    := Right_Opnd (N);
6596       Actlist : List_Id;
6597
6598    begin
6599       --  Deal with non-standard booleans
6600
6601       if Is_Boolean_Type (Typ) then
6602          Adjust_Condition (Left);
6603          Adjust_Condition (Right);
6604          Set_Etype (N, Standard_Boolean);
6605       end if;
6606
6607       --  Check for cases of left argument is True or False
6608
6609       if Nkind (Left) = N_Identifier then
6610
6611          --  If left argument is False, change (False or else Right) to Right.
6612          --  Any actions associated with Right will be executed unconditionally
6613          --  and can thus be inserted into the tree unconditionally.
6614
6615          if Entity (Left) = Standard_False then
6616             if Present (Actions (N)) then
6617                Insert_Actions (N, Actions (N));
6618             end if;
6619
6620             Rewrite (N, Right);
6621             Adjust_Result_Type (N, Typ);
6622             return;
6623
6624          --  If left argument is True, change (True and then Right) to
6625          --  True. In this case we can forget the actions associated with
6626          --  Right, since they will never be executed.
6627
6628          elsif Entity (Left) = Standard_True then
6629             Kill_Dead_Code (Right);
6630             Kill_Dead_Code (Actions (N));
6631             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6632             Adjust_Result_Type (N, Typ);
6633             return;
6634          end if;
6635       end if;
6636
6637       --  If Actions are present, we expand
6638
6639       --     left or else right
6640
6641       --  into
6642
6643       --     if left then True else right end
6644
6645       --  with the actions becoming the Else_Actions of the conditional
6646       --  expression. This conditional expression is then further expanded
6647       --  (and will eventually disappear)
6648
6649       if Present (Actions (N)) then
6650          Actlist := Actions (N);
6651          Rewrite (N,
6652             Make_Conditional_Expression (Loc,
6653               Expressions => New_List (
6654                 Left,
6655                 New_Occurrence_Of (Standard_True, Loc),
6656                 Right)));
6657
6658          Set_Else_Actions (N, Actlist);
6659          Analyze_And_Resolve (N, Standard_Boolean);
6660          Adjust_Result_Type (N, Typ);
6661          return;
6662       end if;
6663
6664       --  No actions present, check for cases of right argument True/False
6665
6666       if Nkind (Right) = N_Identifier then
6667
6668          --  Change (Left or else False) to Left. Note that we know there
6669          --  are no actions associated with the True operand, since we
6670          --  just checked for this case above.
6671
6672          if Entity (Right) = Standard_False then
6673             Rewrite (N, Left);
6674
6675          --  Change (Left or else True) to True, making sure to preserve
6676          --  any side effects associated with the Left operand.
6677
6678          elsif Entity (Right) = Standard_True then
6679             Remove_Side_Effects (Left);
6680             Rewrite
6681               (N, New_Occurrence_Of (Standard_True, Loc));
6682          end if;
6683       end if;
6684
6685       Adjust_Result_Type (N, Typ);
6686    end Expand_N_Or_Else;
6687
6688    -----------------------------------
6689    -- Expand_N_Qualified_Expression --
6690    -----------------------------------
6691
6692    procedure Expand_N_Qualified_Expression (N : Node_Id) is
6693       Operand     : constant Node_Id   := Expression (N);
6694       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
6695
6696    begin
6697       --  Do validity check if validity checking operands
6698
6699       if Validity_Checks_On
6700         and then Validity_Check_Operands
6701       then
6702          Ensure_Valid (Operand);
6703       end if;
6704
6705       --  Apply possible constraint check
6706
6707       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
6708    end Expand_N_Qualified_Expression;
6709
6710    ---------------------------------
6711    -- Expand_N_Selected_Component --
6712    ---------------------------------
6713
6714    --  If the selector is a discriminant of a concurrent object, rewrite the
6715    --  prefix to denote the corresponding record type.
6716
6717    procedure Expand_N_Selected_Component (N : Node_Id) is
6718       Loc   : constant Source_Ptr := Sloc (N);
6719       Par   : constant Node_Id    := Parent (N);
6720       P     : constant Node_Id    := Prefix (N);
6721       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
6722       Disc  : Entity_Id;
6723       New_N : Node_Id;
6724       Dcon  : Elmt_Id;
6725
6726       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
6727       --  Gigi needs a temporary for prefixes that depend on a discriminant,
6728       --  unless the context of an assignment can provide size information.
6729       --  Don't we have a general routine that does this???
6730
6731       -----------------------
6732       -- In_Left_Hand_Side --
6733       -----------------------
6734
6735       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
6736       begin
6737          return (Nkind (Parent (Comp)) = N_Assignment_Statement
6738                    and then Comp = Name (Parent (Comp)))
6739            or else (Present (Parent (Comp))
6740                       and then Nkind (Parent (Comp)) in N_Subexpr
6741                       and then In_Left_Hand_Side (Parent (Comp)));
6742       end In_Left_Hand_Side;
6743
6744    --  Start of processing for Expand_N_Selected_Component
6745
6746    begin
6747       --  Insert explicit dereference if required
6748
6749       if Is_Access_Type (Ptyp) then
6750          Insert_Explicit_Dereference (P);
6751          Analyze_And_Resolve (P, Designated_Type (Ptyp));
6752
6753          if Ekind (Etype (P)) = E_Private_Subtype
6754            and then Is_For_Access_Subtype (Etype (P))
6755          then
6756             Set_Etype (P, Base_Type (Etype (P)));
6757          end if;
6758
6759          Ptyp := Etype (P);
6760       end if;
6761
6762       --  Deal with discriminant check required
6763
6764       if Do_Discriminant_Check (N) then
6765
6766          --  Present the discrminant checking function to the backend,
6767          --  so that it can inline the call to the function.
6768
6769          Add_Inlined_Body
6770            (Discriminant_Checking_Func
6771              (Original_Record_Component (Entity (Selector_Name (N)))));
6772
6773          --  Now reset the flag and generate the call
6774
6775          Set_Do_Discriminant_Check (N, False);
6776          Generate_Discriminant_Check (N);
6777       end if;
6778
6779       --  Gigi cannot handle unchecked conversions that are the prefix of a
6780       --  selected component with discriminants. This must be checked during
6781       --  expansion, because during analysis the type of the selector is not
6782       --  known at the point the prefix is analyzed. If the conversion is the
6783       --  target of an assignment, then we cannot force the evaluation.
6784
6785       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
6786         and then Has_Discriminants (Etype (N))
6787         and then not In_Left_Hand_Side (N)
6788       then
6789          Force_Evaluation (Prefix (N));
6790       end if;
6791
6792       --  Remaining processing applies only if selector is a discriminant
6793
6794       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
6795
6796          --  If the selector is a discriminant of a constrained record type,
6797          --  we may be able to rewrite the expression with the actual value
6798          --  of the discriminant, a useful optimization in some cases.
6799
6800          if Is_Record_Type (Ptyp)
6801            and then Has_Discriminants (Ptyp)
6802            and then Is_Constrained (Ptyp)
6803          then
6804             --  Do this optimization for discrete types only, and not for
6805             --  access types (access discriminants get us into trouble!)
6806
6807             if not Is_Discrete_Type (Etype (N)) then
6808                null;
6809
6810             --  Don't do this on the left hand of an assignment statement.
6811             --  Normally one would think that references like this would
6812             --  not occur, but they do in generated code, and mean that
6813             --  we really do want to assign the discriminant!
6814
6815             elsif Nkind (Par) = N_Assignment_Statement
6816               and then Name (Par) = N
6817             then
6818                null;
6819
6820             --  Don't do this optimization for the prefix of an attribute
6821             --  or the operand of an object renaming declaration since these
6822             --  are contexts where we do not want the value anyway.
6823
6824             elsif (Nkind (Par) = N_Attribute_Reference
6825                      and then Prefix (Par) = N)
6826               or else Is_Renamed_Object (N)
6827             then
6828                null;
6829
6830             --  Don't do this optimization if we are within the code for a
6831             --  discriminant check, since the whole point of such a check may
6832             --  be to verify the condition on which the code below depends!
6833
6834             elsif Is_In_Discriminant_Check (N) then
6835                null;
6836
6837             --  Green light to see if we can do the optimization. There is
6838             --  still one condition that inhibits the optimization below
6839             --  but now is the time to check the particular discriminant.
6840
6841             else
6842                --  Loop through discriminants to find the matching
6843                --  discriminant constraint to see if we can copy it.
6844
6845                Disc := First_Discriminant (Ptyp);
6846                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
6847                Discr_Loop : while Present (Dcon) loop
6848
6849                   --  Check if this is the matching discriminant
6850
6851                   if Disc = Entity (Selector_Name (N)) then
6852
6853                      --  Here we have the matching discriminant. Check for
6854                      --  the case of a discriminant of a component that is
6855                      --  constrained by an outer discriminant, which cannot
6856                      --  be optimized away.
6857
6858                      if
6859                        Denotes_Discriminant
6860                         (Node (Dcon), Check_Concurrent => True)
6861                      then
6862                         exit Discr_Loop;
6863
6864                      --  In the context of a case statement, the expression
6865                      --  may have the base type of the discriminant, and we
6866                      --  need to preserve the constraint to avoid spurious
6867                      --  errors on missing cases.
6868
6869                      elsif Nkind (Parent (N)) = N_Case_Statement
6870                        and then Etype (Node (Dcon)) /= Etype (Disc)
6871                      then
6872                         Rewrite (N,
6873                           Make_Qualified_Expression (Loc,
6874                             Subtype_Mark =>
6875                               New_Occurrence_Of (Etype (Disc), Loc),
6876                             Expression   =>
6877                               New_Copy_Tree (Node (Dcon))));
6878                         Analyze_And_Resolve (N, Etype (Disc));
6879
6880                         --  In case that comes out as a static expression,
6881                         --  reset it (a selected component is never static).
6882
6883                         Set_Is_Static_Expression (N, False);
6884                         return;
6885
6886                      --  Otherwise we can just copy the constraint, but the
6887                      --  result is certainly not static! In some cases the
6888                      --  discriminant constraint has been analyzed in the
6889                      --  context of the original subtype indication, but for
6890                      --  itypes the constraint might not have been analyzed
6891                      --  yet, and this must be done now.
6892
6893                      else
6894                         Rewrite (N, New_Copy_Tree (Node (Dcon)));
6895                         Analyze_And_Resolve (N);
6896                         Set_Is_Static_Expression (N, False);
6897                         return;
6898                      end if;
6899                   end if;
6900
6901                   Next_Elmt (Dcon);
6902                   Next_Discriminant (Disc);
6903                end loop Discr_Loop;
6904
6905                --  Note: the above loop should always find a matching
6906                --  discriminant, but if it does not, we just missed an
6907                --  optimization due to some glitch (perhaps a previous
6908                --  error), so ignore.
6909
6910             end if;
6911          end if;
6912
6913          --  The only remaining processing is in the case of a discriminant of
6914          --  a concurrent object, where we rewrite the prefix to denote the
6915          --  corresponding record type. If the type is derived and has renamed
6916          --  discriminants, use corresponding discriminant, which is the one
6917          --  that appears in the corresponding record.
6918
6919          if not Is_Concurrent_Type (Ptyp) then
6920             return;
6921          end if;
6922
6923          Disc := Entity (Selector_Name (N));
6924
6925          if Is_Derived_Type (Ptyp)
6926            and then Present (Corresponding_Discriminant (Disc))
6927          then
6928             Disc := Corresponding_Discriminant (Disc);
6929          end if;
6930
6931          New_N :=
6932            Make_Selected_Component (Loc,
6933              Prefix =>
6934                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
6935                  New_Copy_Tree (P)),
6936              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
6937
6938          Rewrite (N, New_N);
6939          Analyze (N);
6940       end if;
6941    end Expand_N_Selected_Component;
6942
6943    --------------------
6944    -- Expand_N_Slice --
6945    --------------------
6946
6947    procedure Expand_N_Slice (N : Node_Id) is
6948       Loc  : constant Source_Ptr := Sloc (N);
6949       Typ  : constant Entity_Id  := Etype (N);
6950       Pfx  : constant Node_Id    := Prefix (N);
6951       Ptp  : Entity_Id           := Etype (Pfx);
6952
6953       function Is_Procedure_Actual (N : Node_Id) return Boolean;
6954       --  Check whether the argument is an actual for a procedure call,
6955       --  in which case the expansion of a bit-packed slice is deferred
6956       --  until the call itself is expanded. The reason this is required
6957       --  is that we might have an IN OUT or OUT parameter, and the copy out
6958       --  is essential, and that copy out would be missed if we created a
6959       --  temporary here in Expand_N_Slice. Note that we don't bother
6960       --  to test specifically for an IN OUT or OUT mode parameter, since it
6961       --  is a bit tricky to do, and it is harmless to defer expansion
6962       --  in the IN case, since the call processing will still generate the
6963       --  appropriate copy in operation, which will take care of the slice.
6964
6965       procedure Make_Temporary;
6966       --  Create a named variable for the value of the slice, in
6967       --  cases where the back-end cannot handle it properly, e.g.
6968       --  when packed types or unaligned slices are involved.
6969
6970       -------------------------
6971       -- Is_Procedure_Actual --
6972       -------------------------
6973
6974       function Is_Procedure_Actual (N : Node_Id) return Boolean is
6975          Par : Node_Id := Parent (N);
6976
6977       begin
6978          loop
6979             --  If our parent is a procedure call we can return
6980
6981             if Nkind (Par) = N_Procedure_Call_Statement then
6982                return True;
6983
6984             --  If our parent is a type conversion, keep climbing the
6985             --  tree, since a type conversion can be a procedure actual.
6986             --  Also keep climbing if parameter association or a qualified
6987             --  expression, since these are additional cases that do can
6988             --  appear on procedure actuals.
6989
6990             elsif Nkind (Par) = N_Type_Conversion
6991               or else Nkind (Par) = N_Parameter_Association
6992               or else Nkind (Par) = N_Qualified_Expression
6993             then
6994                Par := Parent (Par);
6995
6996                --  Any other case is not what we are looking for
6997
6998             else
6999                return False;
7000             end if;
7001          end loop;
7002       end Is_Procedure_Actual;
7003
7004       --------------------
7005       -- Make_Temporary --
7006       --------------------
7007
7008       procedure Make_Temporary is
7009          Decl : Node_Id;
7010          Ent  : constant Entity_Id :=
7011                   Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
7012       begin
7013          Decl :=
7014            Make_Object_Declaration (Loc,
7015              Defining_Identifier => Ent,
7016              Object_Definition   => New_Occurrence_Of (Typ, Loc));
7017
7018          Set_No_Initialization (Decl);
7019
7020          Insert_Actions (N, New_List (
7021            Decl,
7022            Make_Assignment_Statement (Loc,
7023              Name => New_Occurrence_Of (Ent, Loc),
7024              Expression => Relocate_Node (N))));
7025
7026          Rewrite (N, New_Occurrence_Of (Ent, Loc));
7027          Analyze_And_Resolve (N, Typ);
7028       end Make_Temporary;
7029
7030    --  Start of processing for Expand_N_Slice
7031
7032    begin
7033       --  Special handling for access types
7034
7035       if Is_Access_Type (Ptp) then
7036
7037          Ptp := Designated_Type (Ptp);
7038
7039          Rewrite (Pfx,
7040            Make_Explicit_Dereference (Sloc (N),
7041             Prefix => Relocate_Node (Pfx)));
7042
7043          Analyze_And_Resolve (Pfx, Ptp);
7044       end if;
7045
7046       --  Range checks are potentially also needed for cases involving
7047       --  a slice indexed by a subtype indication, but Do_Range_Check
7048       --  can currently only be set for expressions ???
7049
7050       if not Index_Checks_Suppressed (Ptp)
7051         and then (not Is_Entity_Name (Pfx)
7052                    or else not Index_Checks_Suppressed (Entity (Pfx)))
7053         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
7054
7055          --  Do not enable range check to nodes associated with the frontend
7056          --  expansion of the dispatch table. We first check if Ada.Tags is
7057          --  already loaded to avoid the addition of an undesired dependence
7058          --  on such run-time unit.
7059
7060         and then
7061           (VM_Target /= No_VM
7062             or else not
7063              (RTU_Loaded (Ada_Tags)
7064                and then Nkind (Prefix (N)) = N_Selected_Component
7065                and then Present (Entity (Selector_Name (Prefix (N))))
7066                and then Entity (Selector_Name (Prefix (N))) =
7067                                   RTE_Record_Component (RE_Prims_Ptr)))
7068       then
7069          Enable_Range_Check (Discrete_Range (N));
7070       end if;
7071
7072       --  The remaining case to be handled is packed slices. We can leave
7073       --  packed slices as they are in the following situations:
7074
7075       --    1. Right or left side of an assignment (we can handle this
7076       --       situation correctly in the assignment statement expansion).
7077
7078       --    2. Prefix of indexed component (the slide is optimized away
7079       --       in this case, see the start of Expand_N_Slice.)
7080
7081       --    3. Object renaming declaration, since we want the name of
7082       --       the slice, not the value.
7083
7084       --    4. Argument to procedure call, since copy-in/copy-out handling
7085       --       may be required, and this is handled in the expansion of
7086       --       call itself.
7087
7088       --    5. Prefix of an address attribute (this is an error which
7089       --       is caught elsewhere, and the expansion would intefere
7090       --       with generating the error message).
7091
7092       if not Is_Packed (Typ) then
7093
7094          --  Apply transformation for actuals of a function call,
7095          --  where Expand_Actuals is not used.
7096
7097          if Nkind (Parent (N)) = N_Function_Call
7098            and then Is_Possibly_Unaligned_Slice (N)
7099          then
7100             Make_Temporary;
7101          end if;
7102
7103       elsif Nkind (Parent (N)) = N_Assignment_Statement
7104         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
7105                    and then Parent (N) = Name (Parent (Parent (N))))
7106       then
7107          return;
7108
7109       elsif Nkind (Parent (N)) = N_Indexed_Component
7110         or else Is_Renamed_Object (N)
7111         or else Is_Procedure_Actual (N)
7112       then
7113          return;
7114
7115       elsif Nkind (Parent (N)) = N_Attribute_Reference
7116         and then Attribute_Name (Parent (N)) = Name_Address
7117       then
7118          return;
7119
7120       else
7121          Make_Temporary;
7122       end if;
7123    end Expand_N_Slice;
7124
7125    ------------------------------
7126    -- Expand_N_Type_Conversion --
7127    ------------------------------
7128
7129    procedure Expand_N_Type_Conversion (N : Node_Id) is
7130       Loc          : constant Source_Ptr := Sloc (N);
7131       Operand      : constant Node_Id    := Expression (N);
7132       Target_Type  : constant Entity_Id  := Etype (N);
7133       Operand_Type : Entity_Id           := Etype (Operand);
7134
7135       procedure Handle_Changed_Representation;
7136       --  This is called in the case of record and array type conversions
7137       --  to see if there is a change of representation to be handled.
7138       --  Change of representation is actually handled at the assignment
7139       --  statement level, and what this procedure does is rewrite node N
7140       --  conversion as an assignment to temporary. If there is no change
7141       --  of representation, then the conversion node is unchanged.
7142
7143       procedure Real_Range_Check;
7144       --  Handles generation of range check for real target value
7145
7146       -----------------------------------
7147       -- Handle_Changed_Representation --
7148       -----------------------------------
7149
7150       procedure Handle_Changed_Representation is
7151          Temp : Entity_Id;
7152          Decl : Node_Id;
7153          Odef : Node_Id;
7154          Disc : Node_Id;
7155          N_Ix : Node_Id;
7156          Cons : List_Id;
7157
7158       begin
7159          --  Nothing else to do if no change of representation
7160
7161          if Same_Representation (Operand_Type, Target_Type) then
7162             return;
7163
7164          --  The real change of representation work is done by the assignment
7165          --  statement processing. So if this type conversion is appearing as
7166          --  the expression of an assignment statement, nothing needs to be
7167          --  done to the conversion.
7168
7169          elsif Nkind (Parent (N)) = N_Assignment_Statement then
7170             return;
7171
7172          --  Otherwise we need to generate a temporary variable, and do the
7173          --  change of representation assignment into that temporary variable.
7174          --  The conversion is then replaced by a reference to this variable.
7175
7176          else
7177             Cons := No_List;
7178
7179             --  If type is unconstrained we have to add a constraint,
7180             --  copied from the actual value of the left hand side.
7181
7182             if not Is_Constrained (Target_Type) then
7183                if Has_Discriminants (Operand_Type) then
7184                   Disc := First_Discriminant (Operand_Type);
7185
7186                   if Disc /= First_Stored_Discriminant (Operand_Type) then
7187                      Disc := First_Stored_Discriminant (Operand_Type);
7188                   end if;
7189
7190                   Cons := New_List;
7191                   while Present (Disc) loop
7192                      Append_To (Cons,
7193                        Make_Selected_Component (Loc,
7194                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
7195                          Selector_Name =>
7196                            Make_Identifier (Loc, Chars (Disc))));
7197                      Next_Discriminant (Disc);
7198                   end loop;
7199
7200                elsif Is_Array_Type (Operand_Type) then
7201                   N_Ix := First_Index (Target_Type);
7202                   Cons := New_List;
7203
7204                   for J in 1 .. Number_Dimensions (Operand_Type) loop
7205
7206                      --  We convert the bounds explicitly. We use an unchecked
7207                      --  conversion because bounds checks are done elsewhere.
7208
7209                      Append_To (Cons,
7210                        Make_Range (Loc,
7211                          Low_Bound =>
7212                            Unchecked_Convert_To (Etype (N_Ix),
7213                              Make_Attribute_Reference (Loc,
7214                                Prefix =>
7215                                  Duplicate_Subexpr_No_Checks
7216                                    (Operand, Name_Req => True),
7217                                Attribute_Name => Name_First,
7218                                Expressions    => New_List (
7219                                  Make_Integer_Literal (Loc, J)))),
7220
7221                          High_Bound =>
7222                            Unchecked_Convert_To (Etype (N_Ix),
7223                              Make_Attribute_Reference (Loc,
7224                                Prefix =>
7225                                  Duplicate_Subexpr_No_Checks
7226                                    (Operand, Name_Req => True),
7227                                Attribute_Name => Name_Last,
7228                                Expressions    => New_List (
7229                                  Make_Integer_Literal (Loc, J))))));
7230
7231                      Next_Index (N_Ix);
7232                   end loop;
7233                end if;
7234             end if;
7235
7236             Odef := New_Occurrence_Of (Target_Type, Loc);
7237
7238             if Present (Cons) then
7239                Odef :=
7240                  Make_Subtype_Indication (Loc,
7241                    Subtype_Mark => Odef,
7242                    Constraint =>
7243                      Make_Index_Or_Discriminant_Constraint (Loc,
7244                        Constraints => Cons));
7245             end if;
7246
7247             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
7248             Decl :=
7249               Make_Object_Declaration (Loc,
7250                 Defining_Identifier => Temp,
7251                 Object_Definition   => Odef);
7252
7253             Set_No_Initialization (Decl, True);
7254
7255             --  Insert required actions. It is essential to suppress checks
7256             --  since we have suppressed default initialization, which means
7257             --  that the variable we create may have no discriminants.
7258
7259             Insert_Actions (N,
7260               New_List (
7261                 Decl,
7262                 Make_Assignment_Statement (Loc,
7263                   Name => New_Occurrence_Of (Temp, Loc),
7264                   Expression => Relocate_Node (N))),
7265                 Suppress => All_Checks);
7266
7267             Rewrite (N, New_Occurrence_Of (Temp, Loc));
7268             return;
7269          end if;
7270       end Handle_Changed_Representation;
7271
7272       ----------------------
7273       -- Real_Range_Check --
7274       ----------------------
7275
7276       --  Case of conversions to floating-point or fixed-point. If range
7277       --  checks are enabled and the target type has a range constraint,
7278       --  we convert:
7279
7280       --     typ (x)
7281
7282       --       to
7283
7284       --     Tnn : typ'Base := typ'Base (x);
7285       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7286       --     Tnn
7287
7288       --  This is necessary when there is a conversion of integer to float
7289       --  or to fixed-point to ensure that the correct checks are made. It
7290       --  is not necessary for float to float where it is enough to simply
7291       --  set the Do_Range_Check flag.
7292
7293       procedure Real_Range_Check is
7294          Btyp : constant Entity_Id := Base_Type (Target_Type);
7295          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
7296          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
7297          Xtyp : constant Entity_Id := Etype (Operand);
7298          Conv : Node_Id;
7299          Tnn  : Entity_Id;
7300
7301       begin
7302          --  Nothing to do if conversion was rewritten
7303
7304          if Nkind (N) /= N_Type_Conversion then
7305             return;
7306          end if;
7307
7308          --  Nothing to do if range checks suppressed, or target has the
7309          --  same range as the base type (or is the base type).
7310
7311          if Range_Checks_Suppressed (Target_Type)
7312            or else (Lo = Type_Low_Bound (Btyp)
7313                       and then
7314                     Hi = Type_High_Bound (Btyp))
7315          then
7316             return;
7317          end if;
7318
7319          --  Nothing to do if expression is an entity on which checks
7320          --  have been suppressed.
7321
7322          if Is_Entity_Name (Operand)
7323            and then Range_Checks_Suppressed (Entity (Operand))
7324          then
7325             return;
7326          end if;
7327
7328          --  Nothing to do if bounds are all static and we can tell that
7329          --  the expression is within the bounds of the target. Note that
7330          --  if the operand is of an unconstrained floating-point type,
7331          --  then we do not trust it to be in range (might be infinite)
7332
7333          declare
7334             S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
7335             S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
7336
7337          begin
7338             if (not Is_Floating_Point_Type (Xtyp)
7339                  or else Is_Constrained (Xtyp))
7340               and then Compile_Time_Known_Value (S_Lo)
7341               and then Compile_Time_Known_Value (S_Hi)
7342               and then Compile_Time_Known_Value (Hi)
7343               and then Compile_Time_Known_Value (Lo)
7344             then
7345                declare
7346                   D_Lov : constant Ureal := Expr_Value_R (Lo);
7347                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
7348                   S_Lov : Ureal;
7349                   S_Hiv : Ureal;
7350
7351                begin
7352                   if Is_Real_Type (Xtyp) then
7353                      S_Lov := Expr_Value_R (S_Lo);
7354                      S_Hiv := Expr_Value_R (S_Hi);
7355                   else
7356                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
7357                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
7358                   end if;
7359
7360                   if D_Hiv > D_Lov
7361                     and then S_Lov >= D_Lov
7362                     and then S_Hiv <= D_Hiv
7363                   then
7364                      Set_Do_Range_Check (Operand, False);
7365                      return;
7366                   end if;
7367                end;
7368             end if;
7369          end;
7370
7371          --  For float to float conversions, we are done
7372
7373          if Is_Floating_Point_Type (Xtyp)
7374               and then
7375             Is_Floating_Point_Type (Btyp)
7376          then
7377             return;
7378          end if;
7379
7380          --  Otherwise rewrite the conversion as described above
7381
7382          Conv := Relocate_Node (N);
7383          Rewrite
7384            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
7385          Set_Etype (Conv, Btyp);
7386
7387          --  Enable overflow except for case of integer to float conversions,
7388          --  where it is never required, since we can never have overflow in
7389          --  this case.
7390
7391          if not Is_Integer_Type (Etype (Operand)) then
7392             Enable_Overflow_Check (Conv);
7393          end if;
7394
7395          Tnn :=
7396            Make_Defining_Identifier (Loc,
7397              Chars => New_Internal_Name ('T'));
7398
7399          Insert_Actions (N, New_List (
7400            Make_Object_Declaration (Loc,
7401              Defining_Identifier => Tnn,
7402              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
7403              Expression => Conv),
7404
7405            Make_Raise_Constraint_Error (Loc,
7406              Condition =>
7407               Make_Or_Else (Loc,
7408                 Left_Opnd =>
7409                   Make_Op_Lt (Loc,
7410                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
7411                     Right_Opnd =>
7412                       Make_Attribute_Reference (Loc,
7413                         Attribute_Name => Name_First,
7414                         Prefix =>
7415                           New_Occurrence_Of (Target_Type, Loc))),
7416
7417                 Right_Opnd =>
7418                   Make_Op_Gt (Loc,
7419                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
7420                     Right_Opnd =>
7421                       Make_Attribute_Reference (Loc,
7422                         Attribute_Name => Name_Last,
7423                         Prefix =>
7424                           New_Occurrence_Of (Target_Type, Loc)))),
7425              Reason => CE_Range_Check_Failed)));
7426
7427          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
7428          Analyze_And_Resolve (N, Btyp);
7429       end Real_Range_Check;
7430
7431    --  Start of processing for Expand_N_Type_Conversion
7432
7433    begin
7434       --  Nothing at all to do if conversion is to the identical type
7435       --  so remove the conversion completely, it is useless.
7436
7437       if Operand_Type = Target_Type then
7438          Rewrite (N, Relocate_Node (Operand));
7439          return;
7440       end if;
7441
7442       --  Nothing to do if this is the second argument of read. This
7443       --  is a "backwards" conversion that will be handled by the
7444       --  specialized code in attribute processing.
7445
7446       if Nkind (Parent (N)) = N_Attribute_Reference
7447         and then Attribute_Name (Parent (N)) = Name_Read
7448         and then Next (First (Expressions (Parent (N)))) = N
7449       then
7450          return;
7451       end if;
7452
7453       --  Here if we may need to expand conversion
7454
7455       --  Do validity check if validity checking operands
7456
7457       if Validity_Checks_On
7458         and then Validity_Check_Operands
7459       then
7460          Ensure_Valid (Operand);
7461       end if;
7462
7463       --  Special case of converting from non-standard boolean type
7464
7465       if Is_Boolean_Type (Operand_Type)
7466         and then (Nonzero_Is_True (Operand_Type))
7467       then
7468          Adjust_Condition (Operand);
7469          Set_Etype (Operand, Standard_Boolean);
7470          Operand_Type := Standard_Boolean;
7471       end if;
7472
7473       --  Case of converting to an access type
7474
7475       if Is_Access_Type (Target_Type) then
7476
7477          --  Apply an accessibility check when the conversion operand is an
7478          --  access parameter (or a renaming thereof), unless conversion was
7479          --  expanded from an unchecked or unrestricted access attribute. Note
7480          --  that other checks may still need to be applied below (such as
7481          --  tagged type checks).
7482
7483          if Is_Entity_Name (Operand)
7484            and then
7485              (Is_Formal (Entity (Operand))
7486                or else
7487                  (Present (Renamed_Object (Entity (Operand)))
7488                    and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
7489                    and then Is_Formal
7490                               (Entity (Renamed_Object (Entity (Operand))))))
7491            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
7492            and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
7493                       or else Attribute_Name (Original_Node (N)) = Name_Access)
7494          then
7495             Apply_Accessibility_Check (Operand, Target_Type);
7496
7497          --  If the level of the operand type is statically deeper
7498          --  then the level of the target type, then force Program_Error.
7499          --  Note that this can only occur for cases where the attribute
7500          --  is within the body of an instantiation (otherwise the
7501          --  conversion will already have been rejected as illegal).
7502          --  Note: warnings are issued by the analyzer for the instance
7503          --  cases.
7504
7505          elsif In_Instance_Body
7506            and then Type_Access_Level (Operand_Type) >
7507                     Type_Access_Level (Target_Type)
7508          then
7509             Rewrite (N,
7510               Make_Raise_Program_Error (Sloc (N),
7511                 Reason => PE_Accessibility_Check_Failed));
7512             Set_Etype (N, Target_Type);
7513
7514          --  When the operand is a selected access discriminant
7515          --  the check needs to be made against the level of the
7516          --  object denoted by the prefix of the selected name.
7517          --  Force Program_Error for this case as well (this
7518          --  accessibility violation can only happen if within
7519          --  the body of an instantiation).
7520
7521          elsif In_Instance_Body
7522            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
7523            and then Nkind (Operand) = N_Selected_Component
7524            and then Object_Access_Level (Operand) >
7525                       Type_Access_Level (Target_Type)
7526          then
7527             Rewrite (N,
7528               Make_Raise_Program_Error (Sloc (N),
7529                 Reason => PE_Accessibility_Check_Failed));
7530             Set_Etype (N, Target_Type);
7531          end if;
7532       end if;
7533
7534       --  Case of conversions of tagged types and access to tagged types
7535
7536       --  When needed, that is to say when the expression is class-wide,
7537       --  Add runtime a tag check for (strict) downward conversion by using
7538       --  the membership test, generating:
7539
7540       --      [constraint_error when Operand not in Target_Type'Class]
7541
7542       --  or in the access type case
7543
7544       --      [constraint_error
7545       --        when Operand /= null
7546       --          and then Operand.all not in
7547       --            Designated_Type (Target_Type)'Class]
7548
7549       if (Is_Access_Type (Target_Type)
7550            and then Is_Tagged_Type (Designated_Type (Target_Type)))
7551         or else Is_Tagged_Type (Target_Type)
7552       then
7553          --  Do not do any expansion in the access type case if the
7554          --  parent is a renaming, since this is an error situation
7555          --  which will be caught by Sem_Ch8, and the expansion can
7556          --  intefere with this error check.
7557
7558          if Is_Access_Type (Target_Type)
7559            and then Is_Renamed_Object (N)
7560          then
7561             return;
7562          end if;
7563
7564          --  Otherwise, proceed with processing tagged conversion
7565
7566          declare
7567             Actual_Operand_Type : Entity_Id;
7568             Actual_Target_Type  : Entity_Id;
7569
7570             Cond : Node_Id;
7571
7572          begin
7573             if Is_Access_Type (Target_Type) then
7574                Actual_Operand_Type := Designated_Type (Operand_Type);
7575                Actual_Target_Type  := Designated_Type (Target_Type);
7576
7577             else
7578                Actual_Operand_Type := Operand_Type;
7579                Actual_Target_Type  := Target_Type;
7580             end if;
7581
7582             --  Ada 2005 (AI-251): Handle interface type conversion
7583
7584             if Is_Interface (Actual_Operand_Type) then
7585                Expand_Interface_Conversion (N, Is_Static => False);
7586                return;
7587             end if;
7588
7589             if Is_Class_Wide_Type (Actual_Operand_Type)
7590               and then Root_Type (Actual_Operand_Type) /=  Actual_Target_Type
7591               and then Is_Ancestor
7592                          (Root_Type (Actual_Operand_Type),
7593                           Actual_Target_Type)
7594               and then not Tag_Checks_Suppressed (Actual_Target_Type)
7595             then
7596                --  The conversion is valid for any descendant of the
7597                --  target type
7598
7599                Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
7600
7601                if Is_Access_Type (Target_Type) then
7602                   Cond :=
7603                      Make_And_Then (Loc,
7604                        Left_Opnd =>
7605                          Make_Op_Ne (Loc,
7606                            Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
7607                            Right_Opnd => Make_Null (Loc)),
7608
7609                        Right_Opnd =>
7610                          Make_Not_In (Loc,
7611                            Left_Opnd  =>
7612                              Make_Explicit_Dereference (Loc,
7613                                Prefix =>
7614                                  Duplicate_Subexpr_No_Checks (Operand)),
7615                            Right_Opnd =>
7616                              New_Reference_To (Actual_Target_Type, Loc)));
7617
7618                else
7619                   Cond :=
7620                     Make_Not_In (Loc,
7621                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
7622                       Right_Opnd =>
7623                         New_Reference_To (Actual_Target_Type, Loc));
7624                end if;
7625
7626                Insert_Action (N,
7627                  Make_Raise_Constraint_Error (Loc,
7628                    Condition => Cond,
7629                    Reason    => CE_Tag_Check_Failed));
7630
7631                declare
7632                   Conv : Node_Id;
7633                begin
7634                   Conv :=
7635                     Make_Unchecked_Type_Conversion (Loc,
7636                       Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
7637                       Expression => Relocate_Node (Expression (N)));
7638                   Rewrite (N, Conv);
7639                   Analyze_And_Resolve (N, Target_Type);
7640                end;
7641             end if;
7642          end;
7643
7644       --  Case of other access type conversions
7645
7646       elsif Is_Access_Type (Target_Type) then
7647          Apply_Constraint_Check (Operand, Target_Type);
7648
7649       --  Case of conversions from a fixed-point type
7650
7651       --  These conversions require special expansion and processing, found
7652       --  in the Exp_Fixd package. We ignore cases where Conversion_OK is
7653       --  set, since from a semantic point of view, these are simple integer
7654       --  conversions, which do not need further processing.
7655
7656       elsif Is_Fixed_Point_Type (Operand_Type)
7657         and then not Conversion_OK (N)
7658       then
7659          --  We should never see universal fixed at this case, since the
7660          --  expansion of the constituent divide or multiply should have
7661          --  eliminated the explicit mention of universal fixed.
7662
7663          pragma Assert (Operand_Type /= Universal_Fixed);
7664
7665          --  Check for special case of the conversion to universal real
7666          --  that occurs as a result of the use of a round attribute.
7667          --  In this case, the real type for the conversion is taken
7668          --  from the target type of the Round attribute and the
7669          --  result must be marked as rounded.
7670
7671          if Target_Type = Universal_Real
7672            and then Nkind (Parent (N)) = N_Attribute_Reference
7673            and then Attribute_Name (Parent (N)) = Name_Round
7674          then
7675             Set_Rounded_Result (N);
7676             Set_Etype (N, Etype (Parent (N)));
7677          end if;
7678
7679          --  Otherwise do correct fixed-conversion, but skip these if the
7680          --  Conversion_OK flag is set, because from a semantic point of
7681          --  view these are simple integer conversions needing no further
7682          --  processing (the backend will simply treat them as integers)
7683
7684          if not Conversion_OK (N) then
7685             if Is_Fixed_Point_Type (Etype (N)) then
7686                Expand_Convert_Fixed_To_Fixed (N);
7687                Real_Range_Check;
7688
7689             elsif Is_Integer_Type (Etype (N)) then
7690                Expand_Convert_Fixed_To_Integer (N);
7691
7692             else
7693                pragma Assert (Is_Floating_Point_Type (Etype (N)));
7694                Expand_Convert_Fixed_To_Float (N);
7695                Real_Range_Check;
7696             end if;
7697          end if;
7698
7699       --  Case of conversions to a fixed-point type
7700
7701       --  These conversions require special expansion and processing, found
7702       --  in the Exp_Fixd package. Again, ignore cases where Conversion_OK
7703       --  is set, since from a semantic point of view, these are simple
7704       --  integer conversions, which do not need further processing.
7705
7706       elsif Is_Fixed_Point_Type (Target_Type)
7707         and then not Conversion_OK (N)
7708       then
7709          if Is_Integer_Type (Operand_Type) then
7710             Expand_Convert_Integer_To_Fixed (N);
7711             Real_Range_Check;
7712          else
7713             pragma Assert (Is_Floating_Point_Type (Operand_Type));
7714             Expand_Convert_Float_To_Fixed (N);
7715             Real_Range_Check;
7716          end if;
7717
7718       --  Case of float-to-integer conversions
7719
7720       --  We also handle float-to-fixed conversions with Conversion_OK set
7721       --  since semantically the fixed-point target is treated as though it
7722       --  were an integer in such cases.
7723
7724       elsif Is_Floating_Point_Type (Operand_Type)
7725         and then
7726           (Is_Integer_Type (Target_Type)
7727             or else
7728           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
7729       then
7730          --  One more check here, gcc is still not able to do conversions of
7731          --  this type with proper overflow checking, and so gigi is doing an
7732          --  approximation of what is required by doing floating-point compares
7733          --  with the end-point. But that can lose precision in some cases, and
7734          --  give a wrong result. Converting the operand to Universal_Real is
7735          --  helpful, but still does not catch all cases with 64-bit integers
7736          --  on targets with only 64-bit floats
7737
7738          --  The above comment seems obsoleted by Apply_Float_Conversion_Check
7739          --  Can this code be removed ???
7740
7741          if Do_Range_Check (Operand) then
7742             Rewrite (Operand,
7743               Make_Type_Conversion (Loc,
7744                 Subtype_Mark =>
7745                   New_Occurrence_Of (Universal_Real, Loc),
7746                 Expression =>
7747                   Relocate_Node (Operand)));
7748
7749             Set_Etype (Operand, Universal_Real);
7750             Enable_Range_Check (Operand);
7751             Set_Do_Range_Check (Expression (Operand), False);
7752          end if;
7753
7754       --  Case of array conversions
7755
7756       --  Expansion of array conversions, add required length/range checks
7757       --  but only do this if there is no change of representation. For
7758       --  handling of this case, see Handle_Changed_Representation.
7759
7760       elsif Is_Array_Type (Target_Type) then
7761
7762          if Is_Constrained (Target_Type) then
7763             Apply_Length_Check (Operand, Target_Type);
7764          else
7765             Apply_Range_Check (Operand, Target_Type);
7766          end if;
7767
7768          Handle_Changed_Representation;
7769
7770       --  Case of conversions of discriminated types
7771
7772       --  Add required discriminant checks if target is constrained. Again
7773       --  this change is skipped if we have a change of representation.
7774
7775       elsif Has_Discriminants (Target_Type)
7776         and then Is_Constrained (Target_Type)
7777       then
7778          Apply_Discriminant_Check (Operand, Target_Type);
7779          Handle_Changed_Representation;
7780
7781       --  Case of all other record conversions. The only processing required
7782       --  is to check for a change of representation requiring the special
7783       --  assignment processing.
7784
7785       elsif Is_Record_Type (Target_Type) then
7786
7787          --  Ada 2005 (AI-216): Program_Error is raised when converting from
7788          --  a derived Unchecked_Union type to an unconstrained non-Unchecked_
7789          --  Union type if the operand lacks inferable discriminants.
7790
7791          if Is_Derived_Type (Operand_Type)
7792            and then Is_Unchecked_Union (Base_Type (Operand_Type))
7793            and then not Is_Constrained (Target_Type)
7794            and then not Is_Unchecked_Union (Base_Type (Target_Type))
7795            and then not Has_Inferable_Discriminants (Operand)
7796          then
7797             --  To prevent Gigi from generating illegal code, we make a
7798             --  Program_Error node, but we give it the target type of the
7799             --  conversion.
7800
7801             declare
7802                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
7803                       Reason => PE_Unchecked_Union_Restriction);
7804
7805             begin
7806                Set_Etype (PE, Target_Type);
7807                Rewrite (N, PE);
7808
7809             end;
7810          else
7811             Handle_Changed_Representation;
7812          end if;
7813
7814       --  Case of conversions of enumeration types
7815
7816       elsif Is_Enumeration_Type (Target_Type) then
7817
7818          --  Special processing is required if there is a change of
7819          --  representation (from enumeration representation clauses)
7820
7821          if not Same_Representation (Target_Type, Operand_Type) then
7822
7823             --  Convert: x(y) to x'val (ytyp'val (y))
7824
7825             Rewrite (N,
7826                Make_Attribute_Reference (Loc,
7827                  Prefix => New_Occurrence_Of (Target_Type, Loc),
7828                  Attribute_Name => Name_Val,
7829                  Expressions => New_List (
7830                    Make_Attribute_Reference (Loc,
7831                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
7832                      Attribute_Name => Name_Pos,
7833                      Expressions => New_List (Operand)))));
7834
7835             Analyze_And_Resolve (N, Target_Type);
7836          end if;
7837
7838       --  Case of conversions to floating-point
7839
7840       elsif Is_Floating_Point_Type (Target_Type) then
7841          Real_Range_Check;
7842       end if;
7843
7844       --  At this stage, either the conversion node has been transformed
7845       --  into some other equivalent expression, or left as a conversion
7846       --  that can be handled by Gigi. The conversions that Gigi can handle
7847       --  are the following:
7848
7849       --    Conversions with no change of representation or type
7850
7851       --    Numeric conversions involving integer values, floating-point
7852       --    values, and fixed-point values. Fixed-point values are allowed
7853       --    only if Conversion_OK is set, i.e. if the fixed-point values
7854       --    are to be treated as integers.
7855
7856       --  No other conversions should be passed to Gigi
7857
7858       --  Check: are these rules stated in sinfo??? if so, why restate here???
7859
7860       --  The only remaining step is to generate a range check if we still
7861       --  have a type conversion at this stage and Do_Range_Check is set.
7862       --  For now we do this only for conversions of discrete types.
7863
7864       if Nkind (N) = N_Type_Conversion
7865         and then Is_Discrete_Type (Etype (N))
7866       then
7867          declare
7868             Expr : constant Node_Id := Expression (N);
7869             Ftyp : Entity_Id;
7870             Ityp : Entity_Id;
7871
7872          begin
7873             if Do_Range_Check (Expr)
7874               and then Is_Discrete_Type (Etype (Expr))
7875             then
7876                Set_Do_Range_Check (Expr, False);
7877
7878                --  Before we do a range check, we have to deal with treating
7879                --  a fixed-point operand as an integer. The way we do this
7880                --  is simply to do an unchecked conversion to an appropriate
7881                --  integer type large enough to hold the result.
7882
7883                --  This code is not active yet, because we are only dealing
7884                --  with discrete types so far ???
7885
7886                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
7887                  and then Treat_Fixed_As_Integer (Expr)
7888                then
7889                   Ftyp := Base_Type (Etype (Expr));
7890
7891                   if Esize (Ftyp) >= Esize (Standard_Integer) then
7892                      Ityp := Standard_Long_Long_Integer;
7893                   else
7894                      Ityp := Standard_Integer;
7895                   end if;
7896
7897                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
7898                end if;
7899
7900                --  Reset overflow flag, since the range check will include
7901                --  dealing with possible overflow, and generate the check
7902                --  If Address is either source or target type, suppress
7903                --  range check to avoid typing anomalies when it is a visible
7904                --  integer type.
7905
7906                Set_Do_Overflow_Check (N, False);
7907                if not Is_Descendent_Of_Address (Etype (Expr))
7908                  and then not Is_Descendent_Of_Address (Target_Type)
7909                then
7910                   Generate_Range_Check
7911                     (Expr, Target_Type, CE_Range_Check_Failed);
7912                end if;
7913             end if;
7914          end;
7915       end if;
7916
7917       --  Final step, if the result is a type conversion involving Vax_Float
7918       --  types, then it is subject for further special processing.
7919
7920       if Nkind (N) = N_Type_Conversion
7921         and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
7922       then
7923          Expand_Vax_Conversion (N);
7924          return;
7925       end if;
7926    end Expand_N_Type_Conversion;
7927
7928    -----------------------------------
7929    -- Expand_N_Unchecked_Expression --
7930    -----------------------------------
7931
7932    --  Remove the unchecked expression node from the tree. It's job was simply
7933    --  to make sure that its constituent expression was handled with checks
7934    --  off, and now that that is done, we can remove it from the tree, and
7935    --  indeed must, since gigi does not expect to see these nodes.
7936
7937    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
7938       Exp : constant Node_Id := Expression (N);
7939
7940    begin
7941       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
7942       Rewrite (N, Exp);
7943    end Expand_N_Unchecked_Expression;
7944
7945    ----------------------------------------
7946    -- Expand_N_Unchecked_Type_Conversion --
7947    ----------------------------------------
7948
7949    --  If this cannot be handled by Gigi and we haven't already made
7950    --  a temporary for it, do it now.
7951
7952    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
7953       Target_Type  : constant Entity_Id := Etype (N);
7954       Operand      : constant Node_Id   := Expression (N);
7955       Operand_Type : constant Entity_Id := Etype (Operand);
7956
7957    begin
7958       --  If we have a conversion of a compile time known value to a target
7959       --  type and the value is in range of the target type, then we can simply
7960       --  replace the construct by an integer literal of the correct type. We
7961       --  only apply this to integer types being converted. Possibly it may
7962       --  apply in other cases, but it is too much trouble to worry about.
7963
7964       --  Note that we do not do this transformation if the Kill_Range_Check
7965       --  flag is set, since then the value may be outside the expected range.
7966       --  This happens in the Normalize_Scalars case.
7967
7968       --  We also skip this if either the target or operand type is biased
7969       --  because in this case, the unchecked conversion is supposed to
7970       --  preserve the bit pattern, not the integer value.
7971
7972       if Is_Integer_Type (Target_Type)
7973         and then not Has_Biased_Representation (Target_Type)
7974         and then Is_Integer_Type (Operand_Type)
7975         and then not Has_Biased_Representation (Operand_Type)
7976         and then Compile_Time_Known_Value (Operand)
7977         and then not Kill_Range_Check (N)
7978       then
7979          declare
7980             Val : constant Uint := Expr_Value (Operand);
7981
7982          begin
7983             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
7984                  and then
7985                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
7986                  and then
7987                Val >= Expr_Value (Type_Low_Bound (Target_Type))
7988                  and then
7989                Val <= Expr_Value (Type_High_Bound (Target_Type))
7990             then
7991                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
7992
7993                --  If Address is the target type, just set the type
7994                --  to avoid a spurious type error on the literal when
7995                --  Address is a visible integer type.
7996
7997                if Is_Descendent_Of_Address (Target_Type) then
7998                   Set_Etype (N, Target_Type);
7999                else
8000                   Analyze_And_Resolve (N, Target_Type);
8001                end if;
8002
8003                return;
8004             end if;
8005          end;
8006       end if;
8007
8008       --  Nothing to do if conversion is safe
8009
8010       if Safe_Unchecked_Type_Conversion (N) then
8011          return;
8012       end if;
8013
8014       --  Otherwise force evaluation unless Assignment_OK flag is set (this
8015       --  flag indicates ??? -- more comments needed here)
8016
8017       if Assignment_OK (N) then
8018          null;
8019       else
8020          Force_Evaluation (N);
8021       end if;
8022    end Expand_N_Unchecked_Type_Conversion;
8023
8024    ----------------------------
8025    -- Expand_Record_Equality --
8026    ----------------------------
8027
8028    --  For non-variant records, Equality is expanded when needed into:
8029
8030    --      and then Lhs.Discr1 = Rhs.Discr1
8031    --      and then ...
8032    --      and then Lhs.Discrn = Rhs.Discrn
8033    --      and then Lhs.Cmp1 = Rhs.Cmp1
8034    --      and then ...
8035    --      and then Lhs.Cmpn = Rhs.Cmpn
8036
8037    --  The expression is folded by the back-end for adjacent fields. This
8038    --  function is called for tagged record in only one occasion: for imple-
8039    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
8040    --  otherwise the primitive "=" is used directly.
8041
8042    function Expand_Record_Equality
8043      (Nod    : Node_Id;
8044       Typ    : Entity_Id;
8045       Lhs    : Node_Id;
8046       Rhs    : Node_Id;
8047       Bodies : List_Id) return Node_Id
8048    is
8049       Loc : constant Source_Ptr := Sloc (Nod);
8050
8051       Result : Node_Id;
8052       C      : Entity_Id;
8053
8054       First_Time : Boolean := True;
8055
8056       function Suitable_Element (C : Entity_Id) return Entity_Id;
8057       --  Return the first field to compare beginning with C, skipping the
8058       --  inherited components.
8059
8060       ----------------------
8061       -- Suitable_Element --
8062       ----------------------
8063
8064       function Suitable_Element (C : Entity_Id) return Entity_Id is
8065       begin
8066          if No (C) then
8067             return Empty;
8068
8069          elsif Ekind (C) /= E_Discriminant
8070            and then Ekind (C) /= E_Component
8071          then
8072             return Suitable_Element (Next_Entity (C));
8073
8074          elsif Is_Tagged_Type (Typ)
8075            and then C /= Original_Record_Component (C)
8076          then
8077             return Suitable_Element (Next_Entity (C));
8078
8079          elsif Chars (C) = Name_uController
8080            or else Chars (C) = Name_uTag
8081          then
8082             return Suitable_Element (Next_Entity (C));
8083
8084          elsif Is_Interface (Etype (C)) then
8085             return Suitable_Element (Next_Entity (C));
8086
8087          else
8088             return C;
8089          end if;
8090       end Suitable_Element;
8091
8092    --  Start of processing for Expand_Record_Equality
8093
8094    begin
8095       --  Generates the following code: (assuming that Typ has one Discr and
8096       --  component C2 is also a record)
8097
8098       --   True
8099       --     and then Lhs.Discr1 = Rhs.Discr1
8100       --     and then Lhs.C1 = Rhs.C1
8101       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8102       --     and then ...
8103       --     and then Lhs.Cmpn = Rhs.Cmpn
8104
8105       Result := New_Reference_To (Standard_True, Loc);
8106       C := Suitable_Element (First_Entity (Typ));
8107
8108       while Present (C) loop
8109          declare
8110             New_Lhs : Node_Id;
8111             New_Rhs : Node_Id;
8112             Check   : Node_Id;
8113
8114          begin
8115             if First_Time then
8116                First_Time := False;
8117                New_Lhs := Lhs;
8118                New_Rhs := Rhs;
8119             else
8120                New_Lhs := New_Copy_Tree (Lhs);
8121                New_Rhs := New_Copy_Tree (Rhs);
8122             end if;
8123
8124             Check :=
8125               Expand_Composite_Equality (Nod, Etype (C),
8126                Lhs =>
8127                  Make_Selected_Component (Loc,
8128                    Prefix => New_Lhs,
8129                    Selector_Name => New_Reference_To (C, Loc)),
8130                Rhs =>
8131                  Make_Selected_Component (Loc,
8132                    Prefix => New_Rhs,
8133                    Selector_Name => New_Reference_To (C, Loc)),
8134                Bodies => Bodies);
8135
8136             --  If some (sub)component is an unchecked_union, the whole
8137             --  operation will raise program error.
8138
8139             if Nkind (Check) = N_Raise_Program_Error then
8140                Result := Check;
8141                Set_Etype (Result, Standard_Boolean);
8142                exit;
8143             else
8144                Result :=
8145                  Make_And_Then (Loc,
8146                    Left_Opnd  => Result,
8147                    Right_Opnd => Check);
8148             end if;
8149          end;
8150
8151          C := Suitable_Element (Next_Entity (C));
8152       end loop;
8153
8154       return Result;
8155    end Expand_Record_Equality;
8156
8157    -------------------------------------
8158    -- Fixup_Universal_Fixed_Operation --
8159    -------------------------------------
8160
8161    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
8162       Conv : constant Node_Id := Parent (N);
8163
8164    begin
8165       --  We must have a type conversion immediately above us
8166
8167       pragma Assert (Nkind (Conv) = N_Type_Conversion);
8168
8169       --  Normally the type conversion gives our target type. The exception
8170       --  occurs in the case of the Round attribute, where the conversion
8171       --  will be to universal real, and our real type comes from the Round
8172       --  attribute (as well as an indication that we must round the result)
8173
8174       if Nkind (Parent (Conv)) = N_Attribute_Reference
8175         and then Attribute_Name (Parent (Conv)) = Name_Round
8176       then
8177          Set_Etype (N, Etype (Parent (Conv)));
8178          Set_Rounded_Result (N);
8179
8180       --  Normal case where type comes from conversion above us
8181
8182       else
8183          Set_Etype (N, Etype (Conv));
8184       end if;
8185    end Fixup_Universal_Fixed_Operation;
8186
8187    ------------------------------
8188    -- Get_Allocator_Final_List --
8189    ------------------------------
8190
8191    function Get_Allocator_Final_List
8192      (N    : Node_Id;
8193       T    : Entity_Id;
8194       PtrT : Entity_Id) return Entity_Id
8195    is
8196       Loc : constant Source_Ptr := Sloc (N);
8197
8198       Owner : Entity_Id := PtrT;
8199       --  The entity whose finalization list must be used to attach the
8200       --  allocated object.
8201
8202    begin
8203       if Ekind (PtrT) = E_Anonymous_Access_Type then
8204
8205          --  If the context is an access parameter, we need to create a
8206          --  non-anonymous access type in order to have a usable final list,
8207          --  because there is otherwise no pool to which the allocated object
8208          --  can belong. We create both the type and the finalization chain
8209          --  here, because freezing an internal type does not create such a
8210          --  chain. The Final_Chain that is thus created is shared by the
8211          --  access parameter. The access type is tested against the result
8212          --  type of the function to exclude allocators whose type is an
8213          --  anonymous access result type.
8214
8215          if Nkind (Associated_Node_For_Itype (PtrT))
8216               in N_Subprogram_Specification
8217            and then
8218              PtrT /=
8219                Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT)))
8220          then
8221             Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
8222             Insert_Action (N,
8223               Make_Full_Type_Declaration (Loc,
8224                 Defining_Identifier => Owner,
8225                 Type_Definition =>
8226                    Make_Access_To_Object_Definition (Loc,
8227                      Subtype_Indication =>
8228                        New_Occurrence_Of (T, Loc))));
8229
8230             Build_Final_List (N, Owner);
8231             Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
8232
8233          --  Ada 2005 (AI-318-02): If the context is a return object
8234          --  declaration, then the anonymous return subtype is defined to have
8235          --  the same accessibility level as that of the function's result
8236          --  subtype, which means that we want the scope where the function is
8237          --  declared.
8238
8239          elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration
8240            and then Ekind (Scope (PtrT)) = E_Return_Statement
8241          then
8242             Owner := Scope (Return_Applies_To (Scope (PtrT)));
8243
8244          --  Case of an access discriminant, or (Ada 2005), of an anonymous
8245          --  access component or anonymous access function result: find the
8246          --  final list associated with the scope of the type. (In the
8247          --  anonymous access component kind, a list controller will have
8248          --  been allocated when freezing the record type, and PtrT has an
8249          --  Associated_Final_Chain attribute designating it.)
8250
8251          elsif No (Associated_Final_Chain (PtrT)) then
8252             Owner := Scope (PtrT);
8253          end if;
8254       end if;
8255
8256       return Find_Final_List (Owner);
8257    end Get_Allocator_Final_List;
8258
8259    ---------------------------------
8260    -- Has_Inferable_Discriminants --
8261    ---------------------------------
8262
8263    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
8264
8265       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
8266       --  Determines whether the left-most prefix of a selected component is a
8267       --  formal parameter in a subprogram. Assumes N is a selected component.
8268
8269       --------------------------------
8270       -- Prefix_Is_Formal_Parameter --
8271       --------------------------------
8272
8273       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
8274          Sel_Comp : Node_Id := N;
8275
8276       begin
8277          --  Move to the left-most prefix by climbing up the tree
8278
8279          while Present (Parent (Sel_Comp))
8280            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
8281          loop
8282             Sel_Comp := Parent (Sel_Comp);
8283          end loop;
8284
8285          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
8286       end Prefix_Is_Formal_Parameter;
8287
8288    --  Start of processing for Has_Inferable_Discriminants
8289
8290    begin
8291       --  For identifiers and indexed components, it is sufficent to have a
8292       --  constrained Unchecked_Union nominal subtype.
8293
8294       if Nkind (N) = N_Identifier
8295            or else
8296          Nkind (N) = N_Indexed_Component
8297       then
8298          return Is_Unchecked_Union (Base_Type (Etype (N)))
8299                   and then
8300                 Is_Constrained (Etype (N));
8301
8302       --  For selected components, the subtype of the selector must be a
8303       --  constrained Unchecked_Union. If the component is subject to a
8304       --  per-object constraint, then the enclosing object must have inferable
8305       --  discriminants.
8306
8307       elsif Nkind (N) = N_Selected_Component then
8308          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
8309
8310             --  A small hack. If we have a per-object constrained selected
8311             --  component of a formal parameter, return True since we do not
8312             --  know the actual parameter association yet.
8313
8314             if Prefix_Is_Formal_Parameter (N) then
8315                return True;
8316             end if;
8317
8318             --  Otherwise, check the enclosing object and the selector
8319
8320             return Has_Inferable_Discriminants (Prefix (N))
8321                      and then
8322                    Has_Inferable_Discriminants (Selector_Name (N));
8323          end if;
8324
8325          --  The call to Has_Inferable_Discriminants will determine whether
8326          --  the selector has a constrained Unchecked_Union nominal type.
8327
8328          return Has_Inferable_Discriminants (Selector_Name (N));
8329
8330       --  A qualified expression has inferable discriminants if its subtype
8331       --  mark is a constrained Unchecked_Union subtype.
8332
8333       elsif Nkind (N) = N_Qualified_Expression then
8334          return Is_Unchecked_Union (Subtype_Mark (N))
8335                   and then
8336                 Is_Constrained (Subtype_Mark (N));
8337
8338       end if;
8339
8340       return False;
8341    end Has_Inferable_Discriminants;
8342
8343    -------------------------------
8344    -- Insert_Dereference_Action --
8345    -------------------------------
8346
8347    procedure Insert_Dereference_Action (N : Node_Id) is
8348       Loc  : constant Source_Ptr := Sloc (N);
8349       Typ  : constant Entity_Id  := Etype (N);
8350       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
8351       Pnod : constant Node_Id    := Parent (N);
8352
8353       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
8354       --  Return true if type of P is derived from Checked_Pool;
8355
8356       -----------------------------
8357       -- Is_Checked_Storage_Pool --
8358       -----------------------------
8359
8360       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
8361          T : Entity_Id;
8362
8363       begin
8364          if No (P) then
8365             return False;
8366          end if;
8367
8368          T := Etype (P);
8369          while T /= Etype (T) loop
8370             if Is_RTE (T, RE_Checked_Pool) then
8371                return True;
8372             else
8373                T := Etype (T);
8374             end if;
8375          end loop;
8376
8377          return False;
8378       end Is_Checked_Storage_Pool;
8379
8380    --  Start of processing for Insert_Dereference_Action
8381
8382    begin
8383       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
8384
8385       if not (Is_Checked_Storage_Pool (Pool)
8386               and then Comes_From_Source (Original_Node (Pnod)))
8387       then
8388          return;
8389       end if;
8390
8391       Insert_Action (N,
8392         Make_Procedure_Call_Statement (Loc,
8393           Name => New_Reference_To (
8394             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
8395
8396           Parameter_Associations => New_List (
8397
8398             --  Pool
8399
8400              New_Reference_To (Pool, Loc),
8401
8402             --  Storage_Address. We use the attribute Pool_Address,
8403             --  which uses the pointer itself to find the address of
8404             --  the object, and which handles unconstrained arrays
8405             --  properly by computing the address of the template.
8406             --  i.e. the correct address of the corresponding allocation.
8407
8408              Make_Attribute_Reference (Loc,
8409                Prefix         => Duplicate_Subexpr_Move_Checks (N),
8410                Attribute_Name => Name_Pool_Address),
8411
8412             --  Size_In_Storage_Elements
8413
8414              Make_Op_Divide (Loc,
8415                Left_Opnd  =>
8416                 Make_Attribute_Reference (Loc,
8417                   Prefix         =>
8418                     Make_Explicit_Dereference (Loc,
8419                       Duplicate_Subexpr_Move_Checks (N)),
8420                   Attribute_Name => Name_Size),
8421                Right_Opnd =>
8422                  Make_Integer_Literal (Loc, System_Storage_Unit)),
8423
8424             --  Alignment
8425
8426              Make_Attribute_Reference (Loc,
8427                Prefix         =>
8428                  Make_Explicit_Dereference (Loc,
8429                    Duplicate_Subexpr_Move_Checks (N)),
8430                Attribute_Name => Name_Alignment))));
8431
8432    exception
8433       when RE_Not_Available =>
8434          return;
8435    end Insert_Dereference_Action;
8436
8437    ------------------------------
8438    -- Make_Array_Comparison_Op --
8439    ------------------------------
8440
8441    --  This is a hand-coded expansion of the following generic function:
8442
8443    --  generic
8444    --    type elem is  (<>);
8445    --    type index is (<>);
8446    --    type a is array (index range <>) of elem;
8447
8448    --  function Gnnn (X : a; Y: a) return boolean is
8449    --    J : index := Y'first;
8450
8451    --  begin
8452    --    if X'length = 0 then
8453    --       return false;
8454
8455    --    elsif Y'length = 0 then
8456    --       return true;
8457
8458    --    else
8459    --      for I in X'range loop
8460    --        if X (I) = Y (J) then
8461    --          if J = Y'last then
8462    --            exit;
8463    --          else
8464    --            J := index'succ (J);
8465    --          end if;
8466
8467    --        else
8468    --           return X (I) > Y (J);
8469    --        end if;
8470    --      end loop;
8471
8472    --      return X'length > Y'length;
8473    --    end if;
8474    --  end Gnnn;
8475
8476    --  Note that since we are essentially doing this expansion by hand, we
8477    --  do not need to generate an actual or formal generic part, just the
8478    --  instantiated function itself.
8479
8480    function Make_Array_Comparison_Op
8481      (Typ : Entity_Id;
8482       Nod : Node_Id) return Node_Id
8483    is
8484       Loc : constant Source_Ptr := Sloc (Nod);
8485
8486       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
8487       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
8488       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
8489       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8490
8491       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
8492
8493       Loop_Statement : Node_Id;
8494       Loop_Body      : Node_Id;
8495       If_Stat        : Node_Id;
8496       Inner_If       : Node_Id;
8497       Final_Expr     : Node_Id;
8498       Func_Body      : Node_Id;
8499       Func_Name      : Entity_Id;
8500       Formals        : List_Id;
8501       Length1        : Node_Id;
8502       Length2        : Node_Id;
8503
8504    begin
8505       --  if J = Y'last then
8506       --     exit;
8507       --  else
8508       --     J := index'succ (J);
8509       --  end if;
8510
8511       Inner_If :=
8512         Make_Implicit_If_Statement (Nod,
8513           Condition =>
8514             Make_Op_Eq (Loc,
8515               Left_Opnd => New_Reference_To (J, Loc),
8516               Right_Opnd =>
8517                 Make_Attribute_Reference (Loc,
8518                   Prefix => New_Reference_To (Y, Loc),
8519                   Attribute_Name => Name_Last)),
8520
8521           Then_Statements => New_List (
8522                 Make_Exit_Statement (Loc)),
8523
8524           Else_Statements =>
8525             New_List (
8526               Make_Assignment_Statement (Loc,
8527                 Name => New_Reference_To (J, Loc),
8528                 Expression =>
8529                   Make_Attribute_Reference (Loc,
8530                     Prefix => New_Reference_To (Index, Loc),
8531                     Attribute_Name => Name_Succ,
8532                     Expressions => New_List (New_Reference_To (J, Loc))))));
8533
8534       --  if X (I) = Y (J) then
8535       --     if ... end if;
8536       --  else
8537       --     return X (I) > Y (J);
8538       --  end if;
8539
8540       Loop_Body :=
8541         Make_Implicit_If_Statement (Nod,
8542           Condition =>
8543             Make_Op_Eq (Loc,
8544               Left_Opnd =>
8545                 Make_Indexed_Component (Loc,
8546                   Prefix      => New_Reference_To (X, Loc),
8547                   Expressions => New_List (New_Reference_To (I, Loc))),
8548
8549               Right_Opnd =>
8550                 Make_Indexed_Component (Loc,
8551                   Prefix      => New_Reference_To (Y, Loc),
8552                   Expressions => New_List (New_Reference_To (J, Loc)))),
8553
8554           Then_Statements => New_List (Inner_If),
8555
8556           Else_Statements => New_List (
8557             Make_Simple_Return_Statement (Loc,
8558               Expression =>
8559                 Make_Op_Gt (Loc,
8560                   Left_Opnd =>
8561                     Make_Indexed_Component (Loc,
8562                       Prefix      => New_Reference_To (X, Loc),
8563                       Expressions => New_List (New_Reference_To (I, Loc))),
8564
8565                   Right_Opnd =>
8566                     Make_Indexed_Component (Loc,
8567                       Prefix      => New_Reference_To (Y, Loc),
8568                       Expressions => New_List (
8569                         New_Reference_To (J, Loc)))))));
8570
8571       --  for I in X'range loop
8572       --     if ... end if;
8573       --  end loop;
8574
8575       Loop_Statement :=
8576         Make_Implicit_Loop_Statement (Nod,
8577           Identifier => Empty,
8578
8579           Iteration_Scheme =>
8580             Make_Iteration_Scheme (Loc,
8581               Loop_Parameter_Specification =>
8582                 Make_Loop_Parameter_Specification (Loc,
8583                   Defining_Identifier => I,
8584                   Discrete_Subtype_Definition =>
8585                     Make_Attribute_Reference (Loc,
8586                       Prefix => New_Reference_To (X, Loc),
8587                       Attribute_Name => Name_Range))),
8588
8589           Statements => New_List (Loop_Body));
8590
8591       --    if X'length = 0 then
8592       --       return false;
8593       --    elsif Y'length = 0 then
8594       --       return true;
8595       --    else
8596       --      for ... loop ... end loop;
8597       --      return X'length > Y'length;
8598       --    end if;
8599
8600       Length1 :=
8601         Make_Attribute_Reference (Loc,
8602           Prefix => New_Reference_To (X, Loc),
8603           Attribute_Name => Name_Length);
8604
8605       Length2 :=
8606         Make_Attribute_Reference (Loc,
8607           Prefix => New_Reference_To (Y, Loc),
8608           Attribute_Name => Name_Length);
8609
8610       Final_Expr :=
8611         Make_Op_Gt (Loc,
8612           Left_Opnd  => Length1,
8613           Right_Opnd => Length2);
8614
8615       If_Stat :=
8616         Make_Implicit_If_Statement (Nod,
8617           Condition =>
8618             Make_Op_Eq (Loc,
8619               Left_Opnd =>
8620                 Make_Attribute_Reference (Loc,
8621                   Prefix => New_Reference_To (X, Loc),
8622                   Attribute_Name => Name_Length),
8623               Right_Opnd =>
8624                 Make_Integer_Literal (Loc, 0)),
8625
8626           Then_Statements =>
8627             New_List (
8628               Make_Simple_Return_Statement (Loc,
8629                 Expression => New_Reference_To (Standard_False, Loc))),
8630
8631           Elsif_Parts => New_List (
8632             Make_Elsif_Part (Loc,
8633               Condition =>
8634                 Make_Op_Eq (Loc,
8635                   Left_Opnd =>
8636                     Make_Attribute_Reference (Loc,
8637                       Prefix => New_Reference_To (Y, Loc),
8638                       Attribute_Name => Name_Length),
8639                   Right_Opnd =>
8640                     Make_Integer_Literal (Loc, 0)),
8641
8642               Then_Statements =>
8643                 New_List (
8644                   Make_Simple_Return_Statement (Loc,
8645                      Expression => New_Reference_To (Standard_True, Loc))))),
8646
8647           Else_Statements => New_List (
8648             Loop_Statement,
8649             Make_Simple_Return_Statement (Loc,
8650               Expression => Final_Expr)));
8651
8652       --  (X : a; Y: a)
8653
8654       Formals := New_List (
8655         Make_Parameter_Specification (Loc,
8656           Defining_Identifier => X,
8657           Parameter_Type      => New_Reference_To (Typ, Loc)),
8658
8659         Make_Parameter_Specification (Loc,
8660           Defining_Identifier => Y,
8661           Parameter_Type      => New_Reference_To (Typ, Loc)));
8662
8663       --  function Gnnn (...) return boolean is
8664       --    J : index := Y'first;
8665       --  begin
8666       --    if ... end if;
8667       --  end Gnnn;
8668
8669       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
8670
8671       Func_Body :=
8672         Make_Subprogram_Body (Loc,
8673           Specification =>
8674             Make_Function_Specification (Loc,
8675               Defining_Unit_Name       => Func_Name,
8676               Parameter_Specifications => Formals,
8677               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
8678
8679           Declarations => New_List (
8680             Make_Object_Declaration (Loc,
8681               Defining_Identifier => J,
8682               Object_Definition   => New_Reference_To (Index, Loc),
8683               Expression =>
8684                 Make_Attribute_Reference (Loc,
8685                   Prefix => New_Reference_To (Y, Loc),
8686                   Attribute_Name => Name_First))),
8687
8688           Handled_Statement_Sequence =>
8689             Make_Handled_Sequence_Of_Statements (Loc,
8690               Statements => New_List (If_Stat)));
8691
8692       return Func_Body;
8693    end Make_Array_Comparison_Op;
8694
8695    ---------------------------
8696    -- Make_Boolean_Array_Op --
8697    ---------------------------
8698
8699    --  For logical operations on boolean arrays, expand in line the
8700    --  following, replacing 'and' with 'or' or 'xor' where needed:
8701
8702    --    function Annn (A : typ; B: typ) return typ is
8703    --       C : typ;
8704    --    begin
8705    --       for J in A'range loop
8706    --          C (J) := A (J) op B (J);
8707    --       end loop;
8708    --       return C;
8709    --    end Annn;
8710
8711    --  Here typ is the boolean array type
8712
8713    function Make_Boolean_Array_Op
8714      (Typ : Entity_Id;
8715       N   : Node_Id) return Node_Id
8716    is
8717       Loc : constant Source_Ptr := Sloc (N);
8718
8719       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
8720       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
8721       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
8722       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
8723
8724       A_J : Node_Id;
8725       B_J : Node_Id;
8726       C_J : Node_Id;
8727       Op  : Node_Id;
8728
8729       Formals        : List_Id;
8730       Func_Name      : Entity_Id;
8731       Func_Body      : Node_Id;
8732       Loop_Statement : Node_Id;
8733
8734    begin
8735       A_J :=
8736         Make_Indexed_Component (Loc,
8737           Prefix      => New_Reference_To (A, Loc),
8738           Expressions => New_List (New_Reference_To (J, Loc)));
8739
8740       B_J :=
8741         Make_Indexed_Component (Loc,
8742           Prefix      => New_Reference_To (B, Loc),
8743           Expressions => New_List (New_Reference_To (J, Loc)));
8744
8745       C_J :=
8746         Make_Indexed_Component (Loc,
8747           Prefix      => New_Reference_To (C, Loc),
8748           Expressions => New_List (New_Reference_To (J, Loc)));
8749
8750       if Nkind (N) = N_Op_And then
8751          Op :=
8752            Make_Op_And (Loc,
8753              Left_Opnd  => A_J,
8754              Right_Opnd => B_J);
8755
8756       elsif Nkind (N) = N_Op_Or then
8757          Op :=
8758            Make_Op_Or (Loc,
8759              Left_Opnd  => A_J,
8760              Right_Opnd => B_J);
8761
8762       else
8763          Op :=
8764            Make_Op_Xor (Loc,
8765              Left_Opnd  => A_J,
8766              Right_Opnd => B_J);
8767       end if;
8768
8769       Loop_Statement :=
8770         Make_Implicit_Loop_Statement (N,
8771           Identifier => Empty,
8772
8773           Iteration_Scheme =>
8774             Make_Iteration_Scheme (Loc,
8775               Loop_Parameter_Specification =>
8776                 Make_Loop_Parameter_Specification (Loc,
8777                   Defining_Identifier => J,
8778                   Discrete_Subtype_Definition =>
8779                     Make_Attribute_Reference (Loc,
8780                       Prefix => New_Reference_To (A, Loc),
8781                       Attribute_Name => Name_Range))),
8782
8783           Statements => New_List (
8784             Make_Assignment_Statement (Loc,
8785               Name       => C_J,
8786               Expression => Op)));
8787
8788       Formals := New_List (
8789         Make_Parameter_Specification (Loc,
8790           Defining_Identifier => A,
8791           Parameter_Type      => New_Reference_To (Typ, Loc)),
8792
8793         Make_Parameter_Specification (Loc,
8794           Defining_Identifier => B,
8795           Parameter_Type      => New_Reference_To (Typ, Loc)));
8796
8797       Func_Name :=
8798         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
8799       Set_Is_Inlined (Func_Name);
8800
8801       Func_Body :=
8802         Make_Subprogram_Body (Loc,
8803           Specification =>
8804             Make_Function_Specification (Loc,
8805               Defining_Unit_Name       => Func_Name,
8806               Parameter_Specifications => Formals,
8807               Result_Definition        => New_Reference_To (Typ, Loc)),
8808
8809           Declarations => New_List (
8810             Make_Object_Declaration (Loc,
8811               Defining_Identifier => C,
8812               Object_Definition   => New_Reference_To (Typ, Loc))),
8813
8814           Handled_Statement_Sequence =>
8815             Make_Handled_Sequence_Of_Statements (Loc,
8816               Statements => New_List (
8817                 Loop_Statement,
8818                 Make_Simple_Return_Statement (Loc,
8819                   Expression => New_Reference_To (C, Loc)))));
8820
8821       return Func_Body;
8822    end Make_Boolean_Array_Op;
8823
8824    ------------------------
8825    -- Rewrite_Comparison --
8826    ------------------------
8827
8828    procedure Rewrite_Comparison (N : Node_Id) is
8829    begin
8830       if Nkind (N) = N_Type_Conversion then
8831          Rewrite_Comparison (Expression (N));
8832          return;
8833
8834       elsif Nkind (N) not in N_Op_Compare then
8835          return;
8836       end if;
8837
8838       declare
8839          Typ : constant Entity_Id := Etype (N);
8840          Op1 : constant Node_Id   := Left_Opnd (N);
8841          Op2 : constant Node_Id   := Right_Opnd (N);
8842
8843          Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
8844          --  Res indicates if compare outcome can be compile time determined
8845
8846          True_Result  : Boolean;
8847          False_Result : Boolean;
8848
8849       begin
8850          case N_Op_Compare (Nkind (N)) is
8851             when N_Op_Eq =>
8852                True_Result  := Res = EQ;
8853                False_Result := Res = LT or else Res = GT or else Res = NE;
8854
8855             when N_Op_Ge =>
8856                True_Result  := Res in Compare_GE;
8857                False_Result := Res = LT;
8858
8859                if Res = LE
8860                  and then Constant_Condition_Warnings
8861                  and then Comes_From_Source (Original_Node (N))
8862                  and then Nkind (Original_Node (N)) = N_Op_Ge
8863                  and then not In_Instance
8864                  and then not Warnings_Off (Etype (Left_Opnd (N)))
8865                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
8866                then
8867                   Error_Msg_N
8868                     ("can never be greater than, could replace by ""'=""?", N);
8869                end if;
8870
8871             when N_Op_Gt =>
8872                True_Result  := Res = GT;
8873                False_Result := Res in Compare_LE;
8874
8875             when N_Op_Lt =>
8876                True_Result  := Res = LT;
8877                False_Result := Res in Compare_GE;
8878
8879             when N_Op_Le =>
8880                True_Result  := Res in Compare_LE;
8881                False_Result := Res = GT;
8882
8883                if Res = GE
8884                  and then Constant_Condition_Warnings
8885                  and then Comes_From_Source (Original_Node (N))
8886                  and then Nkind (Original_Node (N)) = N_Op_Le
8887                  and then not In_Instance
8888                  and then not Warnings_Off (Etype (Left_Opnd (N)))
8889                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
8890                then
8891                   Error_Msg_N
8892                     ("can never be less than, could replace by ""'=""?", N);
8893                end if;
8894
8895             when N_Op_Ne =>
8896                True_Result  := Res = NE or else Res = GT or else Res = LT;
8897                False_Result := Res = EQ;
8898          end case;
8899
8900          if True_Result then
8901             Rewrite (N,
8902               Convert_To (Typ,
8903                 New_Occurrence_Of (Standard_True, Sloc (N))));
8904             Analyze_And_Resolve (N, Typ);
8905             Warn_On_Known_Condition (N);
8906
8907          elsif False_Result then
8908             Rewrite (N,
8909               Convert_To (Typ,
8910                 New_Occurrence_Of (Standard_False, Sloc (N))));
8911             Analyze_And_Resolve (N, Typ);
8912             Warn_On_Known_Condition (N);
8913          end if;
8914       end;
8915    end Rewrite_Comparison;
8916
8917    ----------------------------
8918    -- Safe_In_Place_Array_Op --
8919    ----------------------------
8920
8921    function Safe_In_Place_Array_Op
8922      (Lhs : Node_Id;
8923       Op1 : Node_Id;
8924       Op2 : Node_Id) return Boolean
8925    is
8926       Target : Entity_Id;
8927
8928       function Is_Safe_Operand (Op : Node_Id) return Boolean;
8929       --  Operand is safe if it cannot overlap part of the target of the
8930       --  operation. If the operand and the target are identical, the operand
8931       --  is safe. The operand can be empty in the case of negation.
8932
8933       function Is_Unaliased (N : Node_Id) return Boolean;
8934       --  Check that N is a stand-alone entity
8935
8936       ------------------
8937       -- Is_Unaliased --
8938       ------------------
8939
8940       function Is_Unaliased (N : Node_Id) return Boolean is
8941       begin
8942          return
8943            Is_Entity_Name (N)
8944              and then No (Address_Clause (Entity (N)))
8945              and then No (Renamed_Object (Entity (N)));
8946       end Is_Unaliased;
8947
8948       ---------------------
8949       -- Is_Safe_Operand --
8950       ---------------------
8951
8952       function Is_Safe_Operand (Op : Node_Id) return Boolean is
8953       begin
8954          if No (Op) then
8955             return True;
8956
8957          elsif Is_Entity_Name (Op) then
8958             return Is_Unaliased (Op);
8959
8960          elsif Nkind (Op) = N_Indexed_Component
8961            or else Nkind (Op) = N_Selected_Component
8962          then
8963             return Is_Unaliased (Prefix (Op));
8964
8965          elsif Nkind (Op) = N_Slice then
8966             return
8967               Is_Unaliased (Prefix (Op))
8968                 and then Entity (Prefix (Op)) /= Target;
8969
8970          elsif Nkind (Op) = N_Op_Not then
8971             return Is_Safe_Operand (Right_Opnd (Op));
8972
8973          else
8974             return False;
8975          end if;
8976       end Is_Safe_Operand;
8977
8978       --  Start of processing for Is_Safe_In_Place_Array_Op
8979
8980    begin
8981       --  We skip this processing if the component size is not the
8982       --  same as a system storage unit (since at least for NOT
8983       --  this would cause problems).
8984
8985       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
8986          return False;
8987
8988       --  Cannot do in place stuff on VM_Target since cannot pass addresses
8989
8990       elsif VM_Target /= No_VM then
8991          return False;
8992
8993       --  Cannot do in place stuff if non-standard Boolean representation
8994
8995       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
8996          return False;
8997
8998       elsif not Is_Unaliased (Lhs) then
8999          return False;
9000       else
9001          Target := Entity (Lhs);
9002
9003          return
9004            Is_Safe_Operand (Op1)
9005              and then Is_Safe_Operand (Op2);
9006       end if;
9007    end Safe_In_Place_Array_Op;
9008
9009    -----------------------
9010    -- Tagged_Membership --
9011    -----------------------
9012
9013    --  There are two different cases to consider depending on whether
9014    --  the right operand is a class-wide type or not. If not we just
9015    --  compare the actual tag of the left expr to the target type tag:
9016    --
9017    --     Left_Expr.Tag = Right_Type'Tag;
9018    --
9019    --  If it is a class-wide type we use the RT function CW_Membership which
9020    --  is usually implemented by looking in the ancestor tables contained in
9021    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9022
9023    --  Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
9024    --  function IW_Membership which is usually implemented by looking in the
9025    --  table of abstract interface types plus the ancestor table contained in
9026    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
9027
9028    function Tagged_Membership (N : Node_Id) return Node_Id is
9029       Left  : constant Node_Id    := Left_Opnd  (N);
9030       Right : constant Node_Id    := Right_Opnd (N);
9031       Loc   : constant Source_Ptr := Sloc (N);
9032
9033       Left_Type  : Entity_Id;
9034       Right_Type : Entity_Id;
9035       Obj_Tag    : Node_Id;
9036
9037    begin
9038       Left_Type  := Etype (Left);
9039       Right_Type := Etype (Right);
9040
9041       if Is_Class_Wide_Type (Left_Type) then
9042          Left_Type := Root_Type (Left_Type);
9043       end if;
9044
9045       Obj_Tag :=
9046         Make_Selected_Component (Loc,
9047           Prefix        => Relocate_Node (Left),
9048           Selector_Name =>
9049             New_Reference_To (First_Tag_Component (Left_Type), Loc));
9050
9051       if Is_Class_Wide_Type (Right_Type) then
9052
9053          --  No need to issue a run-time check if we statically know that the
9054          --  result of this membership test is always true. For example,
9055          --  considering the following declarations:
9056
9057          --    type Iface is interface;
9058          --    type T     is tagged null record;
9059          --    type DT    is new T and Iface with null record;
9060
9061          --    Obj1 : T;
9062          --    Obj2 : DT;
9063
9064          --  These membership tests are always true:
9065
9066          --    Obj1 in T'Class
9067          --    Obj2 in T'Class;
9068          --    Obj2 in Iface'Class;
9069
9070          --  We do not need to handle cases where the membership is illegal.
9071          --  For example:
9072
9073          --    Obj1 in DT'Class;     --  Compile time error
9074          --    Obj1 in Iface'Class;  --  Compile time error
9075
9076          if not Is_Class_Wide_Type (Left_Type)
9077            and then (Is_Parent (Etype (Right_Type), Left_Type)
9078                        or else (Is_Interface (Etype (Right_Type))
9079                                  and then Interface_Present_In_Ancestor
9080                                            (Typ   => Left_Type,
9081                                             Iface => Etype (Right_Type))))
9082          then
9083             return New_Reference_To (Standard_True, Loc);
9084          end if;
9085
9086          --  Ada 2005 (AI-251): Class-wide applied to interfaces
9087
9088          if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
9089
9090             --   Support to: "Iface_CW_Typ in Typ'Class"
9091
9092            or else Is_Interface (Left_Type)
9093          then
9094             --  Issue error if IW_Membership operation not available in a
9095             --  configurable run time setting.
9096
9097             if not RTE_Available (RE_IW_Membership) then
9098                Error_Msg_CRT ("abstract interface types", N);
9099                return Empty;
9100             end if;
9101
9102             return
9103               Make_Function_Call (Loc,
9104                  Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
9105                  Parameter_Associations => New_List (
9106                    Make_Attribute_Reference (Loc,
9107                      Prefix => Obj_Tag,
9108                      Attribute_Name => Name_Address),
9109                    New_Reference_To (
9110                      Node (First_Elmt
9111                             (Access_Disp_Table (Root_Type (Right_Type)))),
9112                      Loc)));
9113
9114          --  Ada 95: Normal case
9115
9116          else
9117             return
9118               Build_CW_Membership (Loc,
9119                 Obj_Tag_Node => Obj_Tag,
9120                 Typ_Tag_Node =>
9121                    New_Reference_To (
9122                      Node (First_Elmt
9123                             (Access_Disp_Table (Root_Type (Right_Type)))),
9124                      Loc));
9125          end if;
9126
9127       --  Right_Type is not a class-wide type
9128
9129       else
9130          --  No need to check the tag of the object if Right_Typ is abstract
9131
9132          if Is_Abstract_Type (Right_Type) then
9133             return New_Reference_To (Standard_False, Loc);
9134
9135          else
9136             return
9137               Make_Op_Eq (Loc,
9138                 Left_Opnd  => Obj_Tag,
9139                 Right_Opnd =>
9140                   New_Reference_To
9141                     (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
9142          end if;
9143       end if;
9144    end Tagged_Membership;
9145
9146    ------------------------------
9147    -- Unary_Op_Validity_Checks --
9148    ------------------------------
9149
9150    procedure Unary_Op_Validity_Checks (N : Node_Id) is
9151    begin
9152       if Validity_Checks_On and Validity_Check_Operands then
9153          Ensure_Valid (Right_Opnd (N));
9154       end if;
9155    end Unary_Op_Validity_Checks;
9156
9157 end Exp_Ch4;