gcc/ada/exp_ch4.adb

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