gcc/ada/exp_ch4.adb

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