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 --                                                                          --
  10 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Checks;   use Checks;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Aggr; use Exp_Aggr;
  34 with Exp_Ch3;  use Exp_Ch3;
  35 with Exp_Ch7;  use Exp_Ch7;
  36 with Exp_Ch9;  use Exp_Ch9;
  37 with Exp_Disp; use Exp_Disp;
  38 with Exp_Fixd; use Exp_Fixd;
  39 with Exp_Pakd; use Exp_Pakd;
  40 with Exp_Tss;  use Exp_Tss;
  41 with Exp_Util; use Exp_Util;
  42 with Exp_VFpt; use Exp_VFpt;
  43 with Hostparm; use Hostparm;
  44 with Inline;   use Inline;
  45 with Nlists;   use Nlists;
  46 with Nmake;    use Nmake;
  47 with Opt;      use Opt;
  48 with Restrict; use Restrict;
  49 with Rtsfind;  use Rtsfind;
  50 with Sem;      use Sem;
  51 with Sem_Cat;  use Sem_Cat;
  52 with Sem_Ch13; use Sem_Ch13;
  53 with Sem_Eval; use Sem_Eval;
  54 with Sem_Res;  use Sem_Res;
  55 with Sem_Type; use Sem_Type;
  56 with Sem_Util; use Sem_Util;
  57 with Sem_Warn; use Sem_Warn;
  58 with Sinfo;    use Sinfo;
  59 with Sinfo.CN; use Sinfo.CN;
  60 with Snames;   use Snames;
  61 with Stand;    use Stand;
  62 with Targparm; use Targparm;
  63 with Tbuild;   use Tbuild;
  64 with Ttypes;   use Ttypes;
  65 with Uintp;    use Uintp;
  66 with Urealp;   use Urealp;
  67 with Validsw;  use Validsw;
  68
  69 package body Exp_Ch4 is
  70
  71    ------------------------
  72    --  Local Subprograms --
  73    ------------------------
  74
  75    procedure Binary_Op_Validity_Checks (N : Node_Id);
  76    pragma Inline (Binary_Op_Validity_Checks);
  77    --  Performs validity checks for a binary operator
  78
  79    procedure Expand_Array_Comparison (N : Node_Id);
  80    --  This routine handles expansion of the comparison operators (N_Op_Lt,
  81    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
  82    --  code for these operators is similar, differing only in the details of
  83    --  the actual comparison call that is made.
  84
  85    function Expand_Array_Equality
  86      (Nod    : Node_Id;
  87       Typ    : Entity_Id;
  88       A_Typ  : Entity_Id;
  89       Lhs    : Node_Id;
  90       Rhs    : Node_Id;
  91       Bodies : List_Id)
  92       return   Node_Id;
  93    --  Expand an array equality into a call to a function implementing this
  94    --  equality, and a call to it. Loc is the location for the generated
  95    --  nodes. Typ is the type of the array, and Lhs, Rhs are the array
  96    --  expressions to be compared. A_Typ is the type of the arguments,
  97    --  which may be a private type, in which case Typ is its full view.
  98    --  Bodies is a list on which to attach bodies of local functions that
  99    --  are created in the process. This is the responsability of the
 100    --  caller to insert those bodies at the right place. Nod provides
 101    --  the Sloc value for the generated code.
 102
 103    procedure Expand_Boolean_Operator (N : Node_Id);
 104    --  Common expansion processing for Boolean operators (And, Or, Xor)
 105    --  for the case of array type arguments.
 106
 107    function Expand_Composite_Equality
 108      (Nod    : Node_Id;
 109       Typ    : Entity_Id;
 110       Lhs    : Node_Id;
 111       Rhs    : Node_Id;
 112       Bodies : List_Id)
 113       return   Node_Id;
 114    --  Local recursive function used to expand equality for nested
 115    --  composite types. Used by Expand_Record/Array_Equality, Bodies
 116    --  is a list on which to attach bodies of local functions that are
 117    --  created in the process. This is the responsability of the caller
 118    --  to insert those bodies at the right place. Nod provides the Sloc
 119    --  value for generated code.
 120
 121    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
 122    --  This routine handles expansion of concatenation operations, where
 123    --  N is the N_Op_Concat node being expanded and Operands is the list
 124    --  of operands (at least two are present). The caller has dealt with
 125    --  converting any singleton operands into singleton aggregates.
 126
 127    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
 128    --  Routine to expand concatenation of 2-5 operands (in the list Operands)
 129    --  and replace node Cnode with the result of the contatenation. If there
 130    --  are two operands, they can be string or character. If there are more
 131    --  than two operands, then are always of type string (i.e. the caller has
 132    --  already converted character operands to strings in this case).
 133
 134    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
 135    --  N is either an N_Op_Divide or N_Op_Multiply node whose result is
 136    --  universal fixed. We do not have such a type at runtime, so the
 137    --  purpose of this routine is to find the real type by looking up
 138    --  the tree. We also determine if the operation must be rounded.
 139
 140    procedure Insert_Dereference_Action (N : Node_Id);
 141    --  N is an expression whose type is an access. When the type is derived
 142    --  from Checked_Pool, expands a call to the primitive 'dereference'.
 143
 144    function Make_Array_Comparison_Op
 145      (Typ   : Entity_Id;
 146       Nod   : Node_Id)
 147       return  Node_Id;
 148    --  Comparisons between arrays are expanded in line. This function
 149    --  produces the body of the implementation of (a > b), where a and b
 150    --  are one-dimensional arrays of some discrete type. The original
 151    --  node is then expanded into the appropriate call to this function.
 152    --  Nod provides the Sloc value for the generated code.
 153
 154    function Make_Boolean_Array_Op
 155      (Typ  : Entity_Id;
 156       N    : Node_Id)
 157       return Node_Id;
 158    --  Boolean operations on boolean arrays are expanded in line. This
 159    --  function produce the body for the node N, which is (a and b),
 160    --  (a or b), or (a xor b). It is used only the normal case and not
 161    --  the packed case. The type involved, Typ, is the Boolean array type,
 162    --  and the logical operations in the body are simple boolean operations.
 163    --  Note that Typ is always a constrained type (the caller has ensured
 164    --  this by using Convert_To_Actual_Subtype if necessary).
 165
 166    procedure Rewrite_Comparison (N : Node_Id);
 167    --  N is the node for a compile time comparison. If this outcome of this
 168    --  comparison can be determined at compile time, then the node N can be
 169    --  rewritten with True or False. If the outcome cannot be determined at
 170    --  compile time, the call has no effect.
 171
 172    function Tagged_Membership (N : Node_Id) return Node_Id;
 173    --  Construct the expression corresponding to the tagged membership test.
 174    --  Deals with a second operand being (or not) a class-wide type.
 175
 176    procedure Unary_Op_Validity_Checks (N : Node_Id);
 177    pragma Inline (Unary_Op_Validity_Checks);
 178    --  Performs validity checks for a unary operator
 179
 180    -------------------------------
 181    -- Binary_Op_Validity_Checks --
 182    -------------------------------
 183
 184    procedure Binary_Op_Validity_Checks (N : Node_Id) is
 185    begin
 186       if Validity_Checks_On and Validity_Check_Operands then
 187          Ensure_Valid (Left_Opnd (N));
 188          Ensure_Valid (Right_Opnd (N));
 189       end if;
 190    end Binary_Op_Validity_Checks;
 191
 192    -----------------------------
 193    -- Expand_Array_Comparison --
 194    -----------------------------
 195
 196    --  Expansion is only required in the case of array types. The form of
 197    --  the expansion is:
 198
 199    --     [body for greater_nn; boolean_expression]
 200
 201    --  The body is built by Make_Array_Comparison_Op, and the form of the
 202    --  Boolean expression depends on the operator involved.
 203
 204    procedure Expand_Array_Comparison (N : Node_Id) is
 205       Loc  : constant Source_Ptr := Sloc (N);
 206       Op1  : Node_Id             := Left_Opnd (N);
 207       Op2  : Node_Id             := Right_Opnd (N);
 208       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
 209
 210       Expr      : Node_Id;
 211       Func_Body : Node_Id;
 212       Func_Name : Entity_Id;
 213
 214    begin
 215       --  For (a <= b) we convert to not (a > b)
 216
 217       if Chars (N) = Name_Op_Le then
 218          Rewrite (N,
 219            Make_Op_Not (Loc,
 220              Right_Opnd =>
 221                 Make_Op_Gt (Loc,
 222                  Left_Opnd  => Op1,
 223                  Right_Opnd => Op2)));
 224          Analyze_And_Resolve (N, Standard_Boolean);
 225          return;
 226
 227       --  For < the Boolean expression is
 228       --    greater__nn (op2, op1)
 229
 230       elsif Chars (N) = Name_Op_Lt then
 231          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 232
 233          --  Switch operands
 234
 235          Op1 := Right_Opnd (N);
 236          Op2 := Left_Opnd  (N);
 237
 238       --  For (a >= b) we convert to not (a < b)
 239
 240       elsif Chars (N) = Name_Op_Ge then
 241          Rewrite (N,
 242            Make_Op_Not (Loc,
 243              Right_Opnd =>
 244                Make_Op_Lt (Loc,
 245                  Left_Opnd  => Op1,
 246                  Right_Opnd => Op2)));
 247          Analyze_And_Resolve (N, Standard_Boolean);
 248          return;
 249
 250       --  For > the Boolean expression is
 251       --    greater__nn (op1, op2)
 252
 253       else
 254          pragma Assert (Chars (N) = Name_Op_Gt);
 255          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 256       end if;
 257
 258       Func_Name := Defining_Unit_Name (Specification (Func_Body));
 259       Expr :=
 260         Make_Function_Call (Loc,
 261           Name => New_Reference_To (Func_Name, Loc),
 262           Parameter_Associations => New_List (Op1, Op2));
 263
 264       Insert_Action (N, Func_Body);
 265       Rewrite (N, Expr);
 266       Analyze_And_Resolve (N, Standard_Boolean);
 267
 268    end Expand_Array_Comparison;
 269
 270    ---------------------------
 271    -- Expand_Array_Equality --
 272    ---------------------------
 273
 274    --  Expand an equality function for multi-dimensional arrays. Here is
 275    --  an example of such a function for Nb_Dimension = 2
 276
 277    --  function Enn (A : arr; B : arr) return boolean is
 278    --     J1 : integer;
 279    --     J2 : integer;
 280    --
 281    --  begin
 282    --     if A'length (1) /= B'length (1) then
 283    --        return false;
 284    --     else
 285    --        J1 := B'first (1);
 286    --        for I1 in A'first (1) .. A'last (1) loop
 287    --           if A'length (2) /= B'length (2) then
 288    --              return false;
 289    --           else
 290    --              J2 := B'first (2);
 291    --              for I2 in A'first (2) .. A'last (2) loop
 292    --                 if A (I1, I2) /=  B (J1, J2) then
 293    --                    return false;
 294    --                 end if;
 295    --                 J2 := Integer'succ (J2);
 296    --              end loop;
 297    --           end if;
 298    --           J1 := Integer'succ (J1);
 299    --        end loop;
 300    --     end if;
 301    --     return true;
 302    --  end Enn;
 303
 304    function Expand_Array_Equality
 305      (Nod    : Node_Id;
 306       Typ    : Entity_Id;
 307       A_Typ  : Entity_Id;
 308       Lhs    : Node_Id;
 309       Rhs    : Node_Id;
 310       Bodies : List_Id)
 311       return   Node_Id
 312    is
 313       Loc         : constant Source_Ptr := Sloc (Nod);
 314       Actuals     : List_Id;
 315       Decls       : List_Id := New_List;
 316       Index_List1 : List_Id := New_List;
 317       Index_List2 : List_Id := New_List;
 318       Formals     : List_Id;
 319       Stats       : Node_Id;
 320       Func_Name   : Entity_Id;
 321       Func_Body   : Node_Id;
 322
 323       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
 324       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
 325
 326       function Component_Equality (Typ : Entity_Id) return Node_Id;
 327       --  Create one statement to compare corresponding components, designated
 328       --  by a full set of indices.
 329
 330       function Loop_One_Dimension
 331         (N     : Int;
 332          Index : Node_Id)
 333          return Node_Id;
 334       --  Loop over the n'th dimension of the arrays. The single statement
 335       --  in the body of the loop is a loop over the next dimension, or
 336       --  the comparison of corresponding components.
 337
 338       ------------------------
 339       -- Component_Equality --
 340       ------------------------
 341
 342       function Component_Equality (Typ : Entity_Id) return Node_Id is
 343          Test : Node_Id;
 344          L, R : Node_Id;
 345
 346       begin
 347          --  if a(i1...) /= b(j1...) then return false; end if;
 348
 349          L :=
 350            Make_Indexed_Component (Loc,
 351              Prefix => Make_Identifier (Loc, Chars (A)),
 352              Expressions => Index_List1);
 353
 354          R :=
 355            Make_Indexed_Component (Loc,
 356              Prefix => Make_Identifier (Loc, Chars (B)),
 357              Expressions => Index_List2);
 358
 359          Test := Expand_Composite_Equality
 360                    (Nod, Component_Type (Typ), L, R, Decls);
 361
 362          return
 363            Make_Implicit_If_Statement (Nod,
 364              Condition => Make_Op_Not (Loc, Right_Opnd => Test),
 365              Then_Statements => New_List (
 366                Make_Return_Statement (Loc,
 367                  Expression => New_Occurrence_Of (Standard_False, Loc))));
 368
 369       end Component_Equality;
 370
 371       ------------------------
 372       -- Loop_One_Dimension --
 373       ------------------------
 374
 375       function Loop_One_Dimension
 376         (N     : Int;
 377          Index : Node_Id)
 378          return Node_Id
 379       is
 380          I : constant Entity_Id := Make_Defining_Identifier (Loc,
 381                                                   New_Internal_Name ('I'));
 382          J : constant Entity_Id := Make_Defining_Identifier (Loc,
 383                                                   New_Internal_Name ('J'));
 384          Index_Type  : Entity_Id;
 385          Stats : Node_Id;
 386
 387       begin
 388          if N > Number_Dimensions (Typ) then
 389             return Component_Equality (Typ);
 390
 391          else
 392             --  Generate the following:
 393
 394             --  j: index_type;
 395             --  ...
 396
 397             --  if a'length (n) /= b'length (n) then
 398             --    return false;
 399             --  else
 400             --     j := b'first (n);
 401             --     for i in a'range (n) loop
 402             --        --  loop over remaining dimensions.
 403             --        j := index_type'succ (j);
 404             --     end loop;
 405             --  end if;
 406
 407             --  retrieve index type for current dimension.
 408
 409             Index_Type := Base_Type (Etype (Index));
 410             Append (New_Reference_To (I, Loc), Index_List1);
 411             Append (New_Reference_To (J, Loc), Index_List2);
 412
 413             --  Declare index for j as a local variable to the function.
 414             --  Index i is a loop variable.
 415
 416             Append_To (Decls,
 417               Make_Object_Declaration (Loc,
 418                 Defining_Identifier => J,
 419                 Object_Definition   => New_Reference_To (Index_Type, Loc)));
 420
 421             Stats :=
 422               Make_Implicit_If_Statement (Nod,
 423                 Condition =>
 424                   Make_Op_Ne (Loc,
 425                     Left_Opnd =>
 426                       Make_Attribute_Reference (Loc,
 427                         Prefix => New_Reference_To (A, Loc),
 428                         Attribute_Name => Name_Length,
 429                         Expressions => New_List (
 430                           Make_Integer_Literal (Loc, N))),
 431                     Right_Opnd =>
 432                       Make_Attribute_Reference (Loc,
 433                         Prefix => New_Reference_To (B, Loc),
 434                         Attribute_Name => Name_Length,
 435                         Expressions => New_List (
 436                           Make_Integer_Literal (Loc, N)))),
 437
 438                 Then_Statements => New_List (
 439                   Make_Return_Statement (Loc,
 440                     Expression => New_Occurrence_Of (Standard_False, Loc))),
 441
 442                 Else_Statements => New_List (
 443
 444                   Make_Assignment_Statement (Loc,
 445                     Name       => New_Reference_To (J, Loc),
 446                     Expression =>
 447                       Make_Attribute_Reference (Loc,
 448                         Prefix => New_Reference_To (B, Loc),
 449                         Attribute_Name => Name_First,
 450                         Expressions => New_List (
 451                           Make_Integer_Literal (Loc, N)))),
 452
 453                   Make_Implicit_Loop_Statement (Nod,
 454                     Identifier => Empty,
 455                     Iteration_Scheme =>
 456                       Make_Iteration_Scheme (Loc,
 457                         Loop_Parameter_Specification =>
 458                           Make_Loop_Parameter_Specification (Loc,
 459                             Defining_Identifier => I,
 460                             Discrete_Subtype_Definition =>
 461                               Make_Attribute_Reference (Loc,
 462                                 Prefix => New_Reference_To (A, Loc),
 463                                 Attribute_Name => Name_Range,
 464                                 Expressions => New_List (
 465                                   Make_Integer_Literal (Loc, N))))),
 466
 467                     Statements => New_List (
 468                       Loop_One_Dimension (N + 1, Next_Index (Index)),
 469                       Make_Assignment_Statement (Loc,
 470                         Name => New_Reference_To (J, Loc),
 471                         Expression =>
 472                           Make_Attribute_Reference (Loc,
 473                             Prefix => New_Reference_To (Index_Type, Loc),
 474                             Attribute_Name => Name_Succ,
 475                             Expressions => New_List (
 476                               New_Reference_To (J, Loc))))))));
 477
 478             return Stats;
 479          end if;
 480       end Loop_One_Dimension;
 481
 482    --  Start of processing for Expand_Array_Equality
 483
 484    begin
 485       Formals := New_List (
 486         Make_Parameter_Specification (Loc,
 487           Defining_Identifier => A,
 488           Parameter_Type      => New_Reference_To (Typ, Loc)),
 489
 490         Make_Parameter_Specification (Loc,
 491           Defining_Identifier => B,
 492           Parameter_Type      => New_Reference_To (Typ, Loc)));
 493
 494       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
 495
 496       Stats := Loop_One_Dimension (1, First_Index (Typ));
 497
 498       Func_Body :=
 499         Make_Subprogram_Body (Loc,
 500           Specification =>
 501             Make_Function_Specification (Loc,
 502               Defining_Unit_Name       => Func_Name,
 503               Parameter_Specifications => Formals,
 504               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
 505           Declarations               =>  Decls,
 506           Handled_Statement_Sequence =>
 507             Make_Handled_Sequence_Of_Statements (Loc,
 508               Statements => New_List (
 509                 Stats,
 510                 Make_Return_Statement (Loc,
 511                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
 512
 513          Set_Has_Completion (Func_Name, True);
 514
 515          --  If the array type is distinct from the type of the arguments,
 516          --  it is the full view of a private type. Apply an unchecked
 517          --  conversion to insure that analysis of the call succeeds.
 518
 519          if Base_Type (A_Typ) /= Base_Type (Typ) then
 520             Actuals := New_List (
 521               OK_Convert_To (Typ, Lhs),
 522               OK_Convert_To (Typ, Rhs));
 523          else
 524             Actuals := New_List (Lhs, Rhs);
 525          end if;
 526
 527          Append_To (Bodies, Func_Body);
 528
 529          return
 530            Make_Function_Call (Loc,
 531              Name => New_Reference_To (Func_Name, Loc),
 532              Parameter_Associations => Actuals);
 533    end Expand_Array_Equality;
 534
 535    -----------------------------
 536    -- Expand_Boolean_Operator --
 537    -----------------------------
 538
 539    --  Note that we first get the actual subtypes of the operands,
 540    --  since we always want to deal with types that have bounds.
 541
 542    procedure Expand_Boolean_Operator (N : Node_Id) is
 543       Typ       : constant Entity_Id  := Etype (N);
 544
 545    begin
 546       if Is_Bit_Packed_Array (Typ) then
 547          Expand_Packed_Boolean_Operator (N);
 548
 549       else
 550
 551          --  For the normal non-packed case, the expansion is
 552          --  to build a function for carrying out the comparison
 553          --  (using Make_Boolean_Array_Op) and then inserting it
 554          --  into the tree. The original operator node is then
 555          --  rewritten as a call to this function.
 556
 557          declare
 558             Loc       : constant Source_Ptr := Sloc (N);
 559             L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
 560             R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
 561             Func_Body : Node_Id;
 562             Func_Name : Entity_Id;
 563          begin
 564             Convert_To_Actual_Subtype (L);
 565             Convert_To_Actual_Subtype (R);
 566             Ensure_Defined (Etype (L), N);
 567             Ensure_Defined (Etype (R), N);
 568             Apply_Length_Check (R, Etype (L));
 569
 570             Func_Body := Make_Boolean_Array_Op (Etype (L), N);
 571             Func_Name := Defining_Unit_Name (Specification (Func_Body));
 572             Insert_Action (N, Func_Body);
 573
 574             --  Now rewrite the expression with a call
 575
 576             Rewrite (N,
 577               Make_Function_Call (Loc,
 578                 Name => New_Reference_To (Func_Name, Loc),
 579                 Parameter_Associations =>
 580                   New_List
 581                     (L, Make_Type_Conversion
 582                           (Loc, New_Reference_To (Etype (L), Loc), R))));
 583
 584             Analyze_And_Resolve (N, Typ);
 585          end;
 586       end if;
 587    end Expand_Boolean_Operator;
 588
 589    -------------------------------
 590    -- Expand_Composite_Equality --
 591    -------------------------------
 592
 593    --  This function is only called for comparing internal fields of composite
 594    --  types when these fields are themselves composites. This is a special
 595    --  case because it is not possible to respect normal Ada visibility rules.
 596
 597    function Expand_Composite_Equality
 598      (Nod    : Node_Id;
 599       Typ    : Entity_Id;
 600       Lhs    : Node_Id;
 601       Rhs    : Node_Id;
 602       Bodies : List_Id)
 603       return   Node_Id
 604    is
 605       Loc       : constant Source_Ptr := Sloc (Nod);
 606       Full_Type : Entity_Id;
 607       Prim      : Elmt_Id;
 608       Eq_Op     : Entity_Id;
 609
 610    begin
 611       if Is_Private_Type (Typ) then
 612          Full_Type := Underlying_Type (Typ);
 613       else
 614          Full_Type := Typ;
 615       end if;
 616
 617       --  Defense against malformed private types with no completion
 618       --  the error will be diagnosed later by check_completion
 619
 620       if No (Full_Type) then
 621          return New_Reference_To (Standard_False, Loc);
 622       end if;
 623
 624       Full_Type := Base_Type (Full_Type);
 625
 626       if Is_Array_Type (Full_Type) then
 627
 628          --  If the operand is an elementary type other than a floating-point
 629          --  type, then we can simply use the built-in block bitwise equality,
 630          --  since the predefined equality operators always apply and bitwise
 631          --  equality is fine for all these cases.
 632
 633          if Is_Elementary_Type (Component_Type (Full_Type))
 634            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
 635          then
 636             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
 637
 638          --  For composite component types, and floating-point types, use
 639          --  the expansion. This deals with tagged component types (where
 640          --  we use the applicable equality routine) and floating-point,
 641          --  (where we need to worry about negative zeroes), and also the
 642          --  case of any composite type recursively containing such fields.
 643
 644          else
 645             return Expand_Array_Equality
 646                      (Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
 647          end if;
 648
 649       elsif Is_Tagged_Type (Full_Type) then
 650
 651          --  Call the primitive operation "=" of this type
 652
 653          if Is_Class_Wide_Type (Full_Type) then
 654             Full_Type := Root_Type (Full_Type);
 655          end if;
 656
 657          --  If this is derived from an untagged private type completed
 658          --  with a tagged type, it does not have a full view, so we
 659          --  use the primitive operations of the private type.
 660          --  This check should no longer be necessary when these
 661          --  types receive their full views ???
 662
 663          if Is_Private_Type (Typ)
 664            and then not Is_Tagged_Type (Typ)
 665            and then not Is_Controlled (Typ)
 666            and then Is_Derived_Type (Typ)
 667            and then No (Full_View (Typ))
 668          then
 669             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
 670          else
 671             Prim := First_Elmt (Primitive_Operations (Full_Type));
 672          end if;
 673
 674          loop
 675             Eq_Op := Node (Prim);
 676             exit when Chars (Eq_Op) = Name_Op_Eq
 677               and then Etype (First_Formal (Eq_Op)) =
 678                        Etype (Next_Formal (First_Formal (Eq_Op)));
 679             Next_Elmt (Prim);
 680             pragma Assert (Present (Prim));
 681          end loop;
 682
 683          Eq_Op := Node (Prim);
 684
 685          return
 686            Make_Function_Call (Loc,
 687              Name => New_Reference_To (Eq_Op, Loc),
 688              Parameter_Associations =>
 689                New_List
 690                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
 691                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
 692
 693       elsif Is_Record_Type (Full_Type) then
 694          Eq_Op := TSS (Full_Type, Name_uEquality);
 695
 696          if Present (Eq_Op) then
 697             if Etype (First_Formal (Eq_Op)) /= Full_Type then
 698
 699                --  Inherited equality from parent type. Convert the actuals
 700                --  to match signature of operation.
 701
 702                declare
 703                   T : Entity_Id := Etype (First_Formal (Eq_Op));
 704
 705                begin
 706                   return
 707                     Make_Function_Call (Loc,
 708                       Name => New_Reference_To (Eq_Op, Loc),
 709                       Parameter_Associations =>
 710                         New_List (OK_Convert_To (T, Lhs),
 711                                   OK_Convert_To (T, Rhs)));
 712                end;
 713
 714             else
 715                return
 716                  Make_Function_Call (Loc,
 717                    Name => New_Reference_To (Eq_Op, Loc),
 718                    Parameter_Associations => New_List (Lhs, Rhs));
 719             end if;
 720
 721          else
 722             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
 723          end if;
 724
 725       else
 726          --  It can be a simple record or the full view of a scalar private
 727
 728          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
 729       end if;
 730    end Expand_Composite_Equality;
 731
 732    ------------------------------
 733    -- Expand_Concatenate_Other --
 734    ------------------------------
 735
 736    --  Let n be the number of array operands to be concatenated, Base_Typ
 737    --  their base type, Ind_Typ their index type, and Arr_Typ the original
 738    --  array type to which the concatenantion operator applies, then the
 739    --  following subprogram is constructed:
 740    --
 741    --  [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
 742    --      L : Ind_Typ;
 743    --   begin
 744    --      if S1'Length /= 0 then
 745    --         L := XXX;   -->  XXX = S1'First       if Arr_Typ is unconstrained
 746    --                          XXX = Arr_Typ'First  otherwise
 747    --      elsif S2'Length /= 0 then
 748    --         L := YYY;   -->  YYY = S2'First       if Arr_Typ is unconstrained
 749    --                          YYY = Arr_Typ'First  otherwise
 750    --      ...
 751    --      elsif Sn-1'Length /= 0 then
 752    --         L := ZZZ;   -->  ZZZ = Sn-1'First     if Arr_Typ is unconstrained
 753    --                          ZZZ = Arr_Typ'First  otherwise
 754    --      else
 755    --         return Sn;
 756    --      end if;
 757    --
 758    --      declare
 759    --         P : Ind_Typ;
 760    --         H : Ind_Typ :=
 761    --          Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
 762    --                       + Ind_Typ'Pos (L));
 763    --         R : Base_Typ (L .. H);
 764    --      begin
 765    --         if S1'Length /= 0 then
 766    --            P := S1'First;
 767    --            loop
 768    --               R (L) := S1 (P);
 769    --               L := Ind_Typ'Succ (L);
 770    --               exit when P = S1'Last;
 771    --               P := Ind_Typ'Succ (P);
 772    --            end loop;
 773    --         end if;
 774    --
 775    --         if S2'Length /= 0 then
 776    --            L := Ind_Typ'Succ (L);
 777    --            loop
 778    --               R (L) := S2 (P);
 779    --               L := Ind_Typ'Succ (L);
 780    --               exit when P = S2'Last;
 781    --               P := Ind_Typ'Succ (P);
 782    --            end loop;
 783    --         end if;
 784    --
 785    --         ...
 786    --
 787    --         if Sn'Length /= 0 then
 788    --            P := Sn'First;
 789    --            loop
 790    --               R (L) := Sn (P);
 791    --               L := Ind_Typ'Succ (L);
 792    --               exit when P = Sn'Last;
 793    --               P := Ind_Typ'Succ (P);
 794    --            end loop;
 795    --         end if;
 796    --
 797    --         return R;
 798    --      end;
 799    --   end Cnn;]
 800
 801    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
 802       Loc      : constant Source_Ptr := Sloc (Cnode);
 803       Nb_Opnds : constant Nat        := List_Length (Opnds);
 804
 805       Arr_Typ  : constant Entity_Id := Etype (Entity (Cnode));
 806       Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
 807       Ind_Typ  : constant Entity_Id := Etype (First_Index (Base_Typ));
 808
 809       Func_Id     : Node_Id;
 810       Func_Spec   : Node_Id;
 811       Param_Specs : List_Id;
 812
 813       Func_Body  : Node_Id;
 814       Func_Decls : List_Id;
 815       Func_Stmts : List_Id;
 816
 817       L_Decl     : Node_Id;
 818
 819       If_Stmt    : Node_Id;
 820       Elsif_List : List_Id;
 821
 822       Declare_Block : Node_Id;
 823       Declare_Decls : List_Id;
 824       Declare_Stmts : List_Id;
 825
 826       H_Decl   : Node_Id;
 827       H_Init   : Node_Id;
 828       P_Decl   : Node_Id;
 829       R_Decl   : Node_Id;
 830       R_Constr : Node_Id;
 831       R_Range  : Node_Id;
 832
 833       Params  : List_Id;
 834       Operand : Node_Id;
 835
 836       function Copy_Into_R_S (I : Nat) return List_Id;
 837       --  Builds the sequence of statement:
 838       --    P := Si'First;
 839       --    loop
 840       --       R (L) := Si (P);
 841       --       L := Ind_Typ'Succ (L);
 842       --       exit when P = Si'Last;
 843       --       P := Ind_Typ'Succ (P);
 844       --    end loop;
 845       --
 846       --  where i is the input parameter I given.
 847
 848       function Init_L (I : Nat) return Node_Id;
 849       --  Builds the statement:
 850       --    L := Arr_Typ'First;  If Arr_Typ is constrained
 851       --    L := Si'First;       otherwise (where I is the input param given)
 852
 853       function H return Node_Id;
 854       --  Builds reference to identifier H.
 855
 856       function Ind_Val (E : Node_Id) return Node_Id;
 857       --  Builds expression Ind_Typ'Val (E);
 858
 859       function L return Node_Id;
 860       --  Builds reference to identifier L.
 861
 862       function L_Pos return Node_Id;
 863       --  Builds expression Ind_Typ'Pos (L).
 864
 865       function L_Succ return Node_Id;
 866       --  Builds expression Ind_Typ'Succ (L).
 867
 868       function One return Node_Id;
 869       --  Builds integer literal one.
 870
 871       function P return Node_Id;
 872       --  Builds reference to identifier P.
 873
 874       function P_Succ return Node_Id;
 875       --  Builds expression Ind_Typ'Succ (P).
 876
 877       function R return Node_Id;
 878       --  Builds reference to identifier R.
 879
 880       function S (I : Nat) return Node_Id;
 881       --  Builds reference to identifier Si, where I is the value given.
 882
 883       function S_First (I : Nat) return Node_Id;
 884       --  Builds expression Si'First, where I is the value given.
 885
 886       function S_Last (I : Nat) return Node_Id;
 887       --  Builds expression Si'Last, where I is the value given.
 888
 889       function S_Length (I : Nat) return Node_Id;
 890       --  Builds expression Si'Length, where I is the value given.
 891
 892       function S_Length_Test (I : Nat) return Node_Id;
 893       --  Builds expression Si'Length /= 0, where I is the value given.
 894
 895       -------------------
 896       -- Copy_Into_R_S --
 897       -------------------
 898
 899       function Copy_Into_R_S (I : Nat) return List_Id is
 900          Stmts     : List_Id := New_List;
 901          P_Start   : Node_Id;
 902          Loop_Stmt : Node_Id;
 903          R_Copy    : Node_Id;
 904          Exit_Stmt : Node_Id;
 905          L_Inc     : Node_Id;
 906          P_Inc     : Node_Id;
 907
 908       begin
 909          --  First construct the initializations
 910
 911          P_Start := Make_Assignment_Statement (Loc,
 912                       Name       => P,
 913                       Expression => S_First (I));
 914          Append_To (Stmts, P_Start);
 915
 916          --  Then build the loop
 917
 918          R_Copy := Make_Assignment_Statement (Loc,
 919                      Name       => Make_Indexed_Component (Loc,
 920                                      Prefix      => R,
 921                                      Expressions => New_List (L)),
 922                      Expression => Make_Indexed_Component (Loc,
 923                                      Prefix      => S (I),
 924                                      Expressions => New_List (P)));
 925
 926          L_Inc := Make_Assignment_Statement (Loc,
 927                     Name       => L,
 928                     Expression => L_Succ);
 929
 930          Exit_Stmt := Make_Exit_Statement (Loc,
 931                         Condition => Make_Op_Eq (Loc, P, S_Last (I)));
 932
 933          P_Inc := Make_Assignment_Statement (Loc,
 934                     Name       => P,
 935                     Expression => P_Succ);
 936
 937          Loop_Stmt :=
 938            Make_Implicit_Loop_Statement (Cnode,
 939              Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
 940
 941          Append_To (Stmts, Loop_Stmt);
 942
 943          return Stmts;
 944       end Copy_Into_R_S;
 945
 946       -------
 947       -- H --
 948       -------
 949
 950       function H return Node_Id is
 951       begin
 952          return Make_Identifier (Loc, Name_uH);
 953       end H;
 954
 955       -------------
 956       -- Ind_Val --
 957       -------------
 958
 959       function Ind_Val (E : Node_Id) return Node_Id is
 960       begin
 961          return
 962            Make_Attribute_Reference (Loc,
 963              Prefix         => New_Reference_To (Ind_Typ, Loc),
 964              Attribute_Name => Name_Val,
 965              Expressions    => New_List (E));
 966       end Ind_Val;
 967
 968       ------------
 969       -- Init_L --
 970       ------------
 971
 972       function Init_L (I : Nat) return Node_Id is
 973          E : Node_Id;
 974
 975       begin
 976          if Is_Constrained (Arr_Typ) then
 977             E := Make_Attribute_Reference (Loc,
 978                    Prefix         => New_Reference_To (Arr_Typ, Loc),
 979                    Attribute_Name => Name_First);
 980
 981          else
 982             E := S_First (I);
 983          end if;
 984
 985          return Make_Assignment_Statement (Loc, Name => L, Expression => E);
 986       end Init_L;
 987
 988       -------
 989       -- L --
 990       -------
 991
 992       function L return Node_Id is
 993       begin
 994          return Make_Identifier (Loc, Name_uL);
 995       end L;
 996
 997       -----------
 998       -- L_Pos --
 999       -----------
1000
1001       function L_Pos return Node_Id is
1002       begin
1003          return
1004            Make_Attribute_Reference (Loc,
1005              Prefix         => New_Reference_To (Ind_Typ, Loc),
1006              Attribute_Name => Name_Pos,
1007              Expressions    => New_List (L));
1008       end L_Pos;
1009
1010       ------------
1011       -- L_Succ --
1012       ------------
1013
1014       function L_Succ return Node_Id is
1015       begin
1016          return
1017            Make_Attribute_Reference (Loc,
1018              Prefix         => New_Reference_To (Ind_Typ, Loc),
1019              Attribute_Name => Name_Succ,
1020              Expressions    => New_List (L));
1021       end L_Succ;
1022
1023       ---------
1024       -- One --
1025       ---------
1026
1027       function One return Node_Id is
1028       begin
1029          return Make_Integer_Literal (Loc, 1);
1030       end One;
1031
1032       -------
1033       -- P --
1034       -------
1035
1036       function P return Node_Id is
1037       begin
1038          return Make_Identifier (Loc, Name_uP);
1039       end P;
1040
1041       ------------
1042       -- P_Succ --
1043       ------------
1044
1045       function P_Succ return Node_Id is
1046       begin
1047          return
1048            Make_Attribute_Reference (Loc,
1049              Prefix         => New_Reference_To (Ind_Typ, Loc),
1050              Attribute_Name => Name_Succ,
1051              Expressions    => New_List (P));
1052       end P_Succ;
1053
1054       -------
1055       -- R --
1056       -------
1057
1058       function R return Node_Id is
1059       begin
1060          return Make_Identifier (Loc, Name_uR);
1061       end R;
1062
1063       -------
1064       -- S --
1065       -------
1066
1067       function S (I : Nat) return Node_Id is
1068       begin
1069          return Make_Identifier (Loc, New_External_Name ('S', I));
1070       end S;
1071
1072       -------------
1073       -- S_First --
1074       -------------
1075
1076       function S_First (I : Nat) return Node_Id is
1077       begin
1078          return Make_Attribute_Reference (Loc,
1079                   Prefix         => S (I),
1080                   Attribute_Name => Name_First);
1081       end S_First;
1082
1083       ------------
1084       -- S_Last --
1085       ------------
1086
1087       function S_Last (I : Nat) return Node_Id is
1088       begin
1089          return Make_Attribute_Reference (Loc,
1090                   Prefix         => S (I),
1091                   Attribute_Name => Name_Last);
1092       end S_Last;
1093
1094       --------------
1095       -- S_Length --
1096       --------------
1097
1098       function S_Length (I : Nat) return Node_Id is
1099       begin
1100          return Make_Attribute_Reference (Loc,
1101                   Prefix         => S (I),
1102                   Attribute_Name => Name_Length);
1103       end S_Length;
1104
1105       -------------------
1106       -- S_Length_Test --
1107       -------------------
1108
1109       function S_Length_Test (I : Nat) return Node_Id is
1110       begin
1111          return
1112            Make_Op_Ne (Loc,
1113              Left_Opnd  => S_Length (I),
1114              Right_Opnd => Make_Integer_Literal (Loc, 0));
1115       end S_Length_Test;
1116
1117    --  Start of processing for Expand_Concatenate_Other
1118
1119    begin
1120       --  Construct the parameter specs and the overall function spec
1121
1122       Param_Specs := New_List;
1123       for I in 1 .. Nb_Opnds loop
1124          Append_To
1125            (Param_Specs,
1126             Make_Parameter_Specification (Loc,
1127               Defining_Identifier =>
1128                 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
1129               Parameter_Type      => New_Reference_To (Base_Typ, Loc)));
1130       end loop;
1131
1132       Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
1133       Func_Spec :=
1134         Make_Function_Specification (Loc,
1135           Defining_Unit_Name       => Func_Id,
1136           Parameter_Specifications => Param_Specs,
1137           Subtype_Mark             => New_Reference_To (Base_Typ, Loc));
1138
1139       --  Construct L's object declaration
1140
1141       L_Decl :=
1142         Make_Object_Declaration (Loc,
1143           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
1144           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
1145
1146       Func_Decls := New_List (L_Decl);
1147
1148       --  Construct the if-then-elsif statements
1149
1150       Elsif_List := New_List;
1151       for I in 2 .. Nb_Opnds - 1 loop
1152          Append_To (Elsif_List, Make_Elsif_Part (Loc,
1153                                   Condition       => S_Length_Test (I),
1154                                   Then_Statements => New_List (Init_L (I))));
1155       end loop;
1156
1157       If_Stmt :=
1158         Make_Implicit_If_Statement (Cnode,
1159           Condition       => S_Length_Test (1),
1160           Then_Statements => New_List (Init_L (1)),
1161           Elsif_Parts     => Elsif_List,
1162           Else_Statements => New_List (Make_Return_Statement (Loc,
1163                                          Expression => S (Nb_Opnds))));
1164
1165       --  Construct the declaration for H
1166
1167       P_Decl :=
1168         Make_Object_Declaration (Loc,
1169           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
1170           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
1171
1172       H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
1173       for I in 2 .. Nb_Opnds loop
1174          H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
1175       end loop;
1176       H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
1177
1178       H_Decl :=
1179         Make_Object_Declaration (Loc,
1180           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
1181           Object_Definition   => New_Reference_To (Ind_Typ, Loc),
1182           Expression          => H_Init);
1183
1184       --  Construct the declaration for R
1185
1186       R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
1187       R_Constr :=
1188         Make_Index_Or_Discriminant_Constraint (Loc,
1189           Constraints => New_List (R_Range));
1190
1191       R_Decl :=
1192         Make_Object_Declaration (Loc,
1193           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
1194           Object_Definition   =>
1195             Make_Subtype_Indication (Loc,
1196                Subtype_Mark => New_Reference_To (Base_Typ, Loc),
1197                Constraint   => R_Constr));
1198
1199       --  Construct the declarations for the declare block
1200
1201       Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
1202
1203       --  Construct list of statements for the declare block
1204
1205       Declare_Stmts := New_List;
1206       for I in 1 .. Nb_Opnds loop
1207          Append_To (Declare_Stmts,
1208                     Make_Implicit_If_Statement (Cnode,
1209                       Condition       => S_Length_Test (I),
1210                       Then_Statements => Copy_Into_R_S (I)));
1211       end loop;
1212
1213       Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
1214
1215       --  Construct the declare block
1216
1217       Declare_Block := Make_Block_Statement (Loc,
1218         Declarations               => Declare_Decls,
1219         Handled_Statement_Sequence =>
1220           Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
1221
1222       --  Construct the list of function statements
1223
1224       Func_Stmts := New_List (If_Stmt, Declare_Block);
1225
1226       --  Construct the function body
1227
1228       Func_Body :=
1229         Make_Subprogram_Body (Loc,
1230           Specification              => Func_Spec,
1231           Declarations               => Func_Decls,
1232           Handled_Statement_Sequence =>
1233             Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
1234
1235       --  Insert the newly generated function in the code. This is analyzed
1236       --  with all checks off, since we have completed all the checks.
1237
1238       --  Note that this does *not* fix the array concatenation bug when the
1239       --  low bound is Integer'first sibce that bug comes from the pointer
1240       --  dereferencing an unconstrained array. An there we need a constraint
1241       --  check to make sure the length of the concatenated array is ok. ???
1242
1243       Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
1244
1245       --  Construct list of arguments for the function call
1246
1247       Params := New_List;
1248       Operand  := First (Opnds);
1249       for I in 1 .. Nb_Opnds loop
1250          Append_To (Params, Relocate_Node (Operand));
1251          Next (Operand);
1252       end loop;
1253
1254       --  Insert the function call
1255
1256       Rewrite
1257         (Cnode,
1258          Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
1259
1260       Analyze_And_Resolve (Cnode, Base_Typ);
1261       Set_Is_Inlined (Func_Id);
1262    end Expand_Concatenate_Other;
1263
1264    -------------------------------
1265    -- Expand_Concatenate_String --
1266    -------------------------------
1267
1268    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
1269       Loc   : constant Source_Ptr := Sloc (Cnode);
1270       Opnd1 : constant Node_Id    := First (Opnds);
1271       Opnd2 : constant Node_Id    := Next (Opnd1);
1272       Typ1  : constant Entity_Id  := Base_Type (Etype (Opnd1));
1273       Typ2  : constant Entity_Id  := Base_Type (Etype (Opnd2));
1274
1275       R : RE_Id;
1276       --  RE_Id value for function to be called
1277
1278    begin
1279       --  In all cases, we build a call to a routine giving the list of
1280       --  arguments as the parameter list to the routine.
1281
1282       case List_Length (Opnds) is
1283          when 2 =>
1284             if Typ1 = Standard_Character then
1285                if Typ2 = Standard_Character then
1286                   R := RE_Str_Concat_CC;
1287
1288                else
1289                   pragma Assert (Typ2 = Standard_String);
1290                   R := RE_Str_Concat_CS;
1291                end if;
1292
1293             elsif Typ1 = Standard_String then
1294                if Typ2 = Standard_Character then
1295                   R := RE_Str_Concat_SC;
1296
1297                else
1298                   pragma Assert (Typ2 = Standard_String);
1299                   R := RE_Str_Concat;
1300                end if;
1301
1302             --  If we have anything other than Standard_Character or
1303             --  Standard_String, then we must have had a serious error
1304             --  earlier, so we just abandon the attempt at expansion.
1305
1306             else
1307                pragma Assert (Serious_Errors_Detected > 0);
1308                return;
1309             end if;
1310
1311          when 3 =>
1312             R := RE_Str_Concat_3;
1313
1314          when 4 =>
1315             R := RE_Str_Concat_4;
1316
1317          when 5 =>
1318             R := RE_Str_Concat_5;
1319
1320          when others =>
1321             R := RE_Null;
1322             raise Program_Error;
1323       end case;
1324
1325       --  Now generate the appropriate call
1326
1327       Rewrite (Cnode,
1328         Make_Function_Call (Sloc (Cnode),
1329           Name => New_Occurrence_Of (RTE (R), Loc),
1330           Parameter_Associations => Opnds));
1331
1332       Analyze_And_Resolve (Cnode, Standard_String);
1333    end Expand_Concatenate_String;
1334
1335    ------------------------
1336    -- Expand_N_Allocator --
1337    ------------------------
1338
1339    procedure Expand_N_Allocator (N : Node_Id) is
1340       PtrT  : constant Entity_Id  := Etype (N);
1341       Desig : Entity_Id;
1342       Loc   : constant Source_Ptr := Sloc (N);
1343       Temp  : Entity_Id;
1344       Node  : Node_Id;
1345
1346    begin
1347       --  RM E.2.3(22). We enforce that the expected type of an allocator
1348       --  shall not be a remote access-to-class-wide-limited-private type
1349
1350       --  Why is this being done at expansion time, seems clearly wrong ???
1351
1352       Validate_Remote_Access_To_Class_Wide_Type (N);
1353
1354       --  Set the Storage Pool
1355
1356       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
1357
1358       if Present (Storage_Pool (N)) then
1359          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
1360             if not Java_VM then
1361                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
1362             end if;
1363          else
1364             Set_Procedure_To_Call (N,
1365               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
1366          end if;
1367       end if;
1368
1369       --  Under certain circumstances we can replace an allocator by an
1370       --  access to statically allocated storage. The conditions, as noted
1371       --  in AARM 3.10 (10c) are as follows:
1372
1373       --    Size and initial value is known at compile time
1374       --    Access type is access-to-constant
1375
1376       if Is_Access_Constant (PtrT)
1377         and then Nkind (Expression (N)) = N_Qualified_Expression
1378         and then Compile_Time_Known_Value (Expression (Expression (N)))
1379         and then Size_Known_At_Compile_Time (Etype (Expression
1380                                                     (Expression (N))))
1381       then
1382          --  Here we can do the optimization. For the allocator
1383
1384          --    new x'(y)
1385
1386          --  We insert an object declaration
1387
1388          --    Tnn : aliased x := y;
1389
1390          --  and replace the allocator by Tnn'Unrestricted_Access.
1391          --  Tnn is marked as requiring static allocation.
1392
1393          Temp :=
1394            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
1395
1396          Desig := Subtype_Mark (Expression (N));
1397
1398          --  If context is constrained, use constrained subtype directly,
1399          --  so that the constant is not labelled as having a nomimally
1400          --  unconstrained subtype.
1401
1402          if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
1403             Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
1404          end if;
1405
1406          Insert_Action (N,
1407            Make_Object_Declaration (Loc,
1408              Defining_Identifier => Temp,
1409              Aliased_Present     => True,
1410              Constant_Present    => Is_Access_Constant (PtrT),
1411              Object_Definition   => Desig,
1412              Expression          => Expression (Expression (N))));
1413
1414          Rewrite (N,
1415            Make_Attribute_Reference (Loc,
1416              Prefix => New_Occurrence_Of (Temp, Loc),
1417              Attribute_Name => Name_Unrestricted_Access));
1418
1419          Analyze_And_Resolve (N, PtrT);
1420
1421          --  We set the variable as statically allocated, since we don't
1422          --  want it going on the stack of the current procedure!
1423
1424          Set_Is_Statically_Allocated (Temp);
1425          return;
1426       end if;
1427
1428       --  If the allocator is for a type which requires initialization, and
1429       --  there is no initial value (i.e. the operand is a subtype indication
1430       --  rather than a qualifed expression), then we must generate a call to
1431       --  the initialization routine. This is done using an expression actions
1432       --  node:
1433       --
1434       --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
1435       --
1436       --  Here ptr_T is the pointer type for the allocator, and T is the
1437       --  subtype of the allocator. A special case arises if the designated
1438       --  type of the access type is a task or contains tasks. In this case
1439       --  the call to Init (Temp.all ...) is replaced by code that ensures
1440       --  that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
1441       --  for details). In addition, if the type T is a task T, then the first
1442       --  argument to Init must be converted to the task record type.
1443
1444       if Nkind (Expression (N)) = N_Qualified_Expression then
1445          declare
1446             Indic : constant Node_Id   := Subtype_Mark (Expression (N));
1447             T     : constant Entity_Id := Entity (Indic);
1448             Exp   : constant Node_Id   := Expression (Expression (N));
1449
1450             Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
1451
1452             Tag_Assign : Node_Id;
1453             Tmp_Node   : Node_Id;
1454
1455          begin
1456             if Is_Tagged_Type (T) or else Controlled_Type (T) then
1457
1458                --    Actions inserted before:
1459                --              Temp : constant ptr_T := new T'(Expression);
1460                --   <no CW>    Temp._tag := T'tag;
1461                --   <CTRL>     Adjust (Finalizable (Temp.all));
1462                --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
1463
1464                --  We analyze by hand the new internal allocator to avoid
1465                --  any recursion and inappropriate call to Initialize
1466                if not Aggr_In_Place then
1467                   Remove_Side_Effects (Exp);
1468                end if;
1469
1470                Temp :=
1471                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1472
1473                --  For a class wide allocation generate the following code:
1474
1475                --    type Equiv_Record is record ... end record;
1476                --    implicit subtype CW is <Class_Wide_Subytpe>;
1477                --    temp : PtrT := new CW'(CW!(expr));
1478
1479                if Is_Class_Wide_Type (T) then
1480                   Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
1481
1482                   Set_Expression (Expression (N),
1483                     Unchecked_Convert_To (Entity (Indic), Exp));
1484
1485                   Analyze_And_Resolve (Expression (N), Entity (Indic));
1486                end if;
1487
1488                if Aggr_In_Place then
1489                   Tmp_Node :=
1490                     Make_Object_Declaration (Loc,
1491                       Defining_Identifier => Temp,
1492                       Object_Definition   => New_Reference_To (PtrT, Loc),
1493                       Expression          => Make_Allocator (Loc,
1494                           New_Reference_To (Etype (Exp), Loc)));
1495
1496                   Set_No_Initialization (Expression (Tmp_Node));
1497                   Insert_Action (N, Tmp_Node);
1498                   Convert_Aggr_In_Allocator (Tmp_Node, Exp);
1499                else
1500                   Node := Relocate_Node (N);
1501                   Set_Analyzed (Node);
1502                   Insert_Action (N,
1503                     Make_Object_Declaration (Loc,
1504                       Defining_Identifier => Temp,
1505                       Constant_Present    => True,
1506                       Object_Definition   => New_Reference_To (PtrT, Loc),
1507                       Expression          => Node));
1508                end if;
1509
1510                --  Suppress the tag assignment when Java_VM because JVM tags
1511                --  are represented implicitly in objects.
1512
1513                if Is_Tagged_Type (T)
1514                  and then not Is_Class_Wide_Type (T)
1515                  and then not Java_VM
1516                then
1517                   Tag_Assign :=
1518                     Make_Assignment_Statement (Loc,
1519                       Name =>
1520                         Make_Selected_Component (Loc,
1521                           Prefix => New_Reference_To (Temp, Loc),
1522                           Selector_Name =>
1523                             New_Reference_To (Tag_Component (T), Loc)),
1524
1525                       Expression =>
1526                         Unchecked_Convert_To (RTE (RE_Tag),
1527                           New_Reference_To (Access_Disp_Table (T), Loc)));
1528
1529                   --  The previous assignment has to be done in any case
1530
1531                   Set_Assignment_OK (Name (Tag_Assign));
1532                   Insert_Action (N, Tag_Assign);
1533
1534                elsif Is_Private_Type (T)
1535                  and then Is_Tagged_Type (Underlying_Type (T))
1536                  and then not Java_VM
1537                then
1538                   declare
1539                      Utyp : constant Entity_Id := Underlying_Type (T);
1540                      Ref  : constant Node_Id :=
1541                               Unchecked_Convert_To (Utyp,
1542                                 Make_Explicit_Dereference (Loc,
1543                                   New_Reference_To (Temp, Loc)));
1544
1545                   begin
1546                      Tag_Assign :=
1547                        Make_Assignment_Statement (Loc,
1548                          Name =>
1549                            Make_Selected_Component (Loc,
1550                              Prefix => Ref,
1551                              Selector_Name =>
1552                                New_Reference_To (Tag_Component (Utyp), Loc)),
1553
1554                          Expression =>
1555                            Unchecked_Convert_To (RTE (RE_Tag),
1556                              New_Reference_To (
1557                                Access_Disp_Table (Utyp), Loc)));
1558
1559                      Set_Assignment_OK (Name (Tag_Assign));
1560                      Insert_Action (N, Tag_Assign);
1561                   end;
1562                end if;
1563
1564                if Controlled_Type (Designated_Type (PtrT))
1565                   and then Controlled_Type (T)
1566                then
1567                   declare
1568                      Flist  : Node_Id;
1569                      Attach : Node_Id;
1570                      Apool  : constant Entity_Id :=
1571                                 Associated_Storage_Pool (PtrT);
1572
1573                   begin
1574                      --  If it is an allocation on the secondary stack
1575                      --  (i.e. a value returned from a function), the object
1576                      --  is attached on the caller side as soon as the call
1577                      --  is completed (see Expand_Ctrl_Function_Call)
1578
1579                      if Is_RTE (Apool, RE_SS_Pool) then
1580                         declare
1581                            F : constant Entity_Id :=
1582                                  Make_Defining_Identifier (Loc,
1583                                    New_Internal_Name ('F'));
1584                         begin
1585                            Insert_Action (N,
1586                              Make_Object_Declaration (Loc,
1587                                Defining_Identifier => F,
1588                                Object_Definition   => New_Reference_To (RTE
1589                                 (RE_Finalizable_Ptr), Loc)));
1590
1591                            Flist := New_Reference_To (F, Loc);
1592                            Attach :=  Make_Integer_Literal (Loc, 1);
1593                         end;
1594
1595                      --  Normal case, not a secondary stack allocation
1596
1597                      else
1598                         Flist := Find_Final_List (PtrT);
1599                         Attach :=  Make_Integer_Literal (Loc, 2);
1600                      end if;
1601
1602                      if not Aggr_In_Place then
1603                         Insert_Actions (N,
1604                           Make_Adjust_Call (
1605                             Ref          =>
1606
1607                            --  An unchecked conversion is needed in the
1608                            --  classwide case because the designated type
1609                            --  can be an ancestor of the subtype mark of
1610                            --  the allocator.
1611
1612                             Unchecked_Convert_To (T,
1613                               Make_Explicit_Dereference (Loc,
1614                                 New_Reference_To (Temp, Loc))),
1615
1616                             Typ          => T,
1617                             Flist_Ref    => Flist,
1618                             With_Attach  => Attach));
1619                      end if;
1620                   end;
1621                end if;
1622
1623                Rewrite (N, New_Reference_To (Temp, Loc));
1624                Analyze_And_Resolve (N, PtrT);
1625
1626             elsif Aggr_In_Place then
1627                Temp :=
1628                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1629                Tmp_Node :=
1630                  Make_Object_Declaration (Loc,
1631                    Defining_Identifier => Temp,
1632                    Object_Definition   => New_Reference_To (PtrT, Loc),
1633                    Expression          => Make_Allocator (Loc,
1634                        New_Reference_To (Etype (Exp), Loc)));
1635
1636                Set_No_Initialization (Expression (Tmp_Node));
1637                Insert_Action (N, Tmp_Node);
1638                Convert_Aggr_In_Allocator (Tmp_Node, Exp);
1639                Rewrite (N, New_Reference_To (Temp, Loc));
1640                Analyze_And_Resolve (N, PtrT);
1641
1642             elsif Is_Access_Type (Designated_Type (PtrT))
1643               and then Nkind (Exp) = N_Allocator
1644               and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1645             then
1646                --  Apply constraint to designated subtype indication.
1647
1648                Apply_Constraint_Check (Expression (Exp),
1649                  Designated_Type (Designated_Type (PtrT)),
1650                  No_Sliding => True);
1651
1652                if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1653
1654                   --  Propagate constraint_error to enclosing allocator
1655
1656                   Rewrite (Exp, New_Copy (Expression (Exp)));
1657                end if;
1658             else
1659                --  First check against the type of the qualified expression
1660                --
1661                --  NOTE: The commented call should be correct, but for
1662                --  some reason causes the compiler to bomb (sigsegv) on
1663                --  ACVC test c34007g, so for now we just perform the old
1664                --  (incorrect) test against the designated subtype with
1665                --  no sliding in the else part of the if statement below.
1666                --  ???
1667                --
1668                --  Apply_Constraint_Check (Exp, T, No_Sliding => True);
1669
1670                --  A check is also needed in cases where the designated
1671                --  subtype is constrained and differs from the subtype
1672                --  given in the qualified expression. Note that the check
1673                --  on the qualified expression does not allow sliding,
1674                --  but this check does (a relaxation from Ada 83).
1675
1676                if Is_Constrained (Designated_Type (PtrT))
1677                  and then not Subtypes_Statically_Match
1678                                 (T, Designated_Type (PtrT))
1679                then
1680                   Apply_Constraint_Check
1681                     (Exp, Designated_Type (PtrT), No_Sliding => False);
1682
1683                --  The nonsliding check should really be performed
1684                --  (unconditionally) against the subtype of the
1685                --  qualified expression, but that causes a problem
1686                --  with c34007g (see above), so for now we retain this.
1687
1688                else
1689                   Apply_Constraint_Check
1690                     (Exp, Designated_Type (PtrT), No_Sliding => True);
1691                end if;
1692             end if;
1693          end;
1694
1695       --  Here if not qualified expression case.
1696       --  In this case, an initialization routine may be required
1697
1698       else
1699          declare
1700             T         : constant Entity_Id  := Entity (Expression (N));
1701             Init      : Entity_Id;
1702             Arg1      : Node_Id;
1703             Args      : List_Id;
1704             Decls     : List_Id;
1705             Decl      : Node_Id;
1706             Discr     : Elmt_Id;
1707             Flist     : Node_Id;
1708             Temp_Decl : Node_Id;
1709             Temp_Type : Entity_Id;
1710
1711          begin
1712
1713             if No_Initialization (N) then
1714                null;
1715
1716             --  Case of no initialization procedure present
1717
1718             elsif not Has_Non_Null_Base_Init_Proc (T) then
1719
1720                --  Case of simple initialization required
1721
1722                if Needs_Simple_Initialization (T) then
1723                   Rewrite (Expression (N),
1724                     Make_Qualified_Expression (Loc,
1725                       Subtype_Mark => New_Occurrence_Of (T, Loc),
1726                       Expression   => Get_Simple_Init_Val (T, Loc)));
1727
1728                   Analyze_And_Resolve (Expression (Expression (N)), T);
1729                   Analyze_And_Resolve (Expression (N), T);
1730                   Set_Paren_Count (Expression (Expression (N)), 1);
1731                   Expand_N_Allocator (N);
1732
1733                --  No initialization required
1734
1735                else
1736                   null;
1737                end if;
1738
1739             --  Case of initialization procedure present, must be called
1740
1741             else
1742                Init := Base_Init_Proc (T);
1743                Node := N;
1744                Temp :=
1745                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1746
1747                --  Construct argument list for the initialization routine call
1748                --  The CPP constructor needs the address directly
1749
1750                if Is_CPP_Class (T) then
1751                   Arg1 := New_Reference_To (Temp, Loc);
1752                   Temp_Type := T;
1753
1754                else
1755                   Arg1 :=
1756                     Make_Explicit_Dereference (Loc,
1757                       Prefix => New_Reference_To (Temp, Loc));
1758                   Set_Assignment_OK (Arg1);
1759                   Temp_Type := PtrT;
1760
1761                   --  The initialization procedure expects a specific type.
1762                   --  if the context is access to class wide, indicate that
1763                   --  the object being allocated has the right specific type.
1764
1765                   if Is_Class_Wide_Type (Designated_Type (PtrT)) then
1766                      Arg1 := Unchecked_Convert_To (T, Arg1);
1767                   end if;
1768                end if;
1769
1770                --  If designated type is a concurrent type or if it is a
1771                --  private type whose definition is a concurrent type,
1772                --  the first argument in the Init routine has to be
1773                --  unchecked conversion to the corresponding record type.
1774                --  If the designated type is a derived type, we also
1775                --  convert the argument to its root type.
1776
1777                if Is_Concurrent_Type (T) then
1778                   Arg1 :=
1779                     Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
1780
1781                elsif Is_Private_Type (T)
1782                  and then Present (Full_View (T))
1783                  and then Is_Concurrent_Type (Full_View (T))
1784                then
1785                   Arg1 :=
1786                     Unchecked_Convert_To
1787                       (Corresponding_Record_Type (Full_View (T)), Arg1);
1788
1789                elsif Etype (First_Formal (Init)) /= Base_Type (T) then
1790
1791                   declare
1792                      Ftyp : constant Entity_Id := Etype (First_Formal (Init));
1793
1794                   begin
1795                      Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
1796                      Set_Etype (Arg1, Ftyp);
1797                   end;
1798                end if;
1799
1800                Args := New_List (Arg1);
1801
1802                --  For the task case, pass the Master_Id of the access type
1803                --  as the value of the _Master parameter, and _Chain as the
1804                --  value of the _Chain parameter (_Chain will be defined as
1805                --  part of the generated code for the allocator).
1806
1807                if Has_Task (T) then
1808
1809                   if No (Master_Id (Base_Type (PtrT))) then
1810
1811                      --  The designated type was an incomplete type, and
1812                      --  the access type did not get expanded. Salvage
1813                      --  it now.
1814
1815                      Expand_N_Full_Type_Declaration
1816                        (Parent (Base_Type (PtrT)));
1817                   end if;
1818
1819                   --  If the context of the allocator is a declaration or
1820                   --  an assignment, we can generate a meaningful image for
1821                   --  it, even though subsequent assignments might remove
1822                   --  the connection between task and entity. We build this
1823                   --  image when the left-hand side is a simple variable,
1824                   --  a simple indexed assignment or a simple selected
1825                   --  component.
1826
1827                   if Nkind (Parent (N)) = N_Assignment_Statement then
1828                      declare
1829                         Nam : constant Node_Id := Name (Parent (N));
1830
1831                      begin
1832                         if Is_Entity_Name (Nam) then
1833                            Decls :=
1834                              Build_Task_Image_Decls (
1835                                Loc,
1836                                  New_Occurrence_Of
1837                                    (Entity (Nam), Sloc (Nam)), T);
1838
1839                         elsif (Nkind (Nam) = N_Indexed_Component
1840                                 or else Nkind (Nam) = N_Selected_Component)
1841                           and then Is_Entity_Name (Prefix (Nam))
1842                         then
1843                            Decls :=
1844                              Build_Task_Image_Decls
1845                                (Loc, Nam, Etype (Prefix (Nam)));
1846                         else
1847                            Decls := Build_Task_Image_Decls (Loc, T, T);
1848                         end if;
1849                      end;
1850
1851                   elsif Nkind (Parent (N)) = N_Object_Declaration then
1852                      Decls :=
1853                        Build_Task_Image_Decls (
1854                           Loc, Defining_Identifier (Parent (N)), T);
1855
1856                   else
1857                      Decls := Build_Task_Image_Decls (Loc, T, T);
1858                   end if;
1859
1860                   Append_To (Args,
1861                     New_Reference_To
1862                       (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
1863                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
1864
1865                   Decl := Last (Decls);
1866                   Append_To (Args,
1867                     New_Occurrence_Of (Defining_Identifier (Decl), Loc));
1868
1869                --  Has_Task is false, Decls not used
1870
1871                else
1872                   Decls := No_List;
1873                end if;
1874
1875                --  Add discriminants if discriminated type
1876
1877                if Has_Discriminants (T) then
1878                   Discr := First_Elmt (Discriminant_Constraint (T));
1879
1880                   while Present (Discr) loop
1881                      Append (New_Copy (Elists.Node (Discr)), Args);
1882                      Next_Elmt (Discr);
1883                   end loop;
1884
1885                elsif Is_Private_Type (T)
1886                  and then Present (Full_View (T))
1887                  and then Has_Discriminants (Full_View (T))
1888                then
1889                   Discr :=
1890                     First_Elmt (Discriminant_Constraint (Full_View (T)));
1891
1892                   while Present (Discr) loop
1893                      Append (New_Copy (Elists.Node (Discr)), Args);
1894                      Next_Elmt (Discr);
1895                   end loop;
1896                end if;
1897
1898                --  We set the allocator as analyzed so that when we analyze the
1899                --  expression actions node, we do not get an unwanted recursive
1900                --  expansion of the allocator expression.
1901
1902                Set_Analyzed (N, True);
1903                Node := Relocate_Node (N);
1904
1905                --  Here is the transformation:
1906                --    input:  new T
1907                --    output: Temp : constant ptr_T := new T;
1908                --            Init (Temp.all, ...);
1909                --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
1910                --    <CTRL>  Initialize (Finalizable (Temp.all));
1911
1912                --  Here ptr_T is the pointer type for the allocator, and T
1913                --  is the subtype of the allocator.
1914
1915                Temp_Decl :=
1916                  Make_Object_Declaration (Loc,
1917                    Defining_Identifier => Temp,
1918                    Constant_Present    => True,
1919                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
1920                    Expression          => Node);
1921
1922                Set_Assignment_OK (Temp_Decl);
1923
1924                if Is_CPP_Class (T) then
1925                   Set_Aliased_Present (Temp_Decl);
1926                end if;
1927
1928                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
1929
1930                --  Case of designated type is task or contains task
1931                --  Create block to activate created tasks, and insert
1932                --  declaration for Task_Image variable ahead of call.
1933
1934                if Has_Task (T) then
1935                   declare
1936                      L   : List_Id := New_List;
1937                      Blk : Node_Id;
1938
1939                   begin
1940                      Build_Task_Allocate_Block (L, Node, Args);
1941                      Blk := Last (L);
1942
1943                      Insert_List_Before (First (Declarations (Blk)), Decls);
1944                      Insert_Actions (N, L);
1945                   end;
1946
1947                else
1948                   Insert_Action (N,
1949                     Make_Procedure_Call_Statement (Loc,
1950                       Name => New_Reference_To (Init, Loc),
1951                       Parameter_Associations => Args));
1952                end if;
1953
1954                if Controlled_Type (T) then
1955
1956                   --  If the context is an access parameter, we need to create
1957                   --  a non-anonymous access type in order to have a usable
1958                   --  final list, because there is otherwise no pool to which
1959                   --  the allocated object can belong. We create both the type
1960                   --  and the finalization chain here, because freezing an
1961                   --  internal type does not create such a chain.
1962
1963                   if Ekind (PtrT) = E_Anonymous_Access_Type then
1964                      declare
1965                         Acc : Entity_Id :=
1966                                 Make_Defining_Identifier (Loc,
1967                                   New_Internal_Name ('I'));
1968                      begin
1969                         Insert_Action (N,
1970                           Make_Full_Type_Declaration (Loc,
1971                             Defining_Identifier => Acc,
1972                             Type_Definition =>
1973                                Make_Access_To_Object_Definition (Loc,
1974                                  Subtype_Indication =>
1975                                    New_Occurrence_Of (T, Loc))));
1976
1977                         Build_Final_List (N, Acc);
1978                         Flist := Find_Final_List (Acc);
1979                      end;
1980
1981                   else
1982                      Flist := Find_Final_List (PtrT);
1983                   end if;
1984
1985                   Insert_Actions (N,
1986                     Make_Init_Call (
1987                       Ref          => New_Copy_Tree (Arg1),
1988                       Typ          => T,
1989                       Flist_Ref    => Flist,
1990                       With_Attach  => Make_Integer_Literal (Loc, 2)));
1991                end if;
1992
1993                if Is_CPP_Class (T) then
1994                   Rewrite (N,
1995                     Make_Attribute_Reference (Loc,
1996                       Prefix => New_Reference_To (Temp, Loc),
1997                       Attribute_Name => Name_Unchecked_Access));
1998                else
1999                   Rewrite (N, New_Reference_To (Temp, Loc));
2000                end if;
2001
2002                Analyze_And_Resolve (N, PtrT);
2003             end if;
2004          end;
2005       end if;
2006    end Expand_N_Allocator;
2007
2008    -----------------------
2009    -- Expand_N_And_Then --
2010    -----------------------
2011
2012    --  Expand into conditional expression if Actions present, and also
2013    --  deal with optimizing case of arguments being True or False.
2014
2015    procedure Expand_N_And_Then (N : Node_Id) is
2016       Loc     : constant Source_Ptr := Sloc (N);
2017       Typ     : constant Entity_Id  := Etype (N);
2018       Left    : constant Node_Id    := Left_Opnd (N);
2019       Right   : constant Node_Id    := Right_Opnd (N);
2020       Actlist : List_Id;
2021
2022    begin
2023       --  Deal with non-standard booleans
2024
2025       if Is_Boolean_Type (Typ) then
2026          Adjust_Condition (Left);
2027          Adjust_Condition (Right);
2028          Set_Etype (N, Standard_Boolean);
2029       end if;
2030
2031       --  Check for cases of left argument is True or False
2032
2033       if Nkind (Left) = N_Identifier then
2034
2035          --  If left argument is True, change (True and then Right) to Right.
2036          --  Any actions associated with Right will be executed unconditionally
2037          --  and can thus be inserted into the tree unconditionally.
2038
2039          if Entity (Left) = Standard_True then
2040             if Present (Actions (N)) then
2041                Insert_Actions (N, Actions (N));
2042             end if;
2043
2044             Rewrite (N, Right);
2045             Adjust_Result_Type (N, Typ);
2046             return;
2047
2048          --  If left argument is False, change (False and then Right) to
2049          --  False. In this case we can forget the actions associated with
2050          --  Right, since they will never be executed.
2051
2052          elsif Entity (Left) = Standard_False then
2053             Kill_Dead_Code (Right);
2054             Kill_Dead_Code (Actions (N));
2055             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
2056             Adjust_Result_Type (N, Typ);
2057             return;
2058          end if;
2059       end if;
2060
2061       --  If Actions are present, we expand
2062
2063       --     left and then right
2064
2065       --  into
2066
2067       --     if left then right else false end
2068
2069       --  with the actions becoming the Then_Actions of the conditional
2070       --  expression. This conditional expression is then further expanded
2071       --  (and will eventually disappear)
2072
2073       if Present (Actions (N)) then
2074          Actlist := Actions (N);
2075          Rewrite (N,
2076             Make_Conditional_Expression (Loc,
2077               Expressions => New_List (
2078                 Left,
2079                 Right,
2080                 New_Occurrence_Of (Standard_False, Loc))));
2081
2082          Set_Then_Actions (N, Actlist);
2083          Analyze_And_Resolve (N, Standard_Boolean);
2084          Adjust_Result_Type (N, Typ);
2085          return;
2086       end if;
2087
2088       --  No actions present, check for cases of right argument True/False
2089
2090       if Nkind (Right) = N_Identifier then
2091
2092          --  Change (Left and then True) to Left. Note that we know there
2093          --  are no actions associated with the True operand, since we
2094          --  just checked for this case above.
2095
2096          if Entity (Right) = Standard_True then
2097             Rewrite (N, Left);
2098
2099          --  Change (Left and then False) to False, making sure to preserve
2100          --  any side effects associated with the Left operand.
2101
2102          elsif Entity (Right) = Standard_False then
2103             Remove_Side_Effects (Left);
2104             Rewrite
2105               (N, New_Occurrence_Of (Standard_False, Loc));
2106          end if;
2107       end if;
2108
2109       Adjust_Result_Type (N, Typ);
2110    end Expand_N_And_Then;
2111
2112    -------------------------------------
2113    -- Expand_N_Conditional_Expression --
2114    -------------------------------------
2115
2116    --  Expand into expression actions if then/else actions present
2117
2118    procedure Expand_N_Conditional_Expression (N : Node_Id) is
2119       Loc    : constant Source_Ptr := Sloc (N);
2120       Cond   : constant Node_Id    := First (Expressions (N));
2121       Thenx  : constant Node_Id    := Next (Cond);
2122       Elsex  : constant Node_Id    := Next (Thenx);
2123       Typ    : constant Entity_Id  := Etype (N);
2124       Cnn    : Entity_Id;
2125       New_If : Node_Id;
2126
2127    begin
2128       --  If either then or else actions are present, then given:
2129
2130       --     if cond then then-expr else else-expr end
2131
2132       --  we insert the following sequence of actions (using Insert_Actions):
2133
2134       --      Cnn : typ;
2135       --      if cond then
2136       --         <<then actions>>
2137       --         Cnn := then-expr;
2138       --      else
2139       --         <<else actions>>
2140       --         Cnn := else-expr
2141       --      end if;
2142
2143       --  and replace the conditional expression by a reference to Cnn.
2144
2145       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
2146          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
2147
2148          New_If :=
2149            Make_Implicit_If_Statement (N,
2150              Condition => Relocate_Node (Cond),
2151
2152              Then_Statements => New_List (
2153                Make_Assignment_Statement (Sloc (Thenx),
2154                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
2155                  Expression => Relocate_Node (Thenx))),
2156
2157              Else_Statements => New_List (
2158                Make_Assignment_Statement (Sloc (Elsex),
2159                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
2160                  Expression => Relocate_Node (Elsex))));
2161
2162          if Present (Then_Actions (N)) then
2163             Insert_List_Before
2164               (First (Then_Statements (New_If)), Then_Actions (N));
2165          end if;
2166
2167          if Present (Else_Actions (N)) then
2168             Insert_List_Before
2169               (First (Else_Statements (New_If)), Else_Actions (N));
2170          end if;
2171
2172          Rewrite (N, New_Occurrence_Of (Cnn, Loc));
2173
2174          Insert_Action (N,
2175            Make_Object_Declaration (Loc,
2176              Defining_Identifier => Cnn,
2177              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
2178
2179          Insert_Action (N, New_If);
2180          Analyze_And_Resolve (N, Typ);
2181       end if;
2182    end Expand_N_Conditional_Expression;
2183
2184    -----------------------------------
2185    -- Expand_N_Explicit_Dereference --
2186    -----------------------------------
2187
2188    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
2189    begin
2190       --  The only processing required is an insertion of an explicit
2191       --  dereference call for the checked storage pool case.
2192
2193       Insert_Dereference_Action (Prefix (N));
2194    end Expand_N_Explicit_Dereference;
2195
2196    -----------------
2197    -- Expand_N_In --
2198    -----------------
2199
2200    procedure Expand_N_In (N : Node_Id) is
2201       Loc  : constant Source_Ptr := Sloc (N);
2202       Rtyp : constant Entity_Id  := Etype (N);
2203
2204    begin
2205       --  No expansion is required if we have an explicit range
2206
2207       if Nkind (Right_Opnd (N)) = N_Range then
2208          return;
2209
2210       --  Here right operand is a subtype mark
2211
2212       else
2213          declare
2214             Typ    : Entity_Id := Etype (Right_Opnd (N));
2215             Obj    : Node_Id   := Left_Opnd (N);
2216             Cond   : Node_Id := Empty;
2217             Is_Acc : Boolean := Is_Access_Type (Typ);
2218
2219          begin
2220             Remove_Side_Effects (Obj);
2221
2222             --  For tagged type, do tagged membership operation
2223
2224             if Is_Tagged_Type (Typ) then
2225                --  No expansion will be performed when Java_VM, as the
2226                --  JVM back end will handle the membership tests directly
2227                --  (tags are not explicitly represented in Java objects,
2228                --  so the normal tagged membership expansion is not what
2229                --  we want).
2230
2231                if not Java_VM then
2232                   Rewrite (N, Tagged_Membership (N));
2233                   Analyze_And_Resolve (N, Rtyp);
2234                end if;
2235
2236                return;
2237
2238             --  If type is scalar type, rewrite as x in t'first .. t'last
2239             --  This reason we do this is that the bounds may have the wrong
2240             --  type if they come from the original type definition.
2241
2242             elsif Is_Scalar_Type (Typ) then
2243                Rewrite (Right_Opnd (N),
2244                  Make_Range (Loc,
2245                    Low_Bound =>
2246                      Make_Attribute_Reference (Loc,
2247                        Attribute_Name => Name_First,
2248                        Prefix => New_Reference_To (Typ, Loc)),
2249
2250                    High_Bound =>
2251                      Make_Attribute_Reference (Loc,
2252                        Attribute_Name => Name_Last,
2253                        Prefix => New_Reference_To (Typ, Loc))));
2254                Analyze_And_Resolve (N, Rtyp);
2255                return;
2256             end if;
2257
2258             if Is_Acc then
2259                Typ := Designated_Type (Typ);
2260             end if;
2261
2262             if not Is_Constrained (Typ) then
2263                Rewrite (N,
2264                  New_Reference_To (Standard_True, Loc));
2265                Analyze_And_Resolve (N, Rtyp);
2266
2267             --  For the constrained array case, we have to check the
2268             --  subscripts for an exact match if the lengths are
2269             --  non-zero (the lengths must match in any case).
2270
2271             elsif Is_Array_Type (Typ) then
2272
2273                declare
2274                   function Construct_Attribute_Reference
2275                     (E    : Node_Id;
2276                      Nam  : Name_Id;
2277                      Dim  : Nat)
2278                      return Node_Id;
2279                   --  Build attribute reference E'Nam(Dim)
2280
2281                   function Construct_Attribute_Reference
2282                     (E    : Node_Id;
2283                      Nam  : Name_Id;
2284                      Dim  : Nat)
2285                      return Node_Id
2286                   is
2287                   begin
2288                      return
2289                        Make_Attribute_Reference (Loc,
2290                          Prefix => E,
2291                          Attribute_Name => Nam,
2292                          Expressions => New_List (
2293                            Make_Integer_Literal (Loc, Dim)));
2294                   end Construct_Attribute_Reference;
2295
2296                begin
2297                   for J in 1 .. Number_Dimensions (Typ) loop
2298                      Evolve_And_Then (Cond,
2299                        Make_Op_Eq (Loc,
2300                          Left_Opnd  =>
2301                            Construct_Attribute_Reference
2302                              (Duplicate_Subexpr (Obj), Name_First, J),
2303                          Right_Opnd =>
2304                            Construct_Attribute_Reference
2305                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
2306
2307                      Evolve_And_Then (Cond,
2308                        Make_Op_Eq (Loc,
2309                          Left_Opnd  =>
2310                            Construct_Attribute_Reference
2311                              (Duplicate_Subexpr (Obj), Name_Last, J),
2312                          Right_Opnd =>
2313                            Construct_Attribute_Reference
2314                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
2315                   end loop;
2316
2317                   if Is_Acc then
2318                      Cond := Make_Or_Else (Loc,
2319                        Left_Opnd =>
2320                          Make_Op_Eq (Loc,
2321                            Left_Opnd  => Obj,
2322                            Right_Opnd => Make_Null (Loc)),
2323                        Right_Opnd => Cond);
2324                   end if;
2325
2326                   Rewrite (N, Cond);
2327                   Analyze_And_Resolve (N, Rtyp);
2328                end;
2329
2330             --  These are the cases where constraint checks may be
2331             --  required, e.g. records with possible discriminants
2332
2333             else
2334                --  Expand the test into a series of discriminant comparisons.
2335                --  The expression that is built is the negation of the one
2336                --  that is used for checking discriminant constraints.
2337
2338                Obj := Relocate_Node (Left_Opnd (N));
2339
2340                if Has_Discriminants (Typ) then
2341                   Cond := Make_Op_Not (Loc,
2342                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
2343
2344                   if Is_Acc then
2345                      Cond := Make_Or_Else (Loc,
2346                        Left_Opnd =>
2347                          Make_Op_Eq (Loc,
2348                            Left_Opnd  => Obj,
2349                            Right_Opnd => Make_Null (Loc)),
2350                        Right_Opnd => Cond);
2351                   end if;
2352
2353                else
2354                   Cond := New_Occurrence_Of (Standard_True, Loc);
2355                end if;
2356
2357                Rewrite (N, Cond);
2358                Analyze_And_Resolve (N, Rtyp);
2359             end if;
2360          end;
2361       end if;
2362    end Expand_N_In;
2363
2364    --------------------------------
2365    -- Expand_N_Indexed_Component --
2366    --------------------------------
2367
2368    procedure Expand_N_Indexed_Component (N : Node_Id) is
2369       Loc : constant Source_Ptr := Sloc (N);
2370       Typ : constant Entity_Id  := Etype (N);
2371       P   : constant Node_Id    := Prefix (N);
2372       T   : constant Entity_Id  := Etype (P);
2373
2374    begin
2375       --  A special optimization, if we have an indexed component that
2376       --  is selecting from a slice, then we can eliminate the slice,
2377       --  since, for example, x (i .. j)(k) is identical to x(k). The
2378       --  only difference is the range check required by the slice. The
2379       --  range check for the slice itself has already been generated.
2380       --  The range check for the subscripting operation is ensured
2381       --  by converting the subject to the subtype of the slice.
2382
2383       --  This optimization not only generates better code, avoiding
2384       --  slice messing especially in the packed case, but more importantly
2385       --  bypasses some problems in handling this peculiar case, for
2386       --  example, the issue of dealing specially with object renamings.
2387
2388       if Nkind (P) = N_Slice then
2389          Rewrite (N,
2390            Make_Indexed_Component (Loc,
2391              Prefix => Prefix (P),
2392              Expressions => New_List (
2393                Convert_To
2394                  (Etype (First_Index (Etype (P))),
2395                   First (Expressions (N))))));
2396          Analyze_And_Resolve (N, Typ);
2397          return;
2398       end if;
2399
2400       --  If the prefix is an access type, then we unconditionally rewrite
2401       --  if as an explicit deference. This simplifies processing for several
2402       --  cases, including packed array cases and certain cases in which
2403       --  checks must be generated. We used to try to do this only when it
2404       --  was necessary, but it cleans up the code to do it all the time.
2405
2406       if Is_Access_Type (T) then
2407          Rewrite (P,
2408            Make_Explicit_Dereference (Sloc (N),
2409              Prefix => Relocate_Node (P)));
2410          Analyze_And_Resolve (P, Designated_Type (T));
2411       end if;
2412
2413       if Validity_Checks_On and then Validity_Check_Subscripts then
2414          Apply_Subscript_Validity_Checks (N);
2415       end if;
2416
2417       --  All done for the non-packed case
2418
2419       if not Is_Packed (Etype (Prefix (N))) then
2420          return;
2421       end if;
2422
2423       --  For packed arrays that are not bit-packed (i.e. the case of an array
2424       --  with one or more index types with a non-coniguous enumeration type),
2425       --  we can always use the normal packed element get circuit.
2426
2427       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
2428          Expand_Packed_Element_Reference (N);
2429          return;
2430       end if;
2431
2432       --  For a reference to a component of a bit packed array, we have to
2433       --  convert it to a reference to the corresponding Packed_Array_Type.
2434       --  We only want to do this for simple references, and not for:
2435
2436       --    Left side of assignment (or prefix of left side of assignment)
2437       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
2438
2439       --    Renaming objects in renaming associations
2440       --      This case is handled when a use of the renamed variable occurs
2441
2442       --    Actual parameters for a procedure call
2443       --      This case is handled in Exp_Ch6.Expand_Actuals
2444
2445       --    The second expression in a 'Read attribute reference
2446
2447       --    The prefix of an address or size attribute reference
2448
2449       --  The following circuit detects these exceptions
2450
2451       declare
2452          Child : Node_Id := N;
2453          Parnt : Node_Id := Parent (N);
2454
2455       begin
2456          loop
2457             if Nkind (Parnt) = N_Unchecked_Expression then
2458                null;
2459
2460             elsif Nkind (Parnt) = N_Object_Renaming_Declaration
2461               or else Nkind (Parnt) = N_Procedure_Call_Statement
2462               or else (Nkind (Parnt) = N_Parameter_Association
2463                         and then
2464                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
2465             then
2466                return;
2467
2468             elsif Nkind (Parnt) = N_Attribute_Reference
2469               and then (Attribute_Name (Parnt) = Name_Address
2470                          or else
2471                         Attribute_Name (Parnt) = Name_Size)
2472               and then Prefix (Parnt) = Child
2473             then
2474                return;
2475
2476             elsif Nkind (Parnt) = N_Assignment_Statement
2477               and then Name (Parnt) = Child
2478             then
2479                return;
2480
2481             elsif Nkind (Parnt) = N_Attribute_Reference
2482               and then Attribute_Name (Parnt) = Name_Read
2483               and then Next (First (Expressions (Parnt))) = Child
2484             then
2485                return;
2486
2487             elsif (Nkind (Parnt) = N_Indexed_Component
2488                     or else Nkind (Parnt) = N_Selected_Component)
2489                and then Prefix (Parnt) = Child
2490             then
2491                null;
2492
2493             else
2494                Expand_Packed_Element_Reference (N);
2495                return;
2496             end if;
2497
2498             --  Keep looking up tree for unchecked expression, or if we are
2499             --  the prefix of a possible assignment left side.
2500
2501             Child := Parnt;
2502             Parnt := Parent (Child);
2503          end loop;
2504       end;
2505
2506    end Expand_N_Indexed_Component;
2507
2508    ---------------------
2509    -- Expand_N_Not_In --
2510    ---------------------
2511
2512    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
2513    --  can be done. This avoids needing to duplicate this expansion code.
2514
2515    procedure Expand_N_Not_In (N : Node_Id) is
2516       Loc  : constant Source_Ptr := Sloc (N);
2517       Typ  : constant Entity_Id  := Etype (N);
2518
2519    begin
2520       Rewrite (N,
2521         Make_Op_Not (Loc,
2522           Right_Opnd =>
2523             Make_In (Loc,
2524               Left_Opnd  => Left_Opnd (N),
2525               Right_Opnd => Right_Opnd (N))));
2526       Analyze_And_Resolve (N, Typ);
2527    end Expand_N_Not_In;
2528
2529    -------------------
2530    -- Expand_N_Null --
2531    -------------------
2532
2533    --  The only replacement required is for the case of a null of type
2534    --  that is an access to protected subprogram. We represent such
2535    --  access values as a record, and so we must replace the occurrence
2536    --  of null by the equivalent record (with a null address and a null
2537    --  pointer in it), so that the backend creates the proper value.
2538
2539    procedure Expand_N_Null (N : Node_Id) is
2540       Loc : constant Source_Ptr := Sloc (N);
2541       Typ : constant Entity_Id  := Etype (N);
2542       Agg : Node_Id;
2543
2544    begin
2545       if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
2546          Agg :=
2547            Make_Aggregate (Loc,
2548              Expressions => New_List (
2549                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
2550                Make_Null (Loc)));
2551
2552          Rewrite (N, Agg);
2553          Analyze_And_Resolve (N, Equivalent_Type (Typ));
2554
2555          --  For subsequent semantic analysis, the node must retain its
2556          --  type. Gigi in any case replaces this type by the corresponding
2557          --  record type before processing the node.
2558
2559          Set_Etype (N, Typ);
2560       end if;
2561    end Expand_N_Null;
2562
2563    ---------------------
2564    -- Expand_N_Op_Abs --
2565    ---------------------
2566
2567    procedure Expand_N_Op_Abs (N : Node_Id) is
2568       Loc  : constant Source_Ptr := Sloc (N);
2569       Expr : constant Node_Id := Right_Opnd (N);
2570
2571    begin
2572       Unary_Op_Validity_Checks (N);
2573
2574       --  Deal with software overflow checking
2575
2576       if not Backend_Overflow_Checks_On_Target
2577          and then Is_Signed_Integer_Type (Etype (N))
2578          and then Do_Overflow_Check (N)
2579       then
2580          --  Software overflow checking expands abs (expr) into
2581
2582          --    (if expr >= 0 then expr else -expr)
2583
2584          --  with the usual Duplicate_Subexpr use coding for expr
2585
2586          Rewrite (N,
2587            Make_Conditional_Expression (Loc,
2588              Expressions => New_List (
2589                Make_Op_Ge (Loc,
2590                  Left_Opnd  => Duplicate_Subexpr (Expr),
2591                  Right_Opnd => Make_Integer_Literal (Loc, 0)),
2592
2593                Duplicate_Subexpr (Expr),
2594
2595                Make_Op_Minus (Loc,
2596                  Right_Opnd  => Duplicate_Subexpr (Expr)))));
2597
2598          Analyze_And_Resolve (N);
2599
2600       --  Vax floating-point types case
2601
2602       elsif Vax_Float (Etype (N)) then
2603          Expand_Vax_Arith (N);
2604       end if;
2605    end Expand_N_Op_Abs;
2606
2607    ---------------------
2608    -- Expand_N_Op_Add --
2609    ---------------------
2610
2611    procedure Expand_N_Op_Add (N : Node_Id) is
2612       Typ : constant Entity_Id := Etype (N);
2613
2614    begin
2615       Binary_Op_Validity_Checks (N);
2616
2617       --  N + 0 = 0 + N = N for integer types
2618
2619       if Is_Integer_Type (Typ) then
2620          if Compile_Time_Known_Value (Right_Opnd (N))
2621            and then Expr_Value (Right_Opnd (N)) = Uint_0
2622          then
2623             Rewrite (N, Left_Opnd (N));
2624             return;
2625
2626          elsif Compile_Time_Known_Value (Left_Opnd (N))
2627            and then Expr_Value (Left_Opnd (N)) = Uint_0
2628          then
2629             Rewrite (N, Right_Opnd (N));
2630             return;
2631          end if;
2632       end if;
2633
2634       --  Arithemtic overflow checks for signed integer/fixed point types
2635
2636       if Is_Signed_Integer_Type (Typ)
2637         or else Is_Fixed_Point_Type (Typ)
2638       then
2639          Apply_Arithmetic_Overflow_Check (N);
2640          return;
2641
2642       --  Vax floating-point types case
2643
2644       elsif Vax_Float (Typ) then
2645          Expand_Vax_Arith (N);
2646       end if;
2647    end Expand_N_Op_Add;
2648
2649    ---------------------
2650    -- Expand_N_Op_And --
2651    ---------------------
2652
2653    procedure Expand_N_Op_And (N : Node_Id) is
2654       Typ : constant Entity_Id := Etype (N);
2655
2656    begin
2657       Binary_Op_Validity_Checks (N);
2658
2659       if Is_Array_Type (Etype (N)) then
2660          Expand_Boolean_Operator (N);
2661
2662       elsif Is_Boolean_Type (Etype (N)) then
2663          Adjust_Condition (Left_Opnd (N));
2664          Adjust_Condition (Right_Opnd (N));
2665          Set_Etype (N, Standard_Boolean);
2666          Adjust_Result_Type (N, Typ);
2667       end if;
2668    end Expand_N_Op_And;
2669
2670    ------------------------
2671    -- Expand_N_Op_Concat --
2672    ------------------------
2673
2674    procedure Expand_N_Op_Concat (N : Node_Id) is
2675
2676       Opnds : List_Id;
2677       --  List of operands to be concatenated
2678
2679       Opnd  : Node_Id;
2680       --  Single operand for concatenation
2681
2682       Cnode : Node_Id;
2683       --  Node which is to be replaced by the result of concatenating
2684       --  the nodes in the list Opnds.
2685
2686       Atyp : Entity_Id;
2687       --  Array type of concatenation result type
2688
2689       Ctyp : Entity_Id;
2690       --  Component type of concatenation represented by Cnode
2691
2692    begin
2693       Binary_Op_Validity_Checks (N);
2694
2695       --  If we are the left operand of a concatenation higher up the
2696       --  tree, then do nothing for now, since we want to deal with a
2697       --  series of concatenations as a unit.
2698
2699       if Nkind (Parent (N)) = N_Op_Concat
2700         and then N = Left_Opnd (Parent (N))
2701       then
2702          return;
2703       end if;
2704
2705       --  We get here with a concatenation whose left operand may be a
2706       --  concatenation itself with a consistent type. We need to process
2707       --  these concatenation operands from left to right, which means
2708       --  from the deepest node in the tree to the highest node.
2709
2710       Cnode := N;
2711       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
2712          Cnode := Left_Opnd (Cnode);
2713       end loop;
2714
2715       --  Now Opnd is the deepest Opnd, and its parents are the concatenation
2716       --  nodes above, so now we process bottom up, doing the operations. We
2717       --  gather a string that is as long as possible up to five operands
2718
2719       --  The outer loop runs more than once if there are more than five
2720       --  concatenations of type Standard.String, the most we handle for
2721       --  this case, or if more than one concatenation type is involved.
2722
2723       Outer : loop
2724          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
2725          Set_Parent (Opnds, N);
2726
2727          --  The inner loop gathers concatenation operands
2728
2729          Inner : while Cnode /= N
2730                    and then (Base_Type (Etype (Cnode)) /= Standard_String
2731                                or else
2732                              List_Length (Opnds) < 5)
2733                    and then Base_Type (Etype (Cnode)) =
2734                             Base_Type (Etype (Parent (Cnode)))
2735          loop
2736             Cnode := Parent (Cnode);
2737             Append (Right_Opnd (Cnode), Opnds);
2738          end loop Inner;
2739
2740          --  Here we process the collected operands. First we convert
2741          --  singleton operands to singleton aggregates. This is skipped
2742          --  however for the case of two operands of type String, since
2743          --  we have special routines for these cases.
2744
2745          Atyp := Base_Type (Etype (Cnode));
2746          Ctyp := Base_Type (Component_Type (Etype (Cnode)));
2747
2748          if List_Length (Opnds) > 2 or else Atyp /= Standard_String then
2749             Opnd := First (Opnds);
2750             loop
2751                if Base_Type (Etype (Opnd)) = Ctyp then
2752                   Rewrite (Opnd,
2753                     Make_Aggregate (Sloc (Cnode),
2754                       Expressions => New_List (Relocate_Node (Opnd))));
2755                   Analyze_And_Resolve (Opnd, Atyp);
2756                end if;
2757
2758                Next (Opnd);
2759                exit when No (Opnd);
2760             end loop;
2761          end if;
2762
2763          --  Now call appropriate continuation routine
2764
2765          if Atyp = Standard_String then
2766             Expand_Concatenate_String (Cnode, Opnds);
2767          else
2768             Expand_Concatenate_Other (Cnode, Opnds);
2769          end if;
2770
2771          exit Outer when Cnode = N;
2772          Cnode := Parent (Cnode);
2773       end loop Outer;
2774    end Expand_N_Op_Concat;
2775
2776    ------------------------
2777    -- Expand_N_Op_Divide --
2778    ------------------------
2779
2780    procedure Expand_N_Op_Divide (N : Node_Id) is
2781       Loc  : constant Source_Ptr := Sloc (N);
2782       Ltyp : constant Entity_Id  := Etype (Left_Opnd (N));
2783       Rtyp : constant Entity_Id  := Etype (Right_Opnd (N));
2784       Typ  : Entity_Id           := Etype (N);
2785
2786    begin
2787       Binary_Op_Validity_Checks (N);
2788
2789       --  Vax_Float is a special case
2790
2791       if Vax_Float (Typ) then
2792          Expand_Vax_Arith (N);
2793          return;
2794       end if;
2795
2796       --  N / 1 = N for integer types
2797
2798       if Is_Integer_Type (Typ)
2799         and then Compile_Time_Known_Value (Right_Opnd (N))
2800         and then Expr_Value (Right_Opnd (N)) = Uint_1
2801       then
2802          Rewrite (N, Left_Opnd (N));
2803          return;
2804       end if;
2805
2806       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
2807       --  Is_Power_Of_2_For_Shift is set means that we know that our left
2808       --  operand is an unsigned integer, as required for this to work.
2809
2810       if Nkind (Right_Opnd (N)) = N_Op_Expon
2811         and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
2812       then
2813          Rewrite (N,
2814            Make_Op_Shift_Right (Loc,
2815              Left_Opnd  => Left_Opnd (N),
2816              Right_Opnd =>
2817                Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
2818          Analyze_And_Resolve (N, Typ);
2819          return;
2820       end if;
2821
2822       --  Do required fixup of universal fixed operation
2823
2824       if Typ = Universal_Fixed then
2825          Fixup_Universal_Fixed_Operation (N);
2826          Typ := Etype (N);
2827       end if;
2828
2829       --  Divisions with fixed-point results
2830
2831       if Is_Fixed_Point_Type (Typ) then
2832
2833          --  No special processing if Treat_Fixed_As_Integer is set,
2834          --  since from a semantic point of view such operations are
2835          --  simply integer operations and will be treated that way.
2836
2837          if not Treat_Fixed_As_Integer (N) then
2838             if Is_Integer_Type (Rtyp) then
2839                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
2840             else
2841                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
2842             end if;
2843          end if;
2844
2845       --  Other cases of division of fixed-point operands. Again we
2846       --  exclude the case where Treat_Fixed_As_Integer is set.
2847
2848       elsif (Is_Fixed_Point_Type (Ltyp) or else
2849              Is_Fixed_Point_Type (Rtyp))
2850         and then not Treat_Fixed_As_Integer (N)
2851       then
2852          if Is_Integer_Type (Typ) then
2853             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
2854          else
2855             pragma Assert (Is_Floating_Point_Type (Typ));
2856             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
2857          end if;
2858
2859       --  Mixed-mode operations can appear in a non-static universal
2860       --  context, in  which case the integer argument must be converted
2861       --  explicitly.
2862
2863       elsif Typ = Universal_Real
2864         and then Is_Integer_Type (Rtyp)
2865       then
2866          Rewrite (Right_Opnd (N),
2867            Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
2868
2869          Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
2870
2871       elsif Typ = Universal_Real
2872         and then Is_Integer_Type (Ltyp)
2873       then
2874          Rewrite (Left_Opnd (N),
2875            Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
2876
2877          Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
2878
2879       --  Non-fixed point cases, do zero divide and overflow checks
2880
2881       elsif Is_Integer_Type (Typ) then
2882          Apply_Divide_Check (N);
2883       end if;
2884    end Expand_N_Op_Divide;
2885
2886    --------------------
2887    -- Expand_N_Op_Eq --
2888    --------------------
2889
2890    procedure Expand_N_Op_Eq (N : Node_Id) is
2891       Loc     : constant Source_Ptr := Sloc (N);
2892       Typ     : constant Entity_Id  := Etype (N);
2893       Lhs     : constant Node_Id    := Left_Opnd (N);
2894       Rhs     : constant Node_Id    := Right_Opnd (N);
2895       A_Typ   : Entity_Id           := Etype (Lhs);
2896       Typl    : Entity_Id := A_Typ;
2897       Op_Name : Entity_Id;
2898       Prim    : Elmt_Id;
2899       Bodies  : List_Id := New_List;
2900
2901       procedure Build_Equality_Call (Eq : Entity_Id);
2902       --  If a constructed equality exists for the type or for its parent,
2903       --  build and analyze call, adding conversions if the operation is
2904       --  inherited.
2905
2906       -------------------------
2907       -- Build_Equality_Call --
2908       -------------------------
2909
2910       procedure Build_Equality_Call (Eq : Entity_Id) is
2911          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
2912          L_Exp   : Node_Id := Relocate_Node (Lhs);
2913          R_Exp   : Node_Id := Relocate_Node (Rhs);
2914
2915       begin
2916          if Base_Type (Op_Type) /= Base_Type (A_Typ)
2917            and then not Is_Class_Wide_Type (A_Typ)
2918          then
2919             L_Exp := OK_Convert_To (Op_Type, L_Exp);
2920             R_Exp := OK_Convert_To (Op_Type, R_Exp);
2921          end if;
2922
2923          Rewrite (N,
2924            Make_Function_Call (Loc,
2925              Name => New_Reference_To (Eq, Loc),
2926              Parameter_Associations => New_List (L_Exp, R_Exp)));
2927
2928          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
2929       end Build_Equality_Call;
2930
2931    --  Start of processing for Expand_N_Op_Eq
2932
2933    begin
2934       Binary_Op_Validity_Checks (N);
2935
2936       if Ekind (Typl) = E_Private_Type then
2937          Typl := Underlying_Type (Typl);
2938
2939       elsif Ekind (Typl) = E_Private_Subtype then
2940          Typl := Underlying_Type (Base_Type (Typl));
2941       end if;
2942
2943       --  It may happen in error situations that the underlying type is not
2944       --  set. The error will be detected later, here we just defend the
2945       --  expander code.
2946
2947       if No (Typl) then
2948          return;
2949       end if;
2950
2951       Typl := Base_Type (Typl);
2952
2953       --  Vax float types
2954
2955       if Vax_Float (Typl) then
2956          Expand_Vax_Comparison (N);
2957          return;
2958
2959       --  Boolean types (requiring handling of non-standard case)
2960
2961       elsif Is_Boolean_Type (Typl) then
2962          Adjust_Condition (Left_Opnd (N));
2963          Adjust_Condition (Right_Opnd (N));
2964          Set_Etype (N, Standard_Boolean);
2965          Adjust_Result_Type (N, Typ);
2966
2967       --  Array types
2968
2969       elsif Is_Array_Type (Typl) then
2970
2971          --  Packed case
2972
2973          if Is_Bit_Packed_Array (Typl) then
2974             Expand_Packed_Eq (N);
2975
2976          --  For non-floating-point elementary types, the primitive equality
2977          --  always applies, and block-bit comparison is fine. Floating-point
2978          --  is an exception because of negative zeroes.
2979
2980          --  However, we never use block bit comparison in No_Run_Time mode,
2981          --  since this may result in a call to a run time routine
2982
2983          elsif Is_Elementary_Type (Component_Type (Typl))
2984            and then not Is_Floating_Point_Type (Component_Type (Typl))
2985            and then not No_Run_Time
2986          then
2987             null;
2988
2989          --  For composite and floating-point cases, expand equality loop
2990          --  to make sure of using proper comparisons for tagged types,
2991          --  and correctly handling the floating-point case.
2992
2993          else
2994             Rewrite (N,
2995               Expand_Array_Equality (N, Typl, A_Typ,
2996                 Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
2997
2998             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
2999             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3000          end if;
3001
3002       --  Record Types
3003
3004       elsif Is_Record_Type (Typl) then
3005
3006          --  For tagged types, use the primitive "="
3007
3008          if Is_Tagged_Type (Typl) then
3009
3010             --  If this is derived from an untagged private type completed
3011             --  with a tagged type, it does not have a full view, so we
3012             --  use the primitive operations of the private type.
3013             --  This check should no longer be necessary when these
3014             --  types receive their full views ???
3015
3016             if Is_Private_Type (A_Typ)
3017               and then not Is_Tagged_Type (A_Typ)
3018               and then Is_Derived_Type (A_Typ)
3019               and then No (Full_View (A_Typ))
3020             then
3021                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
3022
3023                while Chars (Node (Prim)) /= Name_Op_Eq loop
3024                   Next_Elmt (Prim);
3025                   pragma Assert (Present (Prim));
3026                end loop;
3027
3028                Op_Name := Node (Prim);
3029             else
3030                Op_Name := Find_Prim_Op (Typl, Name_Op_Eq);
3031             end if;
3032
3033             Build_Equality_Call (Op_Name);
3034
3035          --  If a type support function is present (for complex cases), use it
3036
3037          elsif Present (TSS (Root_Type (Typl), Name_uEquality)) then
3038             Build_Equality_Call (TSS (Root_Type (Typl), Name_uEquality));
3039
3040          --  Otherwise expand the component by component equality. Note that
3041          --  we never use block-bit coparisons for records, because of the
3042          --  problems with gaps. The backend will often be able to recombine
3043          --  the separate comparisons that we generate here.
3044
3045          else
3046             Remove_Side_Effects (Lhs);
3047             Remove_Side_Effects (Rhs);
3048             Rewrite (N,
3049               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
3050
3051             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
3052             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
3053          end if;
3054       end if;
3055
3056       --  If we still have an equality comparison (i.e. it was not rewritten
3057       --  in some way), then we can test if result is needed at compile time).
3058
3059       if Nkind (N) = N_Op_Eq then
3060          Rewrite_Comparison (N);
3061       end if;
3062    end Expand_N_Op_Eq;
3063
3064    -----------------------
3065    -- Expand_N_Op_Expon --
3066    -----------------------
3067
3068    procedure Expand_N_Op_Expon (N : Node_Id) is
3069       Loc    : constant Source_Ptr := Sloc (N);
3070       Typ    : constant Entity_Id  := Etype (N);
3071       Rtyp   : constant Entity_Id  := Root_Type (Typ);
3072       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
3073       Bastyp : constant Node_Id    := Etype (Base);
3074       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
3075       Exptyp : constant Entity_Id  := Etype (Exp);
3076       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
3077       Expv   : Uint;
3078       Xnode  : Node_Id;
3079       Temp   : Node_Id;
3080       Rent   : RE_Id;
3081       Ent    : Entity_Id;
3082
3083    begin
3084       Binary_Op_Validity_Checks (N);
3085
3086       --  If either operand is of a private type, then we have the use of
3087       --  an intrinsic operator, and we get rid of the privateness, by using
3088       --  root types of underlying types for the actual operation. Otherwise
3089       --  the private types will cause trouble if we expand multiplications
3090       --  or shifts etc. We also do this transformation if the result type
3091       --  is different from the base type.
3092
3093       if Is_Private_Type (Etype (Base))
3094            or else
3095          Is_Private_Type (Typ)
3096            or else
3097          Is_Private_Type (Exptyp)
3098            or else
3099          Rtyp /= Root_Type (Bastyp)
3100       then
3101          declare
3102             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
3103             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
3104
3105          begin
3106             Rewrite (N,
3107               Unchecked_Convert_To (Typ,
3108                 Make_Op_Expon (Loc,
3109                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
3110                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
3111             Analyze_And_Resolve (N, Typ);
3112             return;
3113          end;
3114       end if;
3115
3116       --  At this point the exponentiation must be dynamic since the static
3117       --  case has already been folded after Resolve by Eval_Op_Expon.
3118
3119       --  Test for case of literal right argument
3120
3121       if Compile_Time_Known_Value (Exp) then
3122          Expv := Expr_Value (Exp);
3123
3124          --  We only fold small non-negative exponents. You might think we
3125          --  could fold small negative exponents for the real case, but we
3126          --  can't because we are required to raise Constraint_Error for
3127          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
3128          --  See ACVC test C4A012B.
3129
3130          if Expv >= 0 and then Expv <= 4 then
3131
3132             --  X ** 0 = 1 (or 1.0)
3133
3134             if Expv = 0 then
3135                if Ekind (Typ) in Integer_Kind then
3136                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
3137                else
3138                   Xnode := Make_Real_Literal (Loc, Ureal_1);
3139                end if;
3140
3141             --  X ** 1 = X
3142
3143             elsif Expv = 1 then
3144                Xnode := Base;
3145
3146             --  X ** 2 = X * X
3147
3148             elsif Expv = 2 then
3149                Xnode :=
3150                  Make_Op_Multiply (Loc,
3151                    Left_Opnd  => Duplicate_Subexpr (Base),
3152                    Right_Opnd => Duplicate_Subexpr (Base));
3153
3154             --  X ** 3 = X * X * X
3155
3156             elsif Expv = 3 then
3157                Xnode :=
3158                  Make_Op_Multiply (Loc,
3159                    Left_Opnd =>
3160                      Make_Op_Multiply (Loc,
3161                        Left_Opnd  => Duplicate_Subexpr (Base),
3162                        Right_Opnd => Duplicate_Subexpr (Base)),
3163                    Right_Opnd  => Duplicate_Subexpr (Base));
3164
3165             --  X ** 4  ->
3166             --    En : constant base'type := base * base;
3167             --    ...
3168             --    En * En
3169
3170             else -- Expv = 4
3171                Temp :=
3172                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3173
3174                Insert_Actions (N, New_List (
3175                  Make_Object_Declaration (Loc,
3176                    Defining_Identifier => Temp,
3177                    Constant_Present    => True,
3178                    Object_Definition   => New_Reference_To (Typ, Loc),
3179                    Expression =>
3180                      Make_Op_Multiply (Loc,
3181                        Left_Opnd  => Duplicate_Subexpr (Base),
3182                        Right_Opnd => Duplicate_Subexpr (Base)))));
3183
3184                Xnode :=
3185                  Make_Op_Multiply (Loc,
3186                    Left_Opnd  => New_Reference_To (Temp, Loc),
3187                    Right_Opnd => New_Reference_To (Temp, Loc));
3188             end if;
3189
3190             Rewrite (N, Xnode);
3191             Analyze_And_Resolve (N, Typ);
3192             return;
3193          end if;
3194       end if;
3195
3196       --  Case of (2 ** expression) appearing as an argument of an integer
3197       --  multiplication, or as the right argument of a division of a non-
3198       --  negative integer. In such cases we lave the node untouched, setting
3199       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
3200       --  of the higher level node converts it into a shift.
3201
3202       if Nkind (Base) = N_Integer_Literal
3203         and then Intval (Base) = 2
3204         and then Is_Integer_Type (Root_Type (Exptyp))
3205         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
3206         and then Is_Unsigned_Type (Exptyp)
3207         and then not Ovflo
3208         and then Nkind (Parent (N)) in N_Binary_Op
3209       then
3210          declare
3211             P : constant Node_Id := Parent (N);
3212             L : constant Node_Id := Left_Opnd (P);
3213             R : constant Node_Id := Right_Opnd (P);
3214
3215          begin
3216             if (Nkind (P) = N_Op_Multiply
3217                  and then
3218                    ((Is_Integer_Type (Etype (L)) and then R = N)
3219                        or else
3220                     (Is_Integer_Type (Etype (R)) and then L = N))
3221                  and then not Do_Overflow_Check (P))
3222
3223               or else
3224                 (Nkind (P) = N_Op_Divide
3225                   and then Is_Integer_Type (Etype (L))
3226                   and then Is_Unsigned_Type (Etype (L))
3227                   and then R = N
3228                   and then not Do_Overflow_Check (P))
3229             then
3230                Set_Is_Power_Of_2_For_Shift (N);
3231                return;
3232             end if;
3233          end;
3234       end if;
3235
3236       --  Fall through if exponentiation must be done using a runtime routine
3237
3238       if No_Run_Time then
3239          Disallow_In_No_Run_Time_Mode (N);
3240          return;
3241       end if;
3242
3243       --  First deal with modular case
3244
3245       if Is_Modular_Integer_Type (Rtyp) then
3246
3247          --  Non-binary case, we call the special exponentiation routine for
3248          --  the non-binary case, converting the argument to Long_Long_Integer
3249          --  and passing the modulus value. Then the result is converted back
3250          --  to the base type.
3251
3252          if Non_Binary_Modulus (Rtyp) then
3253
3254             Rewrite (N,
3255               Convert_To (Typ,
3256                 Make_Function_Call (Loc,
3257                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
3258                   Parameter_Associations => New_List (
3259                     Convert_To (Standard_Integer, Base),
3260                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
3261                     Exp))));
3262
3263          --  Binary case, in this case, we call one of two routines, either
3264          --  the unsigned integer case, or the unsigned long long integer
3265          --  case, with a final "and" operation to do the required mod.
3266
3267          else
3268             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
3269                Ent := RTE (RE_Exp_Unsigned);
3270             else
3271                Ent := RTE (RE_Exp_Long_Long_Unsigned);
3272             end if;
3273
3274             Rewrite (N,
3275               Convert_To (Typ,
3276                 Make_Op_And (Loc,
3277                   Left_Opnd =>
3278                     Make_Function_Call (Loc,
3279                       Name => New_Reference_To (Ent, Loc),
3280                       Parameter_Associations => New_List (
3281                         Convert_To (Etype (First_Formal (Ent)), Base),
3282                         Exp)),
3283                    Right_Opnd =>
3284                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
3285
3286          end if;
3287
3288          --  Common exit point for modular type case
3289
3290          Analyze_And_Resolve (N, Typ);
3291          return;
3292
3293       --  Signed integer cases
3294
3295       elsif Rtyp = Base_Type (Standard_Integer) then
3296          if Ovflo then
3297             Rent := RE_Exp_Integer;
3298          else
3299             Rent := RE_Exn_Integer;
3300          end if;
3301
3302       elsif Rtyp = Base_Type (Standard_Short_Integer) then
3303          if Ovflo then
3304             Rent := RE_Exp_Short_Integer;
3305          else
3306             Rent := RE_Exn_Short_Integer;
3307          end if;
3308
3309       elsif Rtyp = Base_Type (Standard_Short_Short_Integer) then
3310          if Ovflo then
3311             Rent := RE_Exp_Short_Short_Integer;
3312          else
3313             Rent := RE_Exn_Short_Short_Integer;
3314          end if;
3315
3316       elsif Rtyp = Base_Type (Standard_Long_Integer) then
3317          if Ovflo then
3318             Rent := RE_Exp_Long_Integer;
3319          else
3320             Rent := RE_Exn_Long_Integer;
3321          end if;
3322
3323       elsif (Rtyp = Base_Type (Standard_Long_Long_Integer)
3324         or else Rtyp = Universal_Integer)
3325       then
3326          if Ovflo then
3327             Rent := RE_Exp_Long_Long_Integer;
3328          else
3329             Rent := RE_Exn_Long_Long_Integer;
3330          end if;
3331
3332       --  Floating-point cases
3333
3334       elsif Rtyp = Standard_Float then
3335          if Ovflo then
3336             Rent := RE_Exp_Float;
3337          else
3338             Rent := RE_Exn_Float;
3339          end if;
3340
3341       elsif Rtyp = Standard_Short_Float then
3342          if Ovflo then
3343             Rent := RE_Exp_Short_Float;
3344          else
3345             Rent := RE_Exn_Short_Float;
3346          end if;
3347
3348       elsif Rtyp = Standard_Long_Float then
3349          if Ovflo then
3350             Rent := RE_Exp_Long_Float;
3351          else
3352             Rent := RE_Exn_Long_Float;
3353          end if;
3354
3355       else
3356          pragma Assert
3357            (Rtyp = Standard_Long_Long_Float or else Rtyp = Universal_Real);
3358
3359          if Ovflo then
3360             Rent := RE_Exp_Long_Long_Float;
3361          else
3362             Rent := RE_Exn_Long_Long_Float;
3363          end if;
3364       end if;
3365
3366       --  Common processing for integer cases and floating-point cases.
3367       --  If we are in the base type, we can call runtime routine directly
3368
3369       if Typ = Rtyp
3370         and then Rtyp /= Universal_Integer
3371         and then Rtyp /= Universal_Real
3372       then
3373          Rewrite (N,
3374            Make_Function_Call (Loc,
3375              Name => New_Reference_To (RTE (Rent), Loc),
3376              Parameter_Associations => New_List (Base, Exp)));
3377
3378       --  Otherwise we have to introduce conversions (conversions are also
3379       --  required in the universal cases, since the runtime routine was
3380       --  typed using the largest integer or real case.
3381
3382       else
3383          Rewrite (N,
3384            Convert_To (Typ,
3385              Make_Function_Call (Loc,
3386                Name => New_Reference_To (RTE (Rent), Loc),
3387                Parameter_Associations => New_List (
3388                  Convert_To (Rtyp, Base),
3389                  Exp))));
3390       end if;
3391
3392       Analyze_And_Resolve (N, Typ);
3393       return;
3394
3395    end Expand_N_Op_Expon;
3396
3397    --------------------
3398    -- Expand_N_Op_Ge --
3399    --------------------
3400
3401    procedure Expand_N_Op_Ge (N : Node_Id) is
3402       Typ  : constant Entity_Id := Etype (N);
3403       Op1  : constant Node_Id   := Left_Opnd (N);
3404       Op2  : constant Node_Id   := Right_Opnd (N);
3405       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3406
3407    begin
3408       Binary_Op_Validity_Checks (N);
3409
3410       if Vax_Float (Typ1) then
3411          Expand_Vax_Comparison (N);
3412          return;
3413
3414       elsif Is_Array_Type (Typ1) then
3415          Expand_Array_Comparison (N);
3416          return;
3417       end if;
3418
3419       if Is_Boolean_Type (Typ1) then
3420          Adjust_Condition (Op1);
3421          Adjust_Condition (Op2);
3422          Set_Etype (N, Standard_Boolean);
3423          Adjust_Result_Type (N, Typ);
3424       end if;
3425
3426       Rewrite_Comparison (N);
3427    end Expand_N_Op_Ge;
3428
3429    --------------------
3430    -- Expand_N_Op_Gt --
3431    --------------------
3432
3433    procedure Expand_N_Op_Gt (N : Node_Id) is
3434       Typ  : constant Entity_Id := Etype (N);
3435       Op1  : constant Node_Id   := Left_Opnd (N);
3436       Op2  : constant Node_Id   := Right_Opnd (N);
3437       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3438
3439    begin
3440       Binary_Op_Validity_Checks (N);
3441
3442       if Vax_Float (Typ1) then
3443          Expand_Vax_Comparison (N);
3444          return;
3445
3446       elsif Is_Array_Type (Typ1) then
3447          Expand_Array_Comparison (N);
3448          return;
3449       end if;
3450
3451       if Is_Boolean_Type (Typ1) then
3452          Adjust_Condition (Op1);
3453          Adjust_Condition (Op2);
3454          Set_Etype (N, Standard_Boolean);
3455          Adjust_Result_Type (N, Typ);
3456       end if;
3457
3458       Rewrite_Comparison (N);
3459    end Expand_N_Op_Gt;
3460
3461    --------------------
3462    -- Expand_N_Op_Le --
3463    --------------------
3464
3465    procedure Expand_N_Op_Le (N : Node_Id) is
3466       Typ  : constant Entity_Id := Etype (N);
3467       Op1  : constant Node_Id   := Left_Opnd (N);
3468       Op2  : constant Node_Id   := Right_Opnd (N);
3469       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3470
3471    begin
3472       Binary_Op_Validity_Checks (N);
3473
3474       if Vax_Float (Typ1) then
3475          Expand_Vax_Comparison (N);
3476          return;
3477
3478       elsif Is_Array_Type (Typ1) then
3479          Expand_Array_Comparison (N);
3480          return;
3481       end if;
3482
3483       if Is_Boolean_Type (Typ1) then
3484          Adjust_Condition (Op1);
3485          Adjust_Condition (Op2);
3486          Set_Etype (N, Standard_Boolean);
3487          Adjust_Result_Type (N, Typ);
3488       end if;
3489
3490       Rewrite_Comparison (N);
3491    end Expand_N_Op_Le;
3492
3493    --------------------
3494    -- Expand_N_Op_Lt --
3495    --------------------
3496
3497    procedure Expand_N_Op_Lt (N : Node_Id) is
3498       Typ  : constant Entity_Id := Etype (N);
3499       Op1  : constant Node_Id   := Left_Opnd (N);
3500       Op2  : constant Node_Id   := Right_Opnd (N);
3501       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3502
3503    begin
3504       Binary_Op_Validity_Checks (N);
3505
3506       if Vax_Float (Typ1) then
3507          Expand_Vax_Comparison (N);
3508          return;
3509
3510       elsif Is_Array_Type (Typ1) then
3511          Expand_Array_Comparison (N);
3512          return;
3513       end if;
3514
3515       if Is_Boolean_Type (Typ1) then
3516          Adjust_Condition (Op1);
3517          Adjust_Condition (Op2);
3518          Set_Etype (N, Standard_Boolean);
3519          Adjust_Result_Type (N, Typ);
3520       end if;
3521
3522       Rewrite_Comparison (N);
3523    end Expand_N_Op_Lt;
3524
3525    -----------------------
3526    -- Expand_N_Op_Minus --
3527    -----------------------
3528
3529    procedure Expand_N_Op_Minus (N : Node_Id) is
3530       Loc : constant Source_Ptr := Sloc (N);
3531       Typ : constant Entity_Id  := Etype (N);
3532
3533    begin
3534       Unary_Op_Validity_Checks (N);
3535
3536       if not Backend_Overflow_Checks_On_Target
3537          and then Is_Signed_Integer_Type (Etype (N))
3538          and then Do_Overflow_Check (N)
3539       then
3540          --  Software overflow checking expands -expr into (0 - expr)
3541
3542          Rewrite (N,
3543            Make_Op_Subtract (Loc,
3544              Left_Opnd  => Make_Integer_Literal (Loc, 0),
3545              Right_Opnd => Right_Opnd (N)));
3546
3547          Analyze_And_Resolve (N, Typ);
3548
3549       --  Vax floating-point types case
3550
3551       elsif Vax_Float (Etype (N)) then
3552          Expand_Vax_Arith (N);
3553       end if;
3554    end Expand_N_Op_Minus;
3555
3556    ---------------------
3557    -- Expand_N_Op_Mod --
3558    ---------------------
3559
3560    procedure Expand_N_Op_Mod (N : Node_Id) is
3561       Loc   : constant Source_Ptr := Sloc (N);
3562       T     : constant Entity_Id  := Etype (N);
3563       Left  : constant Node_Id    := Left_Opnd (N);
3564       Right : constant Node_Id    := Right_Opnd (N);
3565       DOC   : constant Boolean    := Do_Overflow_Check (N);
3566       DDC   : constant Boolean    := Do_Division_Check (N);
3567
3568       LLB : Uint;
3569       Llo : Uint;
3570       Lhi : Uint;
3571       LOK : Boolean;
3572       Rlo : Uint;
3573       Rhi : Uint;
3574       ROK : Boolean;
3575
3576    begin
3577       Binary_Op_Validity_Checks (N);
3578
3579       Determine_Range (Right, ROK, Rlo, Rhi);
3580       Determine_Range (Left,  LOK, Llo, Lhi);
3581
3582       --  Convert mod to rem if operands are known non-negative. We do this
3583       --  since it is quite likely that this will improve the quality of code,
3584       --  (the operation now corresponds to the hardware remainder), and it
3585       --  does not seem likely that it could be harmful.
3586
3587       if LOK and then Llo >= 0
3588            and then
3589          ROK and then Rlo >= 0
3590       then
3591          Rewrite (N,
3592            Make_Op_Rem (Sloc (N),
3593              Left_Opnd  => Left_Opnd (N),
3594              Right_Opnd => Right_Opnd (N)));
3595
3596          --  Instead of reanalyzing the node we do the analysis manually.
3597          --  This avoids anomalies when the replacement is done in an
3598          --  instance and is epsilon more efficient.
3599
3600          Set_Entity            (N, Standard_Entity (S_Op_Rem));
3601          Set_Etype             (N, T);
3602          Set_Do_Overflow_Check (N, DOC);
3603          Set_Do_Division_Check (N, DDC);
3604          Expand_N_Op_Rem (N);
3605          Set_Analyzed (N);
3606
3607       --  Otherwise, normal mod processing
3608
3609       else
3610          if Is_Integer_Type (Etype (N)) then
3611             Apply_Divide_Check (N);
3612          end if;
3613
3614          --  Deal with annoying case of largest negative number remainder
3615          --  minus one. Gigi does not handle this case correctly, because
3616          --  it generates a divide instruction which may trap in this case.
3617
3618          --  In fact the check is quite easy, if the right operand is -1,
3619          --  then the mod value is always 0, and we can just ignore the
3620          --  left operand completely in this case.
3621
3622          LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
3623
3624          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
3625            and then
3626             ((not LOK) or else (Llo = LLB))
3627          then
3628             Rewrite (N,
3629               Make_Conditional_Expression (Loc,
3630                 Expressions => New_List (
3631                   Make_Op_Eq (Loc,
3632                     Left_Opnd => Duplicate_Subexpr (Right),
3633                     Right_Opnd =>
3634                       Make_Integer_Literal (Loc, -1)),
3635                   Make_Integer_Literal (Loc, Uint_0),
3636                   Relocate_Node (N))));
3637
3638             Set_Analyzed (Next (Next (First (Expressions (N)))));
3639             Analyze_And_Resolve (N, T);
3640          end if;
3641       end if;
3642    end Expand_N_Op_Mod;
3643
3644    --------------------------
3645    -- Expand_N_Op_Multiply --
3646    --------------------------
3647
3648    procedure Expand_N_Op_Multiply (N : Node_Id) is
3649       Loc  : constant Source_Ptr := Sloc (N);
3650       Lop  : constant Node_Id    := Left_Opnd (N);
3651       Rop  : constant Node_Id    := Right_Opnd (N);
3652       Ltyp : constant Entity_Id  := Etype (Lop);
3653       Rtyp : constant Entity_Id  := Etype (Rop);
3654       Typ  : Entity_Id           := Etype (N);
3655
3656    begin
3657       Binary_Op_Validity_Checks (N);
3658
3659       --  Special optimizations for integer types
3660
3661       if Is_Integer_Type (Typ) then
3662
3663          --  N * 0 = 0 * N = 0 for integer types
3664
3665          if (Compile_Time_Known_Value (Right_Opnd (N))
3666               and then Expr_Value (Right_Opnd (N)) = Uint_0)
3667            or else
3668             (Compile_Time_Known_Value (Left_Opnd (N))
3669               and then Expr_Value (Left_Opnd (N)) = Uint_0)
3670          then
3671             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
3672             Analyze_And_Resolve (N, Typ);
3673             return;
3674          end if;
3675
3676          --  N * 1 = 1 * N = N for integer types
3677
3678          if Compile_Time_Known_Value (Right_Opnd (N))
3679            and then Expr_Value (Right_Opnd (N)) = Uint_1
3680          then
3681             Rewrite (N, Left_Opnd (N));
3682             return;
3683
3684          elsif Compile_Time_Known_Value (Left_Opnd (N))
3685            and then Expr_Value (Left_Opnd (N)) = Uint_1
3686          then
3687             Rewrite (N, Right_Opnd (N));
3688             return;
3689          end if;
3690       end if;
3691
3692       --  Deal with VAX float case
3693
3694       if Vax_Float (Typ) then
3695          Expand_Vax_Arith (N);
3696          return;
3697       end if;
3698
3699       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
3700       --  Is_Power_Of_2_For_Shift is set means that we know that our left
3701       --  operand is an integer, as required for this to work.
3702
3703       if Nkind (Rop) = N_Op_Expon
3704         and then Is_Power_Of_2_For_Shift (Rop)
3705       then
3706          if Nkind (Lop) = N_Op_Expon
3707            and then Is_Power_Of_2_For_Shift (Lop)
3708          then
3709
3710             --  convert 2 ** A * 2 ** B into  2 ** (A + B)
3711
3712             Rewrite (N,
3713               Make_Op_Expon (Loc,
3714                 Left_Opnd => Make_Integer_Literal (Loc, 2),
3715                 Right_Opnd =>
3716                   Make_Op_Add (Loc,
3717                     Left_Opnd  => Right_Opnd (Lop),
3718                     Right_Opnd => Right_Opnd (Rop))));
3719             Analyze_And_Resolve (N, Typ);
3720             return;
3721
3722          else
3723             Rewrite (N,
3724               Make_Op_Shift_Left (Loc,
3725                 Left_Opnd  => Lop,
3726                 Right_Opnd =>
3727                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
3728             Analyze_And_Resolve (N, Typ);
3729             return;
3730          end if;
3731
3732       --  Same processing for the operands the other way round
3733
3734       elsif Nkind (Lop) = N_Op_Expon
3735         and then Is_Power_Of_2_For_Shift (Lop)
3736       then
3737          Rewrite (N,
3738            Make_Op_Shift_Left (Loc,
3739              Left_Opnd  => Rop,
3740              Right_Opnd =>
3741                Convert_To (Standard_Natural, Right_Opnd (Lop))));
3742          Analyze_And_Resolve (N, Typ);
3743          return;
3744       end if;
3745
3746       --  Do required fixup of universal fixed operation
3747
3748       if Typ = Universal_Fixed then
3749          Fixup_Universal_Fixed_Operation (N);
3750          Typ := Etype (N);
3751       end if;
3752
3753       --  Multiplications with fixed-point results
3754
3755       if Is_Fixed_Point_Type (Typ) then
3756
3757          --  No special processing if Treat_Fixed_As_Integer is set,
3758          --  since from a semantic point of view such operations are
3759          --  simply integer operations and will be treated that way.
3760
3761          if not Treat_Fixed_As_Integer (N) then
3762
3763             --  Case of fixed * integer => fixed
3764
3765             if Is_Integer_Type (Rtyp) then
3766                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
3767
3768             --  Case of integer * fixed => fixed
3769
3770             elsif Is_Integer_Type (Ltyp) then
3771                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
3772
3773             --  Case of fixed * fixed => fixed
3774
3775             else
3776                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
3777             end if;
3778          end if;
3779
3780       --  Other cases of multiplication of fixed-point operands. Again
3781       --  we exclude the cases where Treat_Fixed_As_Integer flag is set.
3782
3783       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
3784         and then not Treat_Fixed_As_Integer (N)
3785       then
3786          if Is_Integer_Type (Typ) then
3787             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
3788          else
3789             pragma Assert (Is_Floating_Point_Type (Typ));
3790             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
3791          end if;
3792
3793       --  Mixed-mode operations can appear in a non-static universal
3794       --  context, in  which case the integer argument must be converted
3795       --  explicitly.
3796
3797       elsif Typ = Universal_Real
3798         and then Is_Integer_Type (Rtyp)
3799       then
3800          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
3801
3802          Analyze_And_Resolve (Rop, Universal_Real);
3803
3804       elsif Typ = Universal_Real
3805         and then Is_Integer_Type (Ltyp)
3806       then
3807          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
3808
3809          Analyze_And_Resolve (Lop, Universal_Real);
3810
3811       --  Non-fixed point cases, check software overflow checking required
3812
3813       elsif Is_Signed_Integer_Type (Etype (N)) then
3814          Apply_Arithmetic_Overflow_Check (N);
3815       end if;
3816    end Expand_N_Op_Multiply;
3817
3818    --------------------
3819    -- Expand_N_Op_Ne --
3820    --------------------
3821
3822    --  Rewrite node as the negation of an equality operation, and reanalyze.
3823    --  The equality to be used is defined in the same scope and has the same
3824    --  signature. It must be set explicitly because in an instance it may not
3825    --  have the same visibility as in the generic unit.
3826
3827    procedure Expand_N_Op_Ne (N : Node_Id) is
3828       Loc : constant Source_Ptr := Sloc (N);
3829       Neg : Node_Id;
3830       Ne  : constant Entity_Id := Entity (N);
3831
3832    begin
3833       Binary_Op_Validity_Checks (N);
3834
3835       Neg :=
3836         Make_Op_Not (Loc,
3837           Right_Opnd =>
3838             Make_Op_Eq (Loc,
3839               Left_Opnd =>  Left_Opnd (N),
3840               Right_Opnd => Right_Opnd (N)));
3841       Set_Paren_Count (Right_Opnd (Neg), 1);
3842
3843       if Scope (Ne) /= Standard_Standard then
3844          Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
3845       end if;
3846
3847       Rewrite (N, Neg);
3848       Analyze_And_Resolve (N, Standard_Boolean);
3849    end Expand_N_Op_Ne;
3850
3851    ---------------------
3852    -- Expand_N_Op_Not --
3853    ---------------------
3854
3855    --  If the argument is other than a Boolean array type, there is no
3856    --  special expansion required.
3857
3858    --  For the packed case, we call the special routine in Exp_Pakd, except
3859    --  that if the component size is greater than one, we use the standard
3860    --  routine generating a gruesome loop (it is so peculiar to have packed
3861    --  arrays with non-standard Boolean representations anyway, so it does
3862    --  not matter that we do not handle this case efficiently).
3863
3864    --  For the unpacked case (and for the special packed case where we have
3865    --  non standard Booleans, as discussed above), we generate and insert
3866    --  into the tree the following function definition:
3867
3868    --     function Nnnn (A : arr) is
3869    --       B : arr;
3870    --     begin
3871    --       for J in a'range loop
3872    --          B (J) := not A (J);
3873    --       end loop;
3874    --       return B;
3875    --     end Nnnn;
3876
3877    --  Here arr is the actual subtype of the parameter (and hence always
3878    --  constrained). Then we replace the not with a call to this function.
3879
3880    procedure Expand_N_Op_Not (N : Node_Id) is
3881       Loc  : constant Source_Ptr := Sloc (N);
3882       Typ  : constant Entity_Id  := Etype (N);
3883       Opnd : Node_Id;
3884       Arr  : Entity_Id;
3885       A    : Entity_Id;
3886       B    : Entity_Id;
3887       J    : Entity_Id;
3888       A_J  : Node_Id;
3889       B_J  : Node_Id;
3890
3891       Func_Name      : Entity_Id;
3892       Loop_Statement : Node_Id;
3893
3894    begin
3895       Unary_Op_Validity_Checks (N);
3896
3897       --  For boolean operand, deal with non-standard booleans
3898
3899       if Is_Boolean_Type (Typ) then
3900          Adjust_Condition (Right_Opnd (N));
3901          Set_Etype (N, Standard_Boolean);
3902          Adjust_Result_Type (N, Typ);
3903          return;
3904       end if;
3905
3906       --  Only array types need any other processing
3907
3908       if not Is_Array_Type (Typ) then
3909          return;
3910       end if;
3911
3912       --  Case of array operand. If bit packed, handle it in Exp_Pakd
3913
3914       if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
3915          Expand_Packed_Not (N);
3916          return;
3917       end if;
3918
3919       --  Case of array operand which is not bit-packed
3920
3921       Opnd := Relocate_Node (Right_Opnd (N));
3922       Convert_To_Actual_Subtype (Opnd);
3923       Arr := Etype (Opnd);
3924       Ensure_Defined (Arr, N);
3925
3926       A := Make_Defining_Identifier (Loc, Name_uA);
3927       B := Make_Defining_Identifier (Loc, Name_uB);
3928       J := Make_Defining_Identifier (Loc, Name_uJ);
3929
3930       A_J :=
3931         Make_Indexed_Component (Loc,
3932           Prefix      => New_Reference_To (A, Loc),
3933           Expressions => New_List (New_Reference_To (J, Loc)));
3934
3935       B_J :=
3936         Make_Indexed_Component (Loc,
3937           Prefix      => New_Reference_To (B, Loc),
3938           Expressions => New_List (New_Reference_To (J, Loc)));
3939
3940       Loop_Statement :=
3941         Make_Implicit_Loop_Statement (N,
3942           Identifier => Empty,
3943
3944           Iteration_Scheme =>
3945             Make_Iteration_Scheme (Loc,
3946               Loop_Parameter_Specification =>
3947                 Make_Loop_Parameter_Specification (Loc,
3948                   Defining_Identifier => J,
3949                   Discrete_Subtype_Definition =>
3950                     Make_Attribute_Reference (Loc,
3951                       Prefix => Make_Identifier (Loc, Chars (A)),
3952                       Attribute_Name => Name_Range))),
3953
3954           Statements => New_List (
3955             Make_Assignment_Statement (Loc,
3956               Name       => B_J,
3957               Expression => Make_Op_Not (Loc, A_J))));
3958
3959       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
3960       Set_Is_Inlined (Func_Name);
3961
3962       Insert_Action (N,
3963         Make_Subprogram_Body (Loc,
3964           Specification =>
3965             Make_Function_Specification (Loc,
3966               Defining_Unit_Name => Func_Name,
3967               Parameter_Specifications => New_List (
3968                 Make_Parameter_Specification (Loc,
3969                   Defining_Identifier => A,
3970                   Parameter_Type      => New_Reference_To (Typ, Loc))),
3971               Subtype_Mark => New_Reference_To (Typ, Loc)),
3972
3973           Declarations => New_List (
3974             Make_Object_Declaration (Loc,
3975               Defining_Identifier => B,
3976               Object_Definition   => New_Reference_To (Arr, Loc))),
3977
3978           Handled_Statement_Sequence =>
3979             Make_Handled_Sequence_Of_Statements (Loc,
3980               Statements => New_List (
3981                 Loop_Statement,
3982                 Make_Return_Statement (Loc,
3983                   Expression =>
3984                     Make_Identifier (Loc, Chars (B)))))));
3985
3986       Rewrite (N,
3987         Make_Function_Call (Loc,
3988           Name => New_Reference_To (Func_Name, Loc),
3989           Parameter_Associations => New_List (Opnd)));
3990
3991       Analyze_And_Resolve (N, Typ);
3992    end Expand_N_Op_Not;
3993
3994    --------------------
3995    -- Expand_N_Op_Or --
3996    --------------------
3997
3998    procedure Expand_N_Op_Or (N : Node_Id) is
3999       Typ : constant Entity_Id := Etype (N);
4000
4001    begin
4002       Binary_Op_Validity_Checks (N);
4003
4004       if Is_Array_Type (Etype (N)) then
4005          Expand_Boolean_Operator (N);
4006
4007       elsif Is_Boolean_Type (Etype (N)) then
4008          Adjust_Condition (Left_Opnd (N));
4009          Adjust_Condition (Right_Opnd (N));
4010          Set_Etype (N, Standard_Boolean);
4011          Adjust_Result_Type (N, Typ);
4012       end if;
4013    end Expand_N_Op_Or;
4014
4015    ----------------------
4016    -- Expand_N_Op_Plus --
4017    ----------------------
4018
4019    procedure Expand_N_Op_Plus (N : Node_Id) is
4020    begin
4021       Unary_Op_Validity_Checks (N);
4022    end Expand_N_Op_Plus;
4023
4024    ---------------------
4025    -- Expand_N_Op_Rem --
4026    ---------------------
4027
4028    procedure Expand_N_Op_Rem (N : Node_Id) is
4029       Loc : constant Source_Ptr := Sloc (N);
4030
4031       Left  : constant Node_Id := Left_Opnd (N);
4032       Right : constant Node_Id := Right_Opnd (N);
4033
4034       LLB : Uint;
4035       Llo : Uint;
4036       Lhi : Uint;
4037       LOK : Boolean;
4038       Rlo : Uint;
4039       Rhi : Uint;
4040       ROK : Boolean;
4041       Typ : Entity_Id;
4042
4043    begin
4044       Binary_Op_Validity_Checks (N);
4045
4046       if Is_Integer_Type (Etype (N)) then
4047          Apply_Divide_Check (N);
4048       end if;
4049
4050       --  Deal with annoying case of largest negative number remainder
4051       --  minus one. Gigi does not handle this case correctly, because
4052       --  it generates a divide instruction which may trap in this case.
4053
4054       --  In fact the check is quite easy, if the right operand is -1,
4055       --  then the remainder is always 0, and we can just ignore the
4056       --  left operand completely in this case.
4057
4058       Determine_Range (Right, ROK, Rlo, Rhi);
4059       Determine_Range (Left, LOK, Llo, Lhi);
4060       LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
4061       Typ := Etype (N);
4062
4063       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4064         and then
4065          ((not LOK) or else (Llo = LLB))
4066       then
4067          Rewrite (N,
4068            Make_Conditional_Expression (Loc,
4069              Expressions => New_List (
4070                Make_Op_Eq (Loc,
4071                  Left_Opnd => Duplicate_Subexpr (Right),
4072                  Right_Opnd =>
4073                    Make_Integer_Literal (Loc, -1)),
4074
4075                Make_Integer_Literal (Loc, Uint_0),
4076
4077                Relocate_Node (N))));
4078
4079          Set_Analyzed (Next (Next (First (Expressions (N)))));
4080          Analyze_And_Resolve (N, Typ);
4081       end if;
4082    end Expand_N_Op_Rem;
4083
4084    -----------------------------
4085    -- Expand_N_Op_Rotate_Left --
4086    -----------------------------
4087
4088    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
4089    begin
4090       Binary_Op_Validity_Checks (N);
4091    end Expand_N_Op_Rotate_Left;
4092
4093    ------------------------------
4094    -- Expand_N_Op_Rotate_Right --
4095    ------------------------------
4096
4097    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
4098    begin
4099       Binary_Op_Validity_Checks (N);
4100    end Expand_N_Op_Rotate_Right;
4101
4102    ----------------------------
4103    -- Expand_N_Op_Shift_Left --
4104    ----------------------------
4105
4106    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
4107    begin
4108       Binary_Op_Validity_Checks (N);
4109    end Expand_N_Op_Shift_Left;
4110
4111    -----------------------------
4112    -- Expand_N_Op_Shift_Right --
4113    -----------------------------
4114
4115    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
4116    begin
4117       Binary_Op_Validity_Checks (N);
4118    end Expand_N_Op_Shift_Right;
4119
4120    ----------------------------------------
4121    -- Expand_N_Op_Shift_Right_Arithmetic --
4122    ----------------------------------------
4123
4124    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
4125    begin
4126       Binary_Op_Validity_Checks (N);
4127    end Expand_N_Op_Shift_Right_Arithmetic;
4128
4129    --------------------------
4130    -- Expand_N_Op_Subtract --
4131    --------------------------
4132
4133    procedure Expand_N_Op_Subtract (N : Node_Id) is
4134       Typ : constant Entity_Id := Etype (N);
4135
4136    begin
4137       Binary_Op_Validity_Checks (N);
4138
4139       --  N - 0 = N for integer types
4140
4141       if Is_Integer_Type (Typ)
4142         and then Compile_Time_Known_Value (Right_Opnd (N))
4143         and then Expr_Value (Right_Opnd (N)) = 0
4144       then
4145          Rewrite (N, Left_Opnd (N));
4146          return;
4147       end if;
4148
4149       --  Arithemtic overflow checks for signed integer/fixed point types
4150
4151       if Is_Signed_Integer_Type (Typ)
4152         or else Is_Fixed_Point_Type (Typ)
4153       then
4154          Apply_Arithmetic_Overflow_Check (N);
4155
4156       --  Vax floating-point types case
4157
4158       elsif Vax_Float (Typ) then
4159          Expand_Vax_Arith (N);
4160       end if;
4161    end Expand_N_Op_Subtract;
4162
4163    ---------------------
4164    -- Expand_N_Op_Xor --
4165    ---------------------
4166
4167    procedure Expand_N_Op_Xor (N : Node_Id) is
4168       Typ : constant Entity_Id := Etype (N);
4169
4170    begin
4171       Binary_Op_Validity_Checks (N);
4172
4173       if Is_Array_Type (Etype (N)) then
4174          Expand_Boolean_Operator (N);
4175
4176       elsif Is_Boolean_Type (Etype (N)) then
4177          Adjust_Condition (Left_Opnd (N));
4178          Adjust_Condition (Right_Opnd (N));
4179          Set_Etype (N, Standard_Boolean);
4180          Adjust_Result_Type (N, Typ);
4181       end if;
4182    end Expand_N_Op_Xor;
4183
4184    ----------------------
4185    -- Expand_N_Or_Else --
4186    ----------------------
4187
4188    --  Expand into conditional expression if Actions present, and also
4189    --  deal with optimizing case of arguments being True or False.
4190
4191    procedure Expand_N_Or_Else (N : Node_Id) is
4192       Loc     : constant Source_Ptr := Sloc (N);
4193       Typ     : constant Entity_Id  := Etype (N);
4194       Left    : constant Node_Id    := Left_Opnd (N);
4195       Right   : constant Node_Id    := Right_Opnd (N);
4196       Actlist : List_Id;
4197
4198    begin
4199       --  Deal with non-standard booleans
4200
4201       if Is_Boolean_Type (Typ) then
4202          Adjust_Condition (Left);
4203          Adjust_Condition (Right);
4204          Set_Etype (N, Standard_Boolean);
4205
4206       --  Check for cases of left argument is True or False
4207
4208       elsif Nkind (Left) = N_Identifier then
4209
4210          --  If left argument is False, change (False or else Right) to Right.
4211          --  Any actions associated with Right will be executed unconditionally
4212          --  and can thus be inserted into the tree unconditionally.
4213
4214          if Entity (Left) = Standard_False then
4215             if Present (Actions (N)) then
4216                Insert_Actions (N, Actions (N));
4217             end if;
4218
4219             Rewrite (N, Right);
4220             Adjust_Result_Type (N, Typ);
4221             return;
4222
4223          --  If left argument is True, change (True and then Right) to
4224          --  True. In this case we can forget the actions associated with
4225          --  Right, since they will never be executed.
4226
4227          elsif Entity (Left) = Standard_True then
4228             Kill_Dead_Code (Right);
4229             Kill_Dead_Code (Actions (N));
4230             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4231             Adjust_Result_Type (N, Typ);
4232             return;
4233          end if;
4234       end if;
4235
4236       --  If Actions are present, we expand
4237
4238       --     left or else right
4239
4240       --  into
4241
4242       --     if left then True else right end
4243
4244       --  with the actions becoming the Else_Actions of the conditional
4245       --  expression. This conditional expression is then further expanded
4246       --  (and will eventually disappear)
4247
4248       if Present (Actions (N)) then
4249          Actlist := Actions (N);
4250          Rewrite (N,
4251             Make_Conditional_Expression (Loc,
4252               Expressions => New_List (
4253                 Left,
4254                 New_Occurrence_Of (Standard_True, Loc),
4255                 Right)));
4256
4257          Set_Else_Actions (N, Actlist);
4258          Analyze_And_Resolve (N, Standard_Boolean);
4259          Adjust_Result_Type (N, Typ);
4260          return;
4261       end if;
4262
4263       --  No actions present, check for cases of right argument True/False
4264
4265       if Nkind (Right) = N_Identifier then
4266
4267          --  Change (Left or else False) to Left. Note that we know there
4268          --  are no actions associated with the True operand, since we
4269          --  just checked for this case above.
4270
4271          if Entity (Right) = Standard_False then
4272             Rewrite (N, Left);
4273
4274          --  Change (Left or else True) to True, making sure to preserve
4275          --  any side effects associated with the Left operand.
4276
4277          elsif Entity (Right) = Standard_True then
4278             Remove_Side_Effects (Left);
4279             Rewrite
4280               (N, New_Occurrence_Of (Standard_True, Loc));
4281          end if;
4282       end if;
4283
4284       Adjust_Result_Type (N, Typ);
4285    end Expand_N_Or_Else;
4286
4287    -----------------------------------
4288    -- Expand_N_Qualified_Expression --
4289    -----------------------------------
4290
4291    procedure Expand_N_Qualified_Expression (N : Node_Id) is
4292       Operand     : constant Node_Id   := Expression (N);
4293       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
4294
4295    begin
4296       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
4297    end Expand_N_Qualified_Expression;
4298
4299    ---------------------------------
4300    -- Expand_N_Selected_Component --
4301    ---------------------------------
4302
4303    --  If the selector is a discriminant of a concurrent object, rewrite the
4304    --  prefix to denote the corresponding record type.
4305
4306    procedure Expand_N_Selected_Component (N : Node_Id) is
4307       Loc   : constant Source_Ptr := Sloc (N);
4308       Par   : constant Node_Id    := Parent (N);
4309       P     : constant Node_Id    := Prefix (N);
4310       Disc  : Entity_Id;
4311       Ptyp  : Entity_Id := Underlying_Type (Etype (P));
4312       New_N : Node_Id;
4313
4314       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
4315       --  Gigi needs a temporary for prefixes that depend on a discriminant,
4316       --  unless the context of an assignment can provide size information.
4317
4318       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
4319       begin
4320          return
4321              (Nkind (Parent (Comp)) = N_Assignment_Statement
4322                and then Comp = Name (Parent (Comp)))
4323            or else
4324              (Present (Parent (Comp))
4325                 and then Nkind (Parent (Comp)) in N_Subexpr
4326                 and then In_Left_Hand_Side (Parent (Comp)));
4327       end In_Left_Hand_Side;
4328
4329    begin
4330       if Do_Discriminant_Check (N) then
4331
4332          --  Present the discrminant checking function to the backend,
4333          --  so that it can inline the call to the function.
4334
4335          Add_Inlined_Body
4336            (Discriminant_Checking_Func
4337              (Original_Record_Component (Entity (Selector_Name (N)))));
4338       end if;
4339
4340       --  Insert explicit dereference call for the checked storage pool case
4341
4342       if Is_Access_Type (Ptyp) then
4343          Insert_Dereference_Action (P);
4344          return;
4345       end if;
4346
4347    --  Gigi cannot handle unchecked conversions that are the prefix of
4348    --  a selected component with discriminants. This must be checked
4349    --  during expansion, because during analysis the type of the selector
4350    --  is not known at the point the prefix is analyzed. If the conversion
4351    --  is the target of an assignment, we cannot force the evaluation, of
4352    --  course.
4353
4354       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
4355         and then Has_Discriminants (Etype (N))
4356         and then not In_Left_Hand_Side (N)
4357       then
4358          Force_Evaluation (Prefix (N));
4359       end if;
4360
4361       --  Remaining processing applies only if selector is a discriminant
4362
4363       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
4364
4365          --  If the selector is a discriminant of a constrained record type,
4366          --  rewrite the expression with the actual value of the discriminant.
4367          --  Don't do this on the left hand of an assignment statement (this
4368          --  happens in generated code, and means we really want to set it!)
4369          --  We also only do this optimization for discrete types, and not
4370          --  for access types (access discriminants get us into trouble!)
4371          --  We also do not expand the prefix of an attribute or the
4372          --  operand of an object renaming declaration.
4373
4374          if Is_Record_Type (Ptyp)
4375            and then Has_Discriminants (Ptyp)
4376            and then Is_Constrained (Ptyp)
4377            and then Is_Discrete_Type (Etype (N))
4378            and then (Nkind (Par) /= N_Assignment_Statement
4379                        or else Name (Par) /= N)
4380            and then (Nkind (Par) /= N_Attribute_Reference
4381                        or else Prefix (Par) /= N)
4382            and then not Is_Renamed_Object (N)
4383          then
4384             declare
4385                D : Entity_Id;
4386                E : Elmt_Id;
4387
4388             begin
4389                D := First_Discriminant (Ptyp);
4390                E := First_Elmt (Discriminant_Constraint (Ptyp));
4391
4392                while Present (E) loop
4393                   if D = Entity (Selector_Name (N)) then
4394
4395                      --  In the context of a case statement, the expression
4396                      --  may have the base type of the discriminant, and we
4397                      --  need to preserve the constraint to avoid spurious
4398                      --  errors on missing cases.
4399
4400                      if Nkind (Parent (N)) = N_Case_Statement
4401                        and then Etype (Node (E)) /= Etype (D)
4402                      then
4403                         Rewrite (N,
4404                           Make_Qualified_Expression (Loc,
4405                             Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
4406                             Expression   => New_Copy (Node (E))));
4407                         Analyze (N);
4408                      else
4409                         Rewrite (N, New_Copy (Node (E)));
4410                      end if;
4411
4412                      Set_Is_Static_Expression (N, False);
4413                      return;
4414                   end if;
4415
4416                   Next_Elmt (E);
4417                   Next_Discriminant (D);
4418                end loop;
4419
4420                --  Note: the above loop should always terminate, but if
4421                --  it does not, we just missed an optimization due to
4422                --  some glitch (perhaps a previous error), so ignore!
4423             end;
4424          end if;
4425
4426          --  The only remaining processing is in the case of a discriminant of
4427          --  a concurrent object, where we rewrite the prefix to denote the
4428          --  corresponding record type. If the type is derived and has renamed
4429          --  discriminants, use corresponding discriminant, which is the one
4430          --  that appears in the corresponding record.
4431
4432          if not Is_Concurrent_Type (Ptyp) then
4433             return;
4434          end if;
4435
4436          Disc := Entity (Selector_Name (N));
4437
4438          if Is_Derived_Type (Ptyp)
4439            and then Present (Corresponding_Discriminant (Disc))
4440          then
4441             Disc := Corresponding_Discriminant (Disc);
4442          end if;
4443
4444          New_N :=
4445            Make_Selected_Component (Loc,
4446              Prefix =>
4447                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
4448                  New_Copy_Tree (P)),
4449              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
4450
4451          Rewrite (N, New_N);
4452          Analyze (N);
4453       end if;
4454
4455    end Expand_N_Selected_Component;
4456
4457    --------------------
4458    -- Expand_N_Slice --
4459    --------------------
4460
4461    procedure Expand_N_Slice (N : Node_Id) is
4462       Loc  : constant Source_Ptr := Sloc (N);
4463       Typ  : constant Entity_Id  := Etype (N);
4464       Pfx  : constant Node_Id    := Prefix (N);
4465       Ptp  : Entity_Id           := Etype (Pfx);
4466       Ent  : Entity_Id;
4467       Decl : Node_Id;
4468
4469    begin
4470       --  Special handling for access types
4471
4472       if Is_Access_Type (Ptp) then
4473
4474          --  Check for explicit dereference required for checked pool
4475
4476          Insert_Dereference_Action (Pfx);
4477
4478          --  If we have an access to a packed array type, then put in an
4479          --  explicit dereference. We do this in case the slice must be
4480          --  expanded, and we want to make sure we get an access check.
4481
4482          Ptp := Designated_Type (Ptp);
4483
4484          if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
4485             Rewrite (Pfx,
4486               Make_Explicit_Dereference (Sloc (N),
4487                 Prefix => Relocate_Node (Pfx)));
4488
4489             Analyze_And_Resolve (Pfx, Ptp);
4490
4491             --  The prefix will now carry the Access_Check flag for the back
4492             --  end, remove it from slice itself.
4493
4494             Set_Do_Access_Check (N, False);
4495          end if;
4496       end if;
4497
4498       --  Range checks are potentially also needed for cases involving
4499       --  a slice indexed by a subtype indication, but Do_Range_Check
4500       --  can currently only be set for expressions ???
4501
4502       if not Index_Checks_Suppressed (Ptp)
4503         and then (not Is_Entity_Name (Pfx)
4504                    or else not Index_Checks_Suppressed (Entity (Pfx)))
4505         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
4506       then
4507          Enable_Range_Check (Discrete_Range (N));
4508       end if;
4509
4510       --  The remaining case to be handled is packed slices. We can leave
4511       --  packed slices as they are in the following situations:
4512
4513       --    1. Right or left side of an assignment (we can handle this
4514       --       situation correctly in the assignment statement expansion).
4515
4516       --    2. Prefix of indexed component (the slide is optimized away
4517       --       in this case, see the start of Expand_N_Slice.
4518
4519       --    3. Object renaming declaration, since we want the name of
4520       --       the slice, not the value.
4521
4522       --    4. Argument to procedure call, since copy-in/copy-out handling
4523       --       may be required, and this is handled in the expansion of
4524       --       call itself.
4525
4526       --    5. Prefix of an address attribute (this is an error which
4527       --       is caught elsewhere, and the expansion would intefere
4528       --       with generating the error message).
4529
4530       if Is_Packed (Typ)
4531         and then Nkind (Parent (N)) /= N_Assignment_Statement
4532         and then Nkind (Parent (N)) /= N_Indexed_Component
4533         and then not Is_Renamed_Object (N)
4534         and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
4535         and then (Nkind (Parent (N)) /= N_Attribute_Reference
4536                     or else
4537                   Attribute_Name (Parent (N)) /= Name_Address)
4538       then
4539          Ent :=
4540            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
4541
4542          Decl :=
4543            Make_Object_Declaration (Loc,
4544              Defining_Identifier => Ent,
4545              Object_Definition   => New_Occurrence_Of (Typ, Loc));
4546
4547          Set_No_Initialization (Decl);
4548
4549          Insert_Actions (N, New_List (
4550            Decl,
4551            Make_Assignment_Statement (Loc,
4552              Name => New_Occurrence_Of (Ent, Loc),
4553              Expression => Relocate_Node (N))));
4554
4555          Rewrite (N, New_Occurrence_Of (Ent, Loc));
4556          Analyze_And_Resolve (N, Typ);
4557       end if;
4558    end Expand_N_Slice;
4559
4560    ------------------------------
4561    -- Expand_N_Type_Conversion --
4562    ------------------------------
4563
4564    procedure Expand_N_Type_Conversion (N : Node_Id) is
4565       Loc          : constant Source_Ptr := Sloc (N);
4566       Operand      : constant Node_Id    := Expression (N);
4567       Target_Type  : constant Entity_Id  := Etype (N);
4568       Operand_Type : Entity_Id           := Etype (Operand);
4569
4570       procedure Handle_Changed_Representation;
4571       --  This is called in the case of record and array type conversions
4572       --  to see if there is a change of representation to be handled.
4573       --  Change of representation is actually handled at the assignment
4574       --  statement level, and what this procedure does is rewrite node N
4575       --  conversion as an assignment to temporary. If there is no change
4576       --  of representation, then the conversion node is unchanged.
4577
4578       procedure Real_Range_Check;
4579       --  Handles generation of range check for real target value
4580
4581       -----------------------------------
4582       -- Handle_Changed_Representation --
4583       -----------------------------------
4584
4585       procedure Handle_Changed_Representation is
4586          Temp : Entity_Id;
4587          Decl : Node_Id;
4588          Odef : Node_Id;
4589          Disc : Node_Id;
4590          N_Ix : Node_Id;
4591          Cons : List_Id;
4592
4593       begin
4594          --  Nothing to do if no change of representation
4595
4596          if Same_Representation (Operand_Type, Target_Type) then
4597             return;
4598
4599          --  The real change of representation work is done by the assignment
4600          --  statement processing. So if this type conversion is appearing as
4601          --  the expression of an assignment statement, nothing needs to be
4602          --  done to the conversion.
4603
4604          elsif Nkind (Parent (N)) = N_Assignment_Statement then
4605             return;
4606
4607          --  Otherwise we need to generate a temporary variable, and do the
4608          --  change of representation assignment into that temporary variable.
4609          --  The conversion is then replaced by a reference to this variable.
4610
4611          else
4612             Cons := No_List;
4613
4614             --  If type is unconstrained we have to add a constraint,
4615             --  copied from the actual value of the left hand side.
4616
4617             if not Is_Constrained (Target_Type) then
4618                if Has_Discriminants (Operand_Type) then
4619                   Disc := First_Discriminant (Operand_Type);
4620                   Cons := New_List;
4621                   while Present (Disc) loop
4622                      Append_To (Cons,
4623                        Make_Selected_Component (Loc,
4624                          Prefix => Duplicate_Subexpr (Operand),
4625                          Selector_Name =>
4626                            Make_Identifier (Loc, Chars (Disc))));
4627                      Next_Discriminant (Disc);
4628                   end loop;
4629
4630                elsif Is_Array_Type (Operand_Type) then
4631                   N_Ix := First_Index (Target_Type);
4632                   Cons := New_List;
4633
4634                   for J in 1 .. Number_Dimensions (Operand_Type) loop
4635
4636                      --  We convert the bounds explicitly. We use an unchecked
4637                      --  conversion because bounds checks are done elsewhere.
4638
4639                      Append_To (Cons,
4640                        Make_Range (Loc,
4641                          Low_Bound =>
4642                            Unchecked_Convert_To (Etype (N_Ix),
4643                              Make_Attribute_Reference (Loc,
4644                                Prefix =>
4645                                  Duplicate_Subexpr
4646                                    (Operand, Name_Req => True),
4647                                Attribute_Name => Name_First,
4648                                Expressions    => New_List (
4649                                  Make_Integer_Literal (Loc, J)))),
4650
4651                          High_Bound =>
4652                            Unchecked_Convert_To (Etype (N_Ix),
4653                              Make_Attribute_Reference (Loc,
4654                                Prefix =>
4655                                  Duplicate_Subexpr
4656                                    (Operand, Name_Req => True),
4657                                Attribute_Name => Name_Last,
4658                                Expressions    => New_List (
4659                                  Make_Integer_Literal (Loc, J))))));
4660
4661                      Next_Index (N_Ix);
4662                   end loop;
4663                end if;
4664             end if;
4665
4666             Odef := New_Occurrence_Of (Target_Type, Loc);
4667
4668             if Present (Cons) then
4669                Odef :=
4670                  Make_Subtype_Indication (Loc,
4671                    Subtype_Mark => Odef,
4672                    Constraint =>
4673                      Make_Index_Or_Discriminant_Constraint (Loc,
4674                        Constraints => Cons));
4675             end if;
4676
4677             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
4678             Decl :=
4679               Make_Object_Declaration (Loc,
4680                 Defining_Identifier => Temp,
4681                 Object_Definition   => Odef);
4682
4683             Set_No_Initialization (Decl, True);
4684
4685             --  Insert required actions. It is essential to suppress checks
4686             --  since we have suppressed default initialization, which means
4687             --  that the variable we create may have no discriminants.
4688
4689             Insert_Actions (N,
4690               New_List (
4691                 Decl,
4692                 Make_Assignment_Statement (Loc,
4693                   Name => New_Occurrence_Of (Temp, Loc),
4694                   Expression => Relocate_Node (N))),
4695                 Suppress => All_Checks);
4696
4697             Rewrite (N, New_Occurrence_Of (Temp, Loc));
4698             return;
4699          end if;
4700       end Handle_Changed_Representation;
4701
4702       ----------------------
4703       -- Real_Range_Check --
4704       ----------------------
4705
4706       --  Case of conversions to floating-point or fixed-point. If range
4707       --  checks are enabled and the target type has a range constraint,
4708       --  we convert:
4709
4710       --     typ (x)
4711
4712       --       to
4713
4714       --     Tnn : typ'Base := typ'Base (x);
4715       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
4716       --     Tnn
4717
4718       procedure Real_Range_Check is
4719          Btyp : constant Entity_Id := Base_Type (Target_Type);
4720          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
4721          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
4722          Conv : Node_Id;
4723          Tnn  : Entity_Id;
4724
4725       begin
4726          --  Nothing to do if conversion was rewritten
4727
4728          if Nkind (N) /= N_Type_Conversion then
4729             return;
4730          end if;
4731
4732          --  Nothing to do if range checks suppressed, or target has the
4733          --  same range as the base type (or is the base type).
4734
4735          if Range_Checks_Suppressed (Target_Type)
4736            or else (Lo = Type_Low_Bound (Btyp)
4737                       and then
4738                     Hi = Type_High_Bound (Btyp))
4739          then
4740             return;
4741          end if;
4742
4743          --  Nothing to do if expression is an entity on which checks
4744          --  have been suppressed.
4745
4746          if Is_Entity_Name (Expression (N))
4747            and then Range_Checks_Suppressed (Entity (Expression (N)))
4748          then
4749             return;
4750          end if;
4751
4752          --  Here we rewrite the conversion as described above
4753
4754          Conv := Relocate_Node (N);
4755          Rewrite
4756            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
4757          Set_Etype (Conv, Btyp);
4758
4759          --  Skip overflow check for integer to float conversions,
4760          --  since it is not needed, and in any case gigi generates
4761          --  incorrect code for such overflow checks ???
4762
4763          if not Is_Integer_Type (Etype (Expression (N))) then
4764             Set_Do_Overflow_Check (Conv, True);
4765          end if;
4766
4767          Tnn :=
4768            Make_Defining_Identifier (Loc,
4769              Chars => New_Internal_Name ('T'));
4770
4771          Insert_Actions (N, New_List (
4772            Make_Object_Declaration (Loc,
4773              Defining_Identifier => Tnn,
4774              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
4775              Expression => Conv),
4776
4777            Make_Raise_Constraint_Error (Loc,
4778              Condition =>
4779               Make_Or_Else (Loc,
4780                 Left_Opnd =>
4781                   Make_Op_Lt (Loc,
4782                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
4783                     Right_Opnd =>
4784                       Make_Attribute_Reference (Loc,
4785                         Attribute_Name => Name_First,
4786                         Prefix =>
4787                           New_Occurrence_Of (Target_Type, Loc))),
4788
4789                 Right_Opnd =>
4790                   Make_Op_Gt (Loc,
4791                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
4792                     Right_Opnd =>
4793                       Make_Attribute_Reference (Loc,
4794                         Attribute_Name => Name_Last,
4795                         Prefix =>
4796                           New_Occurrence_Of (Target_Type, Loc)))),
4797              Reason => CE_Range_Check_Failed)));
4798
4799          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4800          Analyze_And_Resolve (N, Btyp);
4801       end Real_Range_Check;
4802
4803    --  Start of processing for Expand_N_Type_Conversion
4804
4805    begin
4806       --  Nothing at all to do if conversion is to the identical type
4807       --  so remove the conversion completely, it is useless.
4808
4809       if Operand_Type = Target_Type then
4810          Rewrite (N, Relocate_Node (Expression (N)));
4811          return;
4812       end if;
4813
4814       --  Deal with Vax floating-point cases
4815
4816       if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
4817          Expand_Vax_Conversion (N);
4818          return;
4819       end if;
4820
4821       --  Nothing to do if this is the second argument of read. This
4822       --  is a "backwards" conversion that will be handled by the
4823       --  specialized code in attribute processing.
4824
4825       if Nkind (Parent (N)) = N_Attribute_Reference
4826         and then Attribute_Name (Parent (N)) = Name_Read
4827         and then Next (First (Expressions (Parent (N)))) = N
4828       then
4829          return;
4830       end if;
4831
4832       --  Here if we may need to expand conversion
4833
4834       --  Special case of converting from non-standard boolean type
4835
4836       if Is_Boolean_Type (Operand_Type)
4837         and then (Nonzero_Is_True (Operand_Type))
4838       then
4839          Adjust_Condition (Operand);
4840          Set_Etype (Operand, Standard_Boolean);
4841          Operand_Type := Standard_Boolean;
4842       end if;
4843
4844       --  Case of converting to an access type
4845
4846       if Is_Access_Type (Target_Type) then
4847
4848          --  Apply an accessibility check if the operand is an
4849          --  access parameter. Note that other checks may still
4850          --  need to be applied below (such as tagged type checks).
4851
4852          if Is_Entity_Name (Operand)
4853            and then Ekind (Entity (Operand)) in Formal_Kind
4854            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
4855          then
4856             Apply_Accessibility_Check (Operand, Target_Type);
4857
4858          --  If the level of the operand type is statically deeper
4859          --  then the level of the target type, then force Program_Error.
4860          --  Note that this can only occur for cases where the attribute
4861          --  is within the body of an instantiation (otherwise the
4862          --  conversion will already have been rejected as illegal).
4863          --  Note: warnings are issued by the analyzer for the instance
4864          --  cases.
4865
4866          elsif In_Instance_Body
4867            and then Type_Access_Level (Operand_Type) >
4868                     Type_Access_Level (Target_Type)
4869          then
4870             Rewrite (N,
4871               Make_Raise_Program_Error (Sloc (N),
4872                 Reason => PE_Accessibility_Check_Failed));
4873             Set_Etype (N, Target_Type);
4874
4875          --  When the operand is a selected access discriminant
4876          --  the check needs to be made against the level of the
4877          --  object denoted by the prefix of the selected name.
4878          --  Force Program_Error for this case as well (this
4879          --  accessibility violation can only happen if within
4880          --  the body of an instantiation).
4881
4882          elsif In_Instance_Body
4883            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
4884            and then Nkind (Operand) = N_Selected_Component
4885            and then Object_Access_Level (Operand) >
4886                       Type_Access_Level (Target_Type)
4887          then
4888             Rewrite (N,
4889               Make_Raise_Program_Error (Sloc (N),
4890                 Reason => PE_Accessibility_Check_Failed));
4891             Set_Etype (N, Target_Type);
4892          end if;
4893       end if;
4894
4895       --  Case of conversions of tagged types and access to tagged types
4896
4897       --  When needed, that is to say when the expression is class-wide,
4898       --  Add runtime a tag check for (strict) downward conversion by using
4899       --  the membership test, generating:
4900
4901       --      [constraint_error when Operand not in Target_Type'Class]
4902
4903       --  or in the access type case
4904
4905       --      [constraint_error
4906       --        when Operand /= null
4907       --          and then Operand.all not in
4908       --            Designated_Type (Target_Type)'Class]
4909
4910       if (Is_Access_Type (Target_Type)
4911            and then Is_Tagged_Type (Designated_Type (Target_Type)))
4912         or else Is_Tagged_Type (Target_Type)
4913       then
4914          --  Do not do any expansion in the access type case if the
4915          --  parent is a renaming, since this is an error situation
4916          --  which will be caught by Sem_Ch8, and the expansion can
4917          --  intefere with this error check.
4918
4919          if Is_Access_Type (Target_Type)
4920            and then Is_Renamed_Object (N)
4921          then
4922             return;
4923          end if;
4924
4925          --  Oherwise, proceed with processing tagged conversion
4926
4927          declare
4928             Actual_Operand_Type : Entity_Id;
4929             Actual_Target_Type  : Entity_Id;
4930
4931             Cond : Node_Id;
4932
4933          begin
4934             if Is_Access_Type (Target_Type) then
4935                Actual_Operand_Type := Designated_Type (Operand_Type);
4936                Actual_Target_Type  := Designated_Type (Target_Type);
4937
4938             else
4939                Actual_Operand_Type := Operand_Type;
4940                Actual_Target_Type  := Target_Type;
4941             end if;
4942
4943             if Is_Class_Wide_Type (Actual_Operand_Type)
4944               and then Root_Type (Actual_Operand_Type) /=  Actual_Target_Type
4945               and then Is_Ancestor
4946                          (Root_Type (Actual_Operand_Type),
4947                           Actual_Target_Type)
4948               and then not Tag_Checks_Suppressed (Actual_Target_Type)
4949             then
4950                --  The conversion is valid for any descendant of the
4951                --  target type
4952
4953                Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
4954
4955                if Is_Access_Type (Target_Type) then
4956                   Cond :=
4957                      Make_And_Then (Loc,
4958                        Left_Opnd =>
4959                          Make_Op_Ne (Loc,
4960                            Left_Opnd  => Duplicate_Subexpr (Operand),
4961                            Right_Opnd => Make_Null (Loc)),
4962
4963                        Right_Opnd =>
4964                          Make_Not_In (Loc,
4965                            Left_Opnd  =>
4966                              Make_Explicit_Dereference (Loc,
4967                                Prefix => Duplicate_Subexpr (Operand)),
4968                            Right_Opnd =>
4969                              New_Reference_To (Actual_Target_Type, Loc)));
4970
4971                else
4972                   Cond :=
4973                     Make_Not_In (Loc,
4974                       Left_Opnd  => Duplicate_Subexpr (Operand),
4975                       Right_Opnd =>
4976                         New_Reference_To (Actual_Target_Type, Loc));
4977                end if;
4978
4979                Insert_Action (N,
4980                  Make_Raise_Constraint_Error (Loc,
4981                    Condition => Cond,
4982                    Reason    => CE_Tag_Check_Failed));
4983
4984                Change_Conversion_To_Unchecked (N);
4985                Analyze_And_Resolve (N, Target_Type);
4986             end if;
4987          end;
4988
4989       --  Case of other access type conversions
4990
4991       elsif Is_Access_Type (Target_Type) then
4992          Apply_Constraint_Check (Operand, Target_Type);
4993
4994       --  Case of conversions from a fixed-point type
4995
4996       --  These conversions require special expansion and processing, found
4997       --  in the Exp_Fixd package. We ignore cases where Conversion_OK is
4998       --  set, since from a semantic point of view, these are simple integer
4999       --  conversions, which do not need further processing.
5000
5001       elsif Is_Fixed_Point_Type (Operand_Type)
5002         and then not Conversion_OK (N)
5003       then
5004          --  We should never see universal fixed at this case, since the
5005          --  expansion of the constituent divide or multiply should have
5006          --  eliminated the explicit mention of universal fixed.
5007
5008          pragma Assert (Operand_Type /= Universal_Fixed);
5009
5010          --  Check for special case of the conversion to universal real
5011          --  that occurs as a result of the use of a round attribute.
5012          --  In this case, the real type for the conversion is taken
5013          --  from the target type of the Round attribute and the
5014          --  result must be marked as rounded.
5015
5016          if Target_Type = Universal_Real
5017            and then Nkind (Parent (N)) = N_Attribute_Reference
5018            and then Attribute_Name (Parent (N)) = Name_Round
5019          then
5020             Set_Rounded_Result (N);
5021             Set_Etype (N, Etype (Parent (N)));
5022          end if;
5023
5024          --  Otherwise do correct fixed-conversion, but skip these if the
5025          --  Conversion_OK flag is set, because from a semantic point of
5026          --  view these are simple integer conversions needing no further
5027          --  processing (the backend will simply treat them as integers)
5028
5029          if not Conversion_OK (N) then
5030             if Is_Fixed_Point_Type (Etype (N)) then
5031                Expand_Convert_Fixed_To_Fixed (N);
5032                Real_Range_Check;
5033
5034             elsif Is_Integer_Type (Etype (N)) then
5035                Expand_Convert_Fixed_To_Integer (N);
5036
5037             else
5038                pragma Assert (Is_Floating_Point_Type (Etype (N)));
5039                Expand_Convert_Fixed_To_Float (N);
5040                Real_Range_Check;
5041             end if;
5042          end if;
5043
5044       --  Case of conversions to a fixed-point type
5045
5046       --  These conversions require special expansion and processing, found
5047       --  in the Exp_Fixd package. Again, ignore cases where Conversion_OK
5048       --  is set, since from a semantic point of view, these are simple
5049       --  integer conversions, which do not need further processing.
5050
5051       elsif Is_Fixed_Point_Type (Target_Type)
5052         and then not Conversion_OK (N)
5053       then
5054          if Is_Integer_Type (Operand_Type) then
5055             Expand_Convert_Integer_To_Fixed (N);
5056             Real_Range_Check;
5057          else
5058             pragma Assert (Is_Floating_Point_Type (Operand_Type));
5059             Expand_Convert_Float_To_Fixed (N);
5060             Real_Range_Check;
5061          end if;
5062
5063       --  Case of float-to-integer conversions
5064
5065       --  We also handle float-to-fixed conversions with Conversion_OK set
5066       --  since semantically the fixed-point target is treated as though it
5067       --  were an integer in such cases.
5068
5069       elsif Is_Floating_Point_Type (Operand_Type)
5070         and then
5071           (Is_Integer_Type (Target_Type)
5072             or else
5073           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
5074       then
5075          --  Special processing required if the conversion is the expression
5076          --  of a Truncation attribute reference. In this case we replace:
5077
5078          --     ityp (ftyp'Truncation (x))
5079
5080          --  by
5081
5082          --     ityp (x)
5083
5084          --  with the Float_Truncate flag set. This is clearly more efficient.
5085
5086          if Nkind (Operand) = N_Attribute_Reference
5087            and then Attribute_Name (Operand) = Name_Truncation
5088          then
5089             Rewrite (Operand,
5090               Relocate_Node (First (Expressions (Operand))));
5091             Set_Float_Truncate (N, True);
5092          end if;
5093
5094          --  One more check here, gcc is still not able to do conversions of
5095          --  this type with proper overflow checking, and so gigi is doing an
5096          --  approximation of what is required by doing floating-point compares
5097          --  with the end-point. But that can lose precision in some cases, and
5098          --  give a wrong result. Converting the operand to Long_Long_Float is
5099          --  helpful, but still does not catch all cases with 64-bit integers
5100          --  on targets with only 64-bit floats ???
5101
5102          if Do_Range_Check (Expression (N)) then
5103             Rewrite (Expression (N),
5104               Make_Type_Conversion (Loc,
5105                 Subtype_Mark =>
5106                   New_Occurrence_Of (Standard_Long_Long_Float, Loc),
5107                 Expression =>
5108                   Relocate_Node (Expression (N))));
5109
5110             Set_Etype (Expression (N), Standard_Long_Long_Float);
5111             Enable_Range_Check (Expression (N));
5112             Set_Do_Range_Check (Expression (Expression (N)), False);
5113          end if;
5114
5115       --  Case of array conversions
5116
5117       --  Expansion of array conversions, add required length/range checks
5118       --  but only do this if there is no change of representation. For
5119       --  handling of this case, see Handle_Changed_Representation.
5120
5121       elsif Is_Array_Type (Target_Type) then
5122
5123          if Is_Constrained (Target_Type) then
5124             Apply_Length_Check (Operand, Target_Type);
5125          else
5126             Apply_Range_Check (Operand, Target_Type);
5127          end if;
5128
5129          Handle_Changed_Representation;
5130
5131       --  Case of conversions of discriminated types
5132
5133       --  Add required discriminant checks if target is constrained. Again
5134       --  this change is skipped if we have a change of representation.
5135
5136       elsif Has_Discriminants (Target_Type)
5137         and then Is_Constrained (Target_Type)
5138       then
5139          Apply_Discriminant_Check (Operand, Target_Type);
5140          Handle_Changed_Representation;
5141
5142       --  Case of all other record conversions. The only processing required
5143       --  is to check for a change of representation requiring the special
5144       --  assignment processing.
5145
5146       elsif Is_Record_Type (Target_Type) then
5147          Handle_Changed_Representation;
5148
5149       --  Case of conversions of enumeration types
5150
5151       elsif Is_Enumeration_Type (Target_Type) then
5152
5153          --  Special processing is required if there is a change of
5154          --  representation (from enumeration representation clauses)
5155
5156          if not Same_Representation (Target_Type, Operand_Type) then
5157
5158             --  Convert: x(y) to x'val (ytyp'val (y))
5159
5160             Rewrite (N,
5161                Make_Attribute_Reference (Loc,
5162                  Prefix => New_Occurrence_Of (Target_Type, Loc),
5163                  Attribute_Name => Name_Val,
5164                  Expressions => New_List (
5165                    Make_Attribute_Reference (Loc,
5166                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
5167                      Attribute_Name => Name_Pos,
5168                      Expressions => New_List (Operand)))));
5169
5170             Analyze_And_Resolve (N, Target_Type);
5171          end if;
5172
5173       --  Case of conversions to floating-point
5174
5175       elsif Is_Floating_Point_Type (Target_Type) then
5176          Real_Range_Check;
5177
5178       --  The remaining cases require no front end processing
5179
5180       else
5181          null;
5182       end if;
5183
5184       --  At this stage, either the conversion node has been transformed
5185       --  into some other equivalent expression, or left as a conversion
5186       --  that can be handled by Gigi. The conversions that Gigi can handle
5187       --  are the following:
5188
5189       --    Conversions with no change of representation or type
5190
5191       --    Numeric conversions involving integer values, floating-point
5192       --    values, and fixed-point values. Fixed-point values are allowed
5193       --    only if Conversion_OK is set, i.e. if the fixed-point values
5194       --    are to be treated as integers.
5195
5196       --  No other conversions should be passed to Gigi.
5197
5198    end Expand_N_Type_Conversion;
5199
5200    -----------------------------------
5201    -- Expand_N_Unchecked_Expression --
5202    -----------------------------------
5203
5204    --  Remove the unchecked expression node from the tree. It's job was simply
5205    --  to make sure that its constituent expression was handled with checks
5206    --  off, and now that that is done, we can remove it from the tree, and
5207    --  indeed must, since gigi does not expect to see these nodes.
5208
5209    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
5210       Exp : constant Node_Id := Expression (N);
5211
5212    begin
5213       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
5214       Rewrite (N, Exp);
5215    end Expand_N_Unchecked_Expression;
5216
5217    ----------------------------------------
5218    -- Expand_N_Unchecked_Type_Conversion --
5219    ----------------------------------------
5220
5221    --  If this cannot be handled by Gigi and we haven't already made
5222    --  a temporary for it, do it now.
5223
5224    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
5225       Target_Type  : constant Entity_Id := Etype (N);
5226       Operand      : constant Node_Id   := Expression (N);
5227       Operand_Type : constant Entity_Id := Etype (Operand);
5228
5229    begin
5230       --  If we have a conversion of a compile time known value to a target
5231       --  type and the value is in range of the target type, then we can simply
5232       --  replace the construct by an integer literal of the correct type. We
5233       --  only apply this to integer types being converted. Possibly it may
5234       --  apply in other cases, but it is too much trouble to worry about.
5235
5236       --  Note that we do not do this transformation if the Kill_Range_Check
5237       --  flag is set, since then the value may be outside the expected range.
5238       --  This happens in the Normalize_Scalars case.
5239
5240       if Is_Integer_Type (Target_Type)
5241         and then Is_Integer_Type (Operand_Type)
5242         and then Compile_Time_Known_Value (Operand)
5243         and then not Kill_Range_Check (N)
5244       then
5245          declare
5246             Val : constant Uint := Expr_Value (Operand);
5247
5248          begin
5249             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
5250                  and then
5251                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
5252                  and then
5253                Val >= Expr_Value (Type_Low_Bound (Target_Type))
5254                  and then
5255                Val <= Expr_Value (Type_High_Bound (Target_Type))
5256             then
5257                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
5258                Analyze_And_Resolve (N, Target_Type);
5259                return;
5260             end if;
5261          end;
5262       end if;
5263
5264       --  Nothing to do if conversion is safe
5265
5266       if Safe_Unchecked_Type_Conversion (N) then
5267          return;
5268       end if;
5269
5270       --  Otherwise force evaluation unless Assignment_OK flag is set (this
5271       --  flag indicates ??? -- more comments needed here)
5272
5273       if Assignment_OK (N) then
5274          null;
5275       else
5276          Force_Evaluation (N);
5277       end if;
5278    end Expand_N_Unchecked_Type_Conversion;
5279
5280    ----------------------------
5281    -- Expand_Record_Equality --
5282    ----------------------------
5283
5284    --  For non-variant records, Equality is expanded when needed into:
5285
5286    --      and then Lhs.Discr1 = Rhs.Discr1
5287    --      and then ...
5288    --      and then Lhs.Discrn = Rhs.Discrn
5289    --      and then Lhs.Cmp1 = Rhs.Cmp1
5290    --      and then ...
5291    --      and then Lhs.Cmpn = Rhs.Cmpn
5292
5293    --  The expression is folded by the back-end for adjacent fields. This
5294    --  function is called for tagged record in only one occasion: for imple-
5295    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
5296    --  otherwise the primitive "=" is used directly.
5297
5298    function Expand_Record_Equality
5299      (Nod    : Node_Id;
5300       Typ    : Entity_Id;
5301       Lhs    : Node_Id;
5302       Rhs    : Node_Id;
5303       Bodies : List_Id)
5304       return   Node_Id
5305    is
5306       Loc : constant Source_Ptr := Sloc (Nod);
5307
5308       function Suitable_Element (C : Entity_Id) return Entity_Id;
5309       --  Return the first field to compare beginning with C, skipping the
5310       --  inherited components
5311
5312       function Suitable_Element (C : Entity_Id) return Entity_Id is
5313       begin
5314          if No (C) then
5315             return Empty;
5316
5317          elsif Ekind (C) /= E_Discriminant
5318            and then Ekind (C) /= E_Component
5319          then
5320             return Suitable_Element (Next_Entity (C));
5321
5322          elsif Is_Tagged_Type (Typ)
5323            and then C /= Original_Record_Component (C)
5324          then
5325             return Suitable_Element (Next_Entity (C));
5326
5327          elsif Chars (C) = Name_uController
5328            or else Chars (C) = Name_uTag
5329          then
5330             return Suitable_Element (Next_Entity (C));
5331
5332          else
5333             return C;
5334          end if;
5335       end Suitable_Element;
5336
5337       Result : Node_Id;
5338       C      : Entity_Id;
5339
5340       First_Time : Boolean := True;
5341
5342    --  Start of processing for Expand_Record_Equality
5343
5344    begin
5345       --  Special processing for the unchecked union case, which will occur
5346       --  only in the context of tagged types and dynamic dispatching, since
5347       --  other cases are handled statically. We return True, but insert a
5348       --  raise Program_Error statement.
5349
5350       if Is_Unchecked_Union (Typ) then
5351
5352          --  If this is a component of an enclosing record, return the Raise
5353          --  statement directly.
5354
5355          if No (Parent (Lhs)) then
5356             Result :=
5357               Make_Raise_Program_Error (Loc,
5358                 Reason => PE_Unchecked_Union_Restriction);
5359             Set_Etype (Result, Standard_Boolean);
5360             return Result;
5361
5362          else
5363             Insert_Action (Lhs,
5364               Make_Raise_Program_Error (Loc,
5365                 Reason => PE_Unchecked_Union_Restriction));
5366             return New_Occurrence_Of (Standard_True, Loc);
5367          end if;
5368       end if;
5369
5370       --  Generates the following code: (assuming that Typ has one Discr and
5371       --  component C2 is also a record)
5372
5373       --   True
5374       --     and then Lhs.Discr1 = Rhs.Discr1
5375       --     and then Lhs.C1 = Rhs.C1
5376       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
5377       --     and then ...
5378       --     and then Lhs.Cmpn = Rhs.Cmpn
5379
5380       Result := New_Reference_To (Standard_True, Loc);
5381       C := Suitable_Element (First_Entity (Typ));
5382
5383       while Present (C) loop
5384
5385          declare
5386             New_Lhs : Node_Id;
5387             New_Rhs : Node_Id;
5388
5389          begin
5390             if First_Time then
5391                First_Time := False;
5392                New_Lhs := Lhs;
5393                New_Rhs := Rhs;
5394
5395             else
5396                New_Lhs := New_Copy_Tree (Lhs);
5397                New_Rhs := New_Copy_Tree (Rhs);
5398             end if;
5399
5400             Result :=
5401               Make_And_Then (Loc,
5402                 Left_Opnd  => Result,
5403                 Right_Opnd =>
5404                   Expand_Composite_Equality (Nod, Etype (C),
5405                     Lhs =>
5406                       Make_Selected_Component (Loc,
5407                         Prefix => New_Lhs,
5408                         Selector_Name => New_Reference_To (C, Loc)),
5409                     Rhs =>
5410                       Make_Selected_Component (Loc,
5411                         Prefix => New_Rhs,
5412                         Selector_Name => New_Reference_To (C, Loc)),
5413                     Bodies => Bodies));
5414          end;
5415
5416          C := Suitable_Element (Next_Entity (C));
5417       end loop;
5418
5419       return Result;
5420    end Expand_Record_Equality;
5421
5422    -------------------------------------
5423    -- Fixup_Universal_Fixed_Operation --
5424    -------------------------------------
5425
5426    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
5427       Conv : constant Node_Id := Parent (N);
5428
5429    begin
5430       --  We must have a type conversion immediately above us
5431
5432       pragma Assert (Nkind (Conv) = N_Type_Conversion);
5433
5434       --  Normally the type conversion gives our target type. The exception
5435       --  occurs in the case of the Round attribute, where the conversion
5436       --  will be to universal real, and our real type comes from the Round
5437       --  attribute (as well as an indication that we must round the result)
5438
5439       if Nkind (Parent (Conv)) = N_Attribute_Reference
5440         and then Attribute_Name (Parent (Conv)) = Name_Round
5441       then
5442          Set_Etype (N, Etype (Parent (Conv)));
5443          Set_Rounded_Result (N);
5444
5445       --  Normal case where type comes from conversion above us
5446
5447       else
5448          Set_Etype (N, Etype (Conv));
5449       end if;
5450    end Fixup_Universal_Fixed_Operation;
5451
5452    -------------------------------
5453    -- Insert_Dereference_Action --
5454    -------------------------------
5455
5456    procedure Insert_Dereference_Action (N : Node_Id) is
5457       Loc  : constant Source_Ptr := Sloc (N);
5458       Typ  : constant Entity_Id  := Etype (N);
5459       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
5460
5461       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
5462       --  return true if type of P is derived from Checked_Pool;
5463
5464       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
5465          T : Entity_Id;
5466
5467       begin
5468          if No (P) then
5469             return False;
5470          end if;
5471
5472          T := Etype (P);
5473          while T /= Etype (T) loop
5474             if Is_RTE (T, RE_Checked_Pool) then
5475                return True;
5476             else
5477                T := Etype (T);
5478             end if;
5479          end loop;
5480
5481          return False;
5482       end Is_Checked_Storage_Pool;
5483
5484    --  Start of processing for Insert_Dereference_Action
5485
5486    begin
5487       if not Comes_From_Source (Parent (N)) then
5488          return;
5489
5490       elsif not Is_Checked_Storage_Pool (Pool) then
5491          return;
5492       end if;
5493
5494       Insert_Action (N,
5495         Make_Procedure_Call_Statement (Loc,
5496           Name => New_Reference_To (
5497             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
5498
5499           Parameter_Associations => New_List (
5500
5501             --  Pool
5502
5503              New_Reference_To (Pool, Loc),
5504
5505             --  Storage_Address
5506
5507              Make_Attribute_Reference (Loc,
5508                Prefix         =>
5509                  Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
5510                Attribute_Name => Name_Address),
5511
5512             --  Size_In_Storage_Elements
5513
5514              Make_Op_Divide (Loc,
5515                Left_Opnd  =>
5516                 Make_Attribute_Reference (Loc,
5517                   Prefix         =>
5518                     Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
5519                   Attribute_Name => Name_Size),
5520                Right_Opnd =>
5521                  Make_Integer_Literal (Loc, System_Storage_Unit)),
5522
5523             --  Alignment
5524
5525              Make_Attribute_Reference (Loc,
5526                Prefix         =>
5527                  Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
5528                Attribute_Name => Name_Alignment))));
5529
5530    end Insert_Dereference_Action;
5531
5532    ------------------------------
5533    -- Make_Array_Comparison_Op --
5534    ------------------------------
5535
5536    --  This is a hand-coded expansion of the following generic function:
5537
5538    --  generic
5539    --    type elem is  (<>);
5540    --    type index is (<>);
5541    --    type a is array (index range <>) of elem;
5542    --
5543    --  function Gnnn (X : a; Y: a) return boolean is
5544    --    J : index := Y'first;
5545    --
5546    --  begin
5547    --    if X'length = 0 then
5548    --       return false;
5549    --
5550    --    elsif Y'length = 0 then
5551    --       return true;
5552    --
5553    --    else
5554    --      for I in X'range loop
5555    --        if X (I) = Y (J) then
5556    --          if J = Y'last then
5557    --            exit;
5558    --          else
5559    --            J := index'succ (J);
5560    --          end if;
5561    --
5562    --        else
5563    --           return X (I) > Y (J);
5564    --        end if;
5565    --      end loop;
5566    --
5567    --      return X'length > Y'length;
5568    --    end if;
5569    --  end Gnnn;
5570
5571    --  Note that since we are essentially doing this expansion by hand, we
5572    --  do not need to generate an actual or formal generic part, just the
5573    --  instantiated function itself.
5574
5575    function Make_Array_Comparison_Op
5576      (Typ   : Entity_Id;
5577       Nod   : Node_Id)
5578       return  Node_Id
5579    is
5580       Loc : constant Source_Ptr := Sloc (Nod);
5581
5582       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
5583       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
5584       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
5585       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
5586
5587       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
5588
5589       Loop_Statement : Node_Id;
5590       Loop_Body      : Node_Id;
5591       If_Stat        : Node_Id;
5592       Inner_If       : Node_Id;
5593       Final_Expr     : Node_Id;
5594       Func_Body      : Node_Id;
5595       Func_Name      : Entity_Id;
5596       Formals        : List_Id;
5597       Length1        : Node_Id;
5598       Length2        : Node_Id;
5599
5600    begin
5601       --  if J = Y'last then
5602       --     exit;
5603       --  else
5604       --     J := index'succ (J);
5605       --  end if;
5606
5607       Inner_If :=
5608         Make_Implicit_If_Statement (Nod,
5609           Condition =>
5610             Make_Op_Eq (Loc,
5611               Left_Opnd => New_Reference_To (J, Loc),
5612               Right_Opnd =>
5613                 Make_Attribute_Reference (Loc,
5614                   Prefix => New_Reference_To (Y, Loc),
5615                   Attribute_Name => Name_Last)),
5616
5617           Then_Statements => New_List (
5618                 Make_Exit_Statement (Loc)),
5619
5620           Else_Statements =>
5621             New_List (
5622               Make_Assignment_Statement (Loc,
5623                 Name => New_Reference_To (J, Loc),
5624                 Expression =>
5625                   Make_Attribute_Reference (Loc,
5626                     Prefix => New_Reference_To (Index, Loc),
5627                     Attribute_Name => Name_Succ,
5628                     Expressions => New_List (New_Reference_To (J, Loc))))));
5629
5630       --  if X (I) = Y (J) then
5631       --     if ... end if;
5632       --  else
5633       --     return X (I) > Y (J);
5634       --  end if;
5635
5636       Loop_Body :=
5637         Make_Implicit_If_Statement (Nod,
5638           Condition =>
5639             Make_Op_Eq (Loc,
5640               Left_Opnd =>
5641                 Make_Indexed_Component (Loc,
5642                   Prefix      => New_Reference_To (X, Loc),
5643                   Expressions => New_List (New_Reference_To (I, Loc))),
5644
5645               Right_Opnd =>
5646                 Make_Indexed_Component (Loc,
5647                   Prefix      => New_Reference_To (Y, Loc),
5648                   Expressions => New_List (New_Reference_To (J, Loc)))),
5649
5650           Then_Statements => New_List (Inner_If),
5651
5652           Else_Statements => New_List (
5653             Make_Return_Statement (Loc,
5654               Expression =>
5655                 Make_Op_Gt (Loc,
5656                   Left_Opnd =>
5657                     Make_Indexed_Component (Loc,
5658                       Prefix      => New_Reference_To (X, Loc),
5659                       Expressions => New_List (New_Reference_To (I, Loc))),
5660
5661                   Right_Opnd =>
5662                     Make_Indexed_Component (Loc,
5663                       Prefix      => New_Reference_To (Y, Loc),
5664                       Expressions => New_List (
5665                         New_Reference_To (J, Loc)))))));
5666
5667       --  for I in X'range loop
5668       --     if ... end if;
5669       --  end loop;
5670
5671       Loop_Statement :=
5672         Make_Implicit_Loop_Statement (Nod,
5673           Identifier => Empty,
5674
5675           Iteration_Scheme =>
5676             Make_Iteration_Scheme (Loc,
5677               Loop_Parameter_Specification =>
5678                 Make_Loop_Parameter_Specification (Loc,
5679                   Defining_Identifier => I,
5680                   Discrete_Subtype_Definition =>
5681                     Make_Attribute_Reference (Loc,
5682                       Prefix => New_Reference_To (X, Loc),
5683                       Attribute_Name => Name_Range))),
5684
5685           Statements => New_List (Loop_Body));
5686
5687       --    if X'length = 0 then
5688       --       return false;
5689       --    elsif Y'length = 0 then
5690       --       return true;
5691       --    else
5692       --      for ... loop ... end loop;
5693       --      return X'length > Y'length;
5694       --    end if;
5695
5696       Length1 :=
5697         Make_Attribute_Reference (Loc,
5698           Prefix => New_Reference_To (X, Loc),
5699           Attribute_Name => Name_Length);
5700
5701       Length2 :=
5702         Make_Attribute_Reference (Loc,
5703           Prefix => New_Reference_To (Y, Loc),
5704           Attribute_Name => Name_Length);
5705
5706       Final_Expr :=
5707         Make_Op_Gt (Loc,
5708           Left_Opnd  => Length1,
5709           Right_Opnd => Length2);
5710
5711       If_Stat :=
5712         Make_Implicit_If_Statement (Nod,
5713           Condition =>
5714             Make_Op_Eq (Loc,
5715               Left_Opnd =>
5716                 Make_Attribute_Reference (Loc,
5717                   Prefix => New_Reference_To (X, Loc),
5718                   Attribute_Name => Name_Length),
5719               Right_Opnd =>
5720                 Make_Integer_Literal (Loc, 0)),
5721
5722           Then_Statements =>
5723             New_List (
5724               Make_Return_Statement (Loc,
5725                 Expression => New_Reference_To (Standard_False, Loc))),
5726
5727           Elsif_Parts => New_List (
5728             Make_Elsif_Part (Loc,
5729               Condition =>
5730                 Make_Op_Eq (Loc,
5731                   Left_Opnd =>
5732                     Make_Attribute_Reference (Loc,
5733                       Prefix => New_Reference_To (Y, Loc),
5734                       Attribute_Name => Name_Length),
5735                   Right_Opnd =>
5736                     Make_Integer_Literal (Loc, 0)),
5737
5738               Then_Statements =>
5739                 New_List (
5740                   Make_Return_Statement (Loc,
5741                      Expression => New_Reference_To (Standard_True, Loc))))),
5742
5743           Else_Statements => New_List (
5744             Loop_Statement,
5745             Make_Return_Statement (Loc,
5746               Expression => Final_Expr)));
5747
5748       --  (X : a; Y: a)
5749
5750       Formals := New_List (
5751         Make_Parameter_Specification (Loc,
5752           Defining_Identifier => X,
5753           Parameter_Type      => New_Reference_To (Typ, Loc)),
5754
5755         Make_Parameter_Specification (Loc,
5756           Defining_Identifier => Y,
5757           Parameter_Type      => New_Reference_To (Typ, Loc)));
5758
5759       --  function Gnnn (...) return boolean is
5760       --    J : index := Y'first;
5761       --  begin
5762       --    if ... end if;
5763       --  end Gnnn;
5764
5765       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
5766
5767       Func_Body :=
5768         Make_Subprogram_Body (Loc,
5769           Specification =>
5770             Make_Function_Specification (Loc,
5771               Defining_Unit_Name       => Func_Name,
5772               Parameter_Specifications => Formals,
5773               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
5774
5775           Declarations => New_List (
5776             Make_Object_Declaration (Loc,
5777               Defining_Identifier => J,
5778               Object_Definition   => New_Reference_To (Index, Loc),
5779               Expression =>
5780                 Make_Attribute_Reference (Loc,
5781                   Prefix => New_Reference_To (Y, Loc),
5782                   Attribute_Name => Name_First))),
5783
5784           Handled_Statement_Sequence =>
5785             Make_Handled_Sequence_Of_Statements (Loc,
5786               Statements => New_List (If_Stat)));
5787
5788       return Func_Body;
5789
5790    end Make_Array_Comparison_Op;
5791
5792    ---------------------------
5793    -- Make_Boolean_Array_Op --
5794    ---------------------------
5795
5796    --  For logical operations on boolean arrays, expand in line the
5797    --  following, replacing 'and' with 'or' or 'xor' where needed:
5798
5799    --    function Annn (A : typ; B: typ) return typ is
5800    --       C : typ;
5801    --    begin
5802    --       for J in A'range loop
5803    --          C (J) := A (J) op B (J);
5804    --       end loop;
5805    --       return C;
5806    --    end Annn;
5807
5808    --  Here typ is the boolean array type
5809
5810    function Make_Boolean_Array_Op
5811      (Typ  : Entity_Id;
5812       N    : Node_Id)
5813       return Node_Id
5814    is
5815       Loc : constant Source_Ptr := Sloc (N);
5816
5817       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
5818       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
5819       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
5820       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
5821
5822       A_J : Node_Id;
5823       B_J : Node_Id;
5824       C_J : Node_Id;
5825       Op  : Node_Id;
5826
5827       Formals        : List_Id;
5828       Func_Name      : Entity_Id;
5829       Func_Body      : Node_Id;
5830       Loop_Statement : Node_Id;
5831
5832    begin
5833       A_J :=
5834         Make_Indexed_Component (Loc,
5835           Prefix      => New_Reference_To (A, Loc),
5836           Expressions => New_List (New_Reference_To (J, Loc)));
5837
5838       B_J :=
5839         Make_Indexed_Component (Loc,
5840           Prefix      => New_Reference_To (B, Loc),
5841           Expressions => New_List (New_Reference_To (J, Loc)));
5842
5843       C_J :=
5844         Make_Indexed_Component (Loc,
5845           Prefix      => New_Reference_To (C, Loc),
5846           Expressions => New_List (New_Reference_To (J, Loc)));
5847
5848       if Nkind (N) = N_Op_And then
5849          Op :=
5850            Make_Op_And (Loc,
5851              Left_Opnd  => A_J,
5852              Right_Opnd => B_J);
5853
5854       elsif Nkind (N) = N_Op_Or then
5855          Op :=
5856            Make_Op_Or (Loc,
5857              Left_Opnd  => A_J,
5858              Right_Opnd => B_J);
5859
5860       else
5861          Op :=
5862            Make_Op_Xor (Loc,
5863              Left_Opnd  => A_J,
5864              Right_Opnd => B_J);
5865       end if;
5866
5867       Loop_Statement :=
5868         Make_Implicit_Loop_Statement (N,
5869           Identifier => Empty,
5870
5871           Iteration_Scheme =>
5872             Make_Iteration_Scheme (Loc,
5873               Loop_Parameter_Specification =>
5874                 Make_Loop_Parameter_Specification (Loc,
5875                   Defining_Identifier => J,
5876                   Discrete_Subtype_Definition =>
5877                     Make_Attribute_Reference (Loc,
5878                       Prefix => New_Reference_To (A, Loc),
5879                       Attribute_Name => Name_Range))),
5880
5881           Statements => New_List (
5882             Make_Assignment_Statement (Loc,
5883               Name       => C_J,
5884               Expression => Op)));
5885
5886       Formals := New_List (
5887         Make_Parameter_Specification (Loc,
5888           Defining_Identifier => A,
5889           Parameter_Type      => New_Reference_To (Typ, Loc)),
5890
5891         Make_Parameter_Specification (Loc,
5892           Defining_Identifier => B,
5893           Parameter_Type      => New_Reference_To (Typ, Loc)));
5894
5895       Func_Name :=
5896         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5897       Set_Is_Inlined (Func_Name);
5898
5899       Func_Body :=
5900         Make_Subprogram_Body (Loc,
5901           Specification =>
5902             Make_Function_Specification (Loc,
5903               Defining_Unit_Name       => Func_Name,
5904               Parameter_Specifications => Formals,
5905               Subtype_Mark             => New_Reference_To (Typ, Loc)),
5906
5907           Declarations => New_List (
5908             Make_Object_Declaration (Loc,
5909               Defining_Identifier => C,
5910               Object_Definition   => New_Reference_To (Typ, Loc))),
5911
5912           Handled_Statement_Sequence =>
5913             Make_Handled_Sequence_Of_Statements (Loc,
5914               Statements => New_List (
5915                 Loop_Statement,
5916                 Make_Return_Statement (Loc,
5917                   Expression => New_Reference_To (C, Loc)))));
5918
5919       return Func_Body;
5920    end Make_Boolean_Array_Op;
5921
5922    ------------------------
5923    -- Rewrite_Comparison --
5924    ------------------------
5925
5926    procedure Rewrite_Comparison (N : Node_Id) is
5927       Typ : constant Entity_Id := Etype (N);
5928       Op1 : constant Node_Id   := Left_Opnd (N);
5929       Op2 : constant Node_Id   := Right_Opnd (N);
5930
5931       Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
5932       --  Res indicates if compare outcome can be determined at compile time
5933
5934       True_Result  : Boolean;
5935       False_Result : Boolean;
5936
5937    begin
5938       case N_Op_Compare (Nkind (N)) is
5939          when N_Op_Eq =>
5940             True_Result  := Res = EQ;
5941             False_Result := Res = LT or else Res = GT or else Res = NE;
5942
5943          when N_Op_Ge =>
5944             True_Result  := Res in Compare_GE;
5945             False_Result := Res = LT;
5946
5947          when N_Op_Gt =>
5948             True_Result  := Res = GT;
5949             False_Result := Res in Compare_LE;
5950
5951          when N_Op_Lt =>
5952             True_Result  := Res = LT;
5953             False_Result := Res in Compare_GE;
5954
5955          when N_Op_Le =>
5956             True_Result  := Res in Compare_LE;
5957             False_Result := Res = GT;
5958
5959          when N_Op_Ne =>
5960             True_Result  := Res = NE;
5961             False_Result := Res = LT or else Res = GT or else Res = EQ;
5962       end case;
5963
5964       if True_Result then
5965          Rewrite (N,
5966            Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
5967          Analyze_And_Resolve (N, Typ);
5968          Warn_On_Known_Condition (N);
5969
5970       elsif False_Result then
5971          Rewrite (N,
5972            Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
5973          Analyze_And_Resolve (N, Typ);
5974          Warn_On_Known_Condition (N);
5975       end if;
5976    end Rewrite_Comparison;
5977
5978    -----------------------
5979    -- Tagged_Membership --
5980    -----------------------
5981
5982    --  There are two different cases to consider depending on whether
5983    --  the right operand is a class-wide type or not. If not we just
5984    --  compare the actual tag of the left expr to the target type tag:
5985    --
5986    --     Left_Expr.Tag = Right_Type'Tag;
5987    --
5988    --  If it is a class-wide type we use the RT function CW_Membership which
5989    --  is usually implemented by looking in the ancestor tables contained in
5990    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
5991
5992    function Tagged_Membership (N : Node_Id) return Node_Id is
5993       Left  : constant Node_Id    := Left_Opnd  (N);
5994       Right : constant Node_Id    := Right_Opnd (N);
5995       Loc   : constant Source_Ptr := Sloc (N);
5996
5997       Left_Type  : Entity_Id;
5998       Right_Type : Entity_Id;
5999       Obj_Tag    : Node_Id;
6000
6001    begin
6002       Left_Type  := Etype (Left);
6003       Right_Type := Etype (Right);
6004
6005       if Is_Class_Wide_Type (Left_Type) then
6006          Left_Type := Root_Type (Left_Type);
6007       end if;
6008
6009       Obj_Tag :=
6010         Make_Selected_Component (Loc,
6011           Prefix        => Relocate_Node (Left),
6012           Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
6013
6014       if Is_Class_Wide_Type (Right_Type) then
6015          return
6016            Make_DT_Access_Action (Left_Type,
6017              Action => CW_Membership,
6018              Args   => New_List (
6019                Obj_Tag,
6020                New_Reference_To (
6021                  Access_Disp_Table (Root_Type (Right_Type)), Loc)));
6022       else
6023          return
6024            Make_Op_Eq (Loc,
6025            Left_Opnd  => Obj_Tag,
6026            Right_Opnd =>
6027              New_Reference_To (Access_Disp_Table (Right_Type), Loc));
6028       end if;
6029
6030    end Tagged_Membership;
6031
6032    ------------------------------
6033    -- Unary_Op_Validity_Checks --
6034    ------------------------------
6035
6036    procedure Unary_Op_Validity_Checks (N : Node_Id) is
6037    begin
6038       if Validity_Checks_On and Validity_Check_Operands then
6039          Ensure_Valid (Right_Opnd (N));
6040       end if;
6041    end Unary_Op_Validity_Checks;
6042
6043 end Exp_Ch4;