gcc/ada/exp_ch4.adb

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