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 --                            $Revision: 1.3 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;    use Atree;
  30 with Checks;   use Checks;
  31 with Einfo;    use Einfo;
  32 with Elists;   use Elists;
  33 with Errout;   use Errout;
  34 with Exp_Aggr; use Exp_Aggr;
  35 with Exp_Ch3;  use Exp_Ch3;
  36 with Exp_Ch7;  use Exp_Ch7;
  37 with Exp_Ch9;  use Exp_Ch9;
  38 with Exp_Disp; use Exp_Disp;
  39 with Exp_Fixd; use Exp_Fixd;
  40 with Exp_Pakd; use Exp_Pakd;
  41 with Exp_Tss;  use Exp_Tss;
  42 with Exp_Util; use Exp_Util;
  43 with Exp_VFpt; use Exp_VFpt;
  44 with Hostparm; use Hostparm;
  45 with Inline;   use Inline;
  46 with Nlists;   use Nlists;
  47 with Nmake;    use Nmake;
  48 with Opt;      use Opt;
  49 with Rtsfind;  use Rtsfind;
  50 with Sem;      use Sem;
  51 with Sem_Cat;  use Sem_Cat;
  52 with Sem_Ch13; use Sem_Ch13;
  53 with Sem_Eval; use Sem_Eval;
  54 with Sem_Res;  use Sem_Res;
  55 with Sem_Type; use Sem_Type;
  56 with Sem_Util; use Sem_Util;
  57 with Sinfo;    use Sinfo;
  58 with Sinfo.CN; use Sinfo.CN;
  59 with Snames;   use Snames;
  60 with Stand;    use Stand;
  61 with Tbuild;   use Tbuild;
  62 with Ttypes;   use Ttypes;
  63 with Uintp;    use Uintp;
  64 with Urealp;   use Urealp;
  65 with Validsw;  use Validsw;
  66
  67 package body Exp_Ch4 is
  68
  69    ------------------------
  70    --  Local Subprograms --
  71    ------------------------
  72
  73    procedure Binary_Op_Validity_Checks (N : Node_Id);
  74    pragma Inline (Binary_Op_Validity_Checks);
  75    --  Performs validity checks for a binary operator
  76
  77    procedure Expand_Array_Comparison (N : Node_Id);
  78    --  This routine handles expansion of the comparison operators (N_Op_Lt,
  79    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
  80    --  code for these operators is similar, differing only in the details of
  81    --  the actual comparison call that is made.
  82
  83    function Expand_Array_Equality
  84      (Nod    : Node_Id;
  85       Typ    : Entity_Id;
  86       A_Typ  : Entity_Id;
  87       Lhs    : Node_Id;
  88       Rhs    : Node_Id;
  89       Bodies : List_Id)
  90       return   Node_Id;
  91    --  Expand an array equality into a call to a function implementing this
  92    --  equality, and a call to it. Loc is the location for the generated
  93    --  nodes. Typ is the type of the array, and Lhs, Rhs are the array
  94    --  expressions to be compared. A_Typ is the type of the arguments,
  95    --  which may be a private type, in which case Typ is its full view.
  96    --  Bodies is a list on which to attach bodies of local functions that
  97    --  are created in the process. This is the responsability of the
  98    --  caller to insert those bodies at the right place. Nod provides
  99    --  the Sloc value for the generated code.
 100
 101    procedure Expand_Boolean_Operator (N : Node_Id);
 102    --  Common expansion processing for Boolean operators (And, Or, Xor)
 103    --  for the case of array type arguments.
 104
 105    function Expand_Composite_Equality
 106      (Nod    : Node_Id;
 107       Typ    : Entity_Id;
 108       Lhs    : Node_Id;
 109       Rhs    : Node_Id;
 110       Bodies : List_Id)
 111       return   Node_Id;
 112    --  Local recursive function used to expand equality for nested
 113    --  composite types. Used by Expand_Record/Array_Equality, Bodies
 114    --  is a list on which to attach bodies of local functions that are
 115    --  created in the process. This is the responsability of the caller
 116    --  to insert those bodies at the right place. Nod provides the Sloc
 117    --  value for generated code.
 118
 119    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
 120    --  This routine handles expansion of concatenation operations, where
 121    --  N is the N_Op_Concat node being expanded and Operands is the list
 122    --  of operands (at least two are present). The caller has dealt with
 123    --  converting any singleton operands into singleton aggregates.
 124
 125    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
 126    --  Routine to expand concatenation of 2-5 operands (in the list Operands)
 127    --  and replace node Cnode with the result of the contatenation. If there
 128    --  are two operands, they can be string or character. If there are more
 129    --  than two operands, then are always of type string (i.e. the caller has
 130    --  already converted character operands to strings in this case).
 131
 132    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
 133    --  N is either an N_Op_Divide or N_Op_Multiply node whose result is
 134    --  universal fixed. We do not have such a type at runtime, so the
 135    --  purpose of this routine is to find the real type by looking up
 136    --  the tree. We also determine if the operation must be rounded.
 137
 138    procedure Insert_Dereference_Action (N : Node_Id);
 139    --  N is an expression whose type is an access. When the type is derived
 140    --  from Checked_Pool, expands a call to the primitive 'dereference'.
 141
 142    function Make_Array_Comparison_Op
 143      (Typ   : Entity_Id;
 144       Nod   : Node_Id)
 145       return  Node_Id;
 146    --  Comparisons between arrays are expanded in line. This function
 147    --  produces the body of the implementation of (a > b), where a and b
 148    --  are one-dimensional arrays of some discrete type. The original
 149    --  node is then expanded into the appropriate call to this function.
 150    --  Nod provides the Sloc value for the generated code.
 151
 152    function Make_Boolean_Array_Op
 153      (Typ  : Entity_Id;
 154       N    : Node_Id)
 155       return Node_Id;
 156    --  Boolean operations on boolean arrays are expanded in line. This
 157    --  function produce the body for the node N, which is (a and b),
 158    --  (a or b), or (a xor b). It is used only the normal case and not
 159    --  the packed case. The type involved, Typ, is the Boolean array type,
 160    --  and the logical operations in the body are simple boolean operations.
 161    --  Note that Typ is always a constrained type (the caller has ensured
 162    --  this by using Convert_To_Actual_Subtype if necessary).
 163
 164    procedure Rewrite_Comparison (N : Node_Id);
 165    --  N is the node for a compile time comparison. If this outcome of this
 166    --  comparison can be determined at compile time, then the node N can be
 167    --  rewritten with True or False. If the outcome cannot be determined at
 168    --  compile time, the call has no effect.
 169
 170    function Tagged_Membership (N : Node_Id) return Node_Id;
 171    --  Construct the expression corresponding to the tagged membership test.
 172    --  Deals with a second operand being (or not) a class-wide type.
 173
 174    procedure Unary_Op_Validity_Checks (N : Node_Id);
 175    pragma Inline (Unary_Op_Validity_Checks);
 176    --  Performs validity checks for a unary operator
 177
 178    -------------------------------
 179    -- Binary_Op_Validity_Checks --
 180    -------------------------------
 181
 182    procedure Binary_Op_Validity_Checks (N : Node_Id) is
 183    begin
 184       if Validity_Checks_On and Validity_Check_Operands then
 185          Ensure_Valid (Left_Opnd (N));
 186          Ensure_Valid (Right_Opnd (N));
 187       end if;
 188    end Binary_Op_Validity_Checks;
 189
 190    -----------------------------
 191    -- Expand_Array_Comparison --
 192    -----------------------------
 193
 194    --  Expansion is only required in the case of array types. The form of
 195    --  the expansion is:
 196
 197    --     [body for greater_nn; boolean_expression]
 198
 199    --  The body is built by Make_Array_Comparison_Op, and the form of the
 200    --  Boolean expression depends on the operator involved.
 201
 202    procedure Expand_Array_Comparison (N : Node_Id) is
 203       Loc  : constant Source_Ptr := Sloc (N);
 204       Op1  : Node_Id             := Left_Opnd (N);
 205       Op2  : Node_Id             := Right_Opnd (N);
 206       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
 207
 208       Expr      : Node_Id;
 209       Func_Body : Node_Id;
 210       Func_Name : Entity_Id;
 211
 212    begin
 213       --  For (a <= b) we convert to not (a > b)
 214
 215       if Chars (N) = Name_Op_Le then
 216          Rewrite (N,
 217            Make_Op_Not (Loc,
 218              Right_Opnd =>
 219                 Make_Op_Gt (Loc,
 220                  Left_Opnd  => Op1,
 221                  Right_Opnd => Op2)));
 222          Analyze_And_Resolve (N, Standard_Boolean);
 223          return;
 224
 225       --  For < the Boolean expression is
 226       --    greater__nn (op2, op1)
 227
 228       elsif Chars (N) = Name_Op_Lt then
 229          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 230
 231          --  Switch operands
 232
 233          Op1 := Right_Opnd (N);
 234          Op2 := Left_Opnd  (N);
 235
 236       --  For (a >= b) we convert to not (a < b)
 237
 238       elsif Chars (N) = Name_Op_Ge then
 239          Rewrite (N,
 240            Make_Op_Not (Loc,
 241              Right_Opnd =>
 242                Make_Op_Lt (Loc,
 243                  Left_Opnd  => Op1,
 244                  Right_Opnd => Op2)));
 245          Analyze_And_Resolve (N, Standard_Boolean);
 246          return;
 247
 248       --  For > the Boolean expression is
 249       --    greater__nn (op1, op2)
 250
 251       else
 252          pragma Assert (Chars (N) = Name_Op_Gt);
 253          Func_Body := Make_Array_Comparison_Op (Typ1, N);
 254       end if;
 255
 256       Func_Name := Defining_Unit_Name (Specification (Func_Body));
 257       Expr :=
 258         Make_Function_Call (Loc,
 259           Name => New_Reference_To (Func_Name, Loc),
 260           Parameter_Associations => New_List (Op1, Op2));
 261
 262       Insert_Action (N, Func_Body);
 263       Rewrite (N, Expr);
 264       Analyze_And_Resolve (N, Standard_Boolean);
 265
 266    end Expand_Array_Comparison;
 267
 268    ---------------------------
 269    -- Expand_Array_Equality --
 270    ---------------------------
 271
 272    --  Expand an equality function for multi-dimensional arrays. Here is
 273    --  an example of such a function for Nb_Dimension = 2
 274
 275    --  function Enn (A : arr; B : arr) return boolean is
 276    --     J1 : integer;
 277    --     J2 : integer;
 278    --
 279    --  begin
 280    --     if A'length (1) /= B'length (1) then
 281    --        return false;
 282    --     else
 283    --        J1 := B'first (1);
 284    --        for I1 in A'first (1) .. A'last (1) loop
 285    --           if A'length (2) /= B'length (2) then
 286    --              return false;
 287    --           else
 288    --              J2 := B'first (2);
 289    --              for I2 in A'first (2) .. A'last (2) loop
 290    --                 if A (I1, I2) /=  B (J1, J2) then
 291    --                    return false;
 292    --                 end if;
 293    --                 J2 := Integer'succ (J2);
 294    --              end loop;
 295    --           end if;
 296    --           J1 := Integer'succ (J1);
 297    --        end loop;
 298    --     end if;
 299    --     return true;
 300    --  end Enn;
 301
 302    function Expand_Array_Equality
 303      (Nod    : Node_Id;
 304       Typ    : Entity_Id;
 305       A_Typ  : Entity_Id;
 306       Lhs    : Node_Id;
 307       Rhs    : Node_Id;
 308       Bodies : List_Id)
 309       return   Node_Id
 310    is
 311       Loc         : constant Source_Ptr := Sloc (Nod);
 312       Actuals     : List_Id;
 313       Decls       : List_Id := New_List;
 314       Index_List1 : List_Id := New_List;
 315       Index_List2 : List_Id := New_List;
 316       Formals     : List_Id;
 317       Stats       : Node_Id;
 318       Func_Name   : Entity_Id;
 319       Func_Body   : Node_Id;
 320
 321       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
 322       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
 323
 324       function Component_Equality (Typ : Entity_Id) return Node_Id;
 325       --  Create one statement to compare corresponding components, designated
 326       --  by a full set of indices.
 327
 328       function Loop_One_Dimension
 329         (N     : Int;
 330          Index : Node_Id)
 331          return Node_Id;
 332       --  Loop over the n'th dimension of the arrays. The single statement
 333       --  in the body of the loop is a loop over the next dimension, or
 334       --  the comparison of corresponding components.
 335
 336       ------------------------
 337       -- Component_Equality --
 338       ------------------------
 339
 340       function Component_Equality (Typ : Entity_Id) return Node_Id is
 341          Test : Node_Id;
 342          L, R : Node_Id;
 343
 344       begin
 345          --  if a(i1...) /= b(j1...) then return false; end if;
 346
 347          L :=
 348            Make_Indexed_Component (Loc,
 349              Prefix => Make_Identifier (Loc, Chars (A)),
 350              Expressions => Index_List1);
 351
 352          R :=
 353            Make_Indexed_Component (Loc,
 354              Prefix => Make_Identifier (Loc, Chars (B)),
 355              Expressions => Index_List2);
 356
 357          Test := Expand_Composite_Equality
 358                    (Nod, Component_Type (Typ), L, R, Decls);
 359
 360          return
 361            Make_Implicit_If_Statement (Nod,
 362              Condition => Make_Op_Not (Loc, Right_Opnd => Test),
 363              Then_Statements => New_List (
 364                Make_Return_Statement (Loc,
 365                  Expression => New_Occurrence_Of (Standard_False, Loc))));
 366
 367       end Component_Equality;
 368
 369       ------------------------
 370       -- Loop_One_Dimension --
 371       ------------------------
 372
 373       function Loop_One_Dimension
 374         (N     : Int;
 375          Index : Node_Id)
 376          return Node_Id
 377       is
 378          I : constant Entity_Id := Make_Defining_Identifier (Loc,
 379                                                   New_Internal_Name ('I'));
 380          J : constant Entity_Id := Make_Defining_Identifier (Loc,
 381                                                   New_Internal_Name ('J'));
 382          Index_Type  : Entity_Id;
 383          Stats : Node_Id;
 384
 385       begin
 386          if N > Number_Dimensions (Typ) then
 387             return Component_Equality (Typ);
 388
 389          else
 390             --  Generate the following:
 391
 392             --  j: index_type;
 393             --  ...
 394
 395             --  if a'length (n) /= b'length (n) then
 396             --    return false;
 397             --  else
 398             --     j := b'first (n);
 399             --     for i in a'range (n) loop
 400             --        --  loop over remaining dimensions.
 401             --        j := index_type'succ (j);
 402             --     end loop;
 403             --  end if;
 404
 405             --  retrieve index type for current dimension.
 406
 407             Index_Type := Base_Type (Etype (Index));
 408             Append (New_Reference_To (I, Loc), Index_List1);
 409             Append (New_Reference_To (J, Loc), Index_List2);
 410
 411             --  Declare index for j as a local variable to the function.
 412             --  Index i is a loop variable.
 413
 414             Append_To (Decls,
 415               Make_Object_Declaration (Loc,
 416                 Defining_Identifier => J,
 417                 Object_Definition   => New_Reference_To (Index_Type, Loc)));
 418
 419             Stats :=
 420               Make_Implicit_If_Statement (Nod,
 421                 Condition =>
 422                   Make_Op_Ne (Loc,
 423                     Left_Opnd =>
 424                       Make_Attribute_Reference (Loc,
 425                         Prefix => New_Reference_To (A, Loc),
 426                         Attribute_Name => Name_Length,
 427                         Expressions => New_List (
 428                           Make_Integer_Literal (Loc, N))),
 429                     Right_Opnd =>
 430                       Make_Attribute_Reference (Loc,
 431                         Prefix => New_Reference_To (B, Loc),
 432                         Attribute_Name => Name_Length,
 433                         Expressions => New_List (
 434                           Make_Integer_Literal (Loc, N)))),
 435
 436                 Then_Statements => New_List (
 437                   Make_Return_Statement (Loc,
 438                     Expression => New_Occurrence_Of (Standard_False, Loc))),
 439
 440                 Else_Statements => New_List (
 441
 442                   Make_Assignment_Statement (Loc,
 443                     Name       => New_Reference_To (J, Loc),
 444                     Expression =>
 445                       Make_Attribute_Reference (Loc,
 446                         Prefix => New_Reference_To (B, Loc),
 447                         Attribute_Name => Name_First,
 448                         Expressions => New_List (
 449                           Make_Integer_Literal (Loc, N)))),
 450
 451                   Make_Implicit_Loop_Statement (Nod,
 452                     Identifier => Empty,
 453                     Iteration_Scheme =>
 454                       Make_Iteration_Scheme (Loc,
 455                         Loop_Parameter_Specification =>
 456                           Make_Loop_Parameter_Specification (Loc,
 457                             Defining_Identifier => I,
 458                             Discrete_Subtype_Definition =>
 459                               Make_Attribute_Reference (Loc,
 460                                 Prefix => New_Reference_To (A, Loc),
 461                                 Attribute_Name => Name_Range,
 462                                 Expressions => New_List (
 463                                   Make_Integer_Literal (Loc, N))))),
 464
 465                     Statements => New_List (
 466                       Loop_One_Dimension (N + 1, Next_Index (Index)),
 467                       Make_Assignment_Statement (Loc,
 468                         Name => New_Reference_To (J, Loc),
 469                         Expression =>
 470                           Make_Attribute_Reference (Loc,
 471                             Prefix => New_Reference_To (Index_Type, Loc),
 472                             Attribute_Name => Name_Succ,
 473                             Expressions => New_List (
 474                               New_Reference_To (J, Loc))))))));
 475
 476             return Stats;
 477          end if;
 478       end Loop_One_Dimension;
 479
 480    --  Start of processing for Expand_Array_Equality
 481
 482    begin
 483       Formals := New_List (
 484         Make_Parameter_Specification (Loc,
 485           Defining_Identifier => A,
 486           Parameter_Type      => New_Reference_To (Typ, Loc)),
 487
 488         Make_Parameter_Specification (Loc,
 489           Defining_Identifier => B,
 490           Parameter_Type      => New_Reference_To (Typ, Loc)));
 491
 492       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
 493
 494       Stats := Loop_One_Dimension (1, First_Index (Typ));
 495
 496       Func_Body :=
 497         Make_Subprogram_Body (Loc,
 498           Specification =>
 499             Make_Function_Specification (Loc,
 500               Defining_Unit_Name       => Func_Name,
 501               Parameter_Specifications => Formals,
 502               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
 503           Declarations               =>  Decls,
 504           Handled_Statement_Sequence =>
 505             Make_Handled_Sequence_Of_Statements (Loc,
 506               Statements => New_List (
 507                 Stats,
 508                 Make_Return_Statement (Loc,
 509                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
 510
 511          Set_Has_Completion (Func_Name, True);
 512
 513          --  If the array type is distinct from the type of the arguments,
 514          --  it is the full view of a private type. Apply an unchecked
 515          --  conversion to insure that analysis of the call succeeds.
 516
 517          if Base_Type (A_Typ) /= Base_Type (Typ) then
 518             Actuals := New_List (
 519               OK_Convert_To (Typ, Lhs),
 520               OK_Convert_To (Typ, Rhs));
 521          else
 522             Actuals := New_List (Lhs, Rhs);
 523          end if;
 524
 525          Append_To (Bodies, Func_Body);
 526
 527          return
 528            Make_Function_Call (Loc,
 529              Name => New_Reference_To (Func_Name, Loc),
 530              Parameter_Associations => Actuals);
 531    end Expand_Array_Equality;
 532
 533    -----------------------------
 534    -- Expand_Boolean_Operator --
 535    -----------------------------
 536
 537    --  Note that we first get the actual subtypes of the operands,
 538    --  since we always want to deal with types that have bounds.
 539
 540    procedure Expand_Boolean_Operator (N : Node_Id) is
 541       Typ       : constant Entity_Id  := Etype (N);
 542
 543    begin
 544       if Is_Bit_Packed_Array (Typ) then
 545          Expand_Packed_Boolean_Operator (N);
 546
 547       else
 548
 549          --  For the normal non-packed case, the expansion is
 550          --  to build a function for carrying out the comparison
 551          --  (using Make_Boolean_Array_Op) and then inserting it
 552          --  into the tree. The original operator node is then
 553          --  rewritten as a call to this function.
 554
 555          declare
 556             Loc       : constant Source_Ptr := Sloc (N);
 557             L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
 558             R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
 559             Func_Body : Node_Id;
 560             Func_Name : Entity_Id;
 561          begin
 562             Convert_To_Actual_Subtype (L);
 563             Convert_To_Actual_Subtype (R);
 564             Ensure_Defined (Etype (L), N);
 565             Ensure_Defined (Etype (R), N);
 566             Apply_Length_Check (R, Etype (L));
 567
 568             Func_Body := Make_Boolean_Array_Op (Etype (L), N);
 569             Func_Name := Defining_Unit_Name (Specification (Func_Body));
 570             Insert_Action (N, Func_Body);
 571
 572             --  Now rewrite the expression with a call
 573
 574             Rewrite (N,
 575               Make_Function_Call (Loc,
 576                 Name => New_Reference_To (Func_Name, Loc),
 577                 Parameter_Associations =>
 578                   New_List
 579                     (L, Make_Type_Conversion
 580                           (Loc, New_Reference_To (Etype (L), Loc), R))));
 581
 582             Analyze_And_Resolve (N, Typ);
 583          end;
 584       end if;
 585    end Expand_Boolean_Operator;
 586
 587    -------------------------------
 588    -- Expand_Composite_Equality --
 589    -------------------------------
 590
 591    --  This function is only called for comparing internal fields of composite
 592    --  types when these fields are themselves composites. This is a special
 593    --  case because it is not possible to respect normal Ada visibility rules.
 594
 595    function Expand_Composite_Equality
 596      (Nod    : Node_Id;
 597       Typ    : Entity_Id;
 598       Lhs    : Node_Id;
 599       Rhs    : Node_Id;
 600       Bodies : List_Id)
 601       return   Node_Id
 602    is
 603       Loc       : constant Source_Ptr := Sloc (Nod);
 604       Full_Type : Entity_Id;
 605       Prim      : Elmt_Id;
 606       Eq_Op     : Entity_Id;
 607
 608    begin
 609       if Is_Private_Type (Typ) then
 610          Full_Type := Underlying_Type (Typ);
 611       else
 612          Full_Type := Typ;
 613       end if;
 614
 615       --  Defense against malformed private types with no completion
 616       --  the error will be diagnosed later by check_completion
 617
 618       if No (Full_Type) then
 619          return New_Reference_To (Standard_False, Loc);
 620       end if;
 621
 622       Full_Type := Base_Type (Full_Type);
 623
 624       if Is_Array_Type (Full_Type) then
 625
 626          --  If the operand is an elementary type other than a floating-point
 627          --  type, then we can simply use the built-in block bitwise equality,
 628          --  since the predefined equality operators always apply and bitwise
 629          --  equality is fine for all these cases.
 630
 631          if Is_Elementary_Type (Component_Type (Full_Type))
 632            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
 633          then
 634             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
 635
 636          --  For composite component types, and floating-point types, use
 637          --  the expansion. This deals with tagged component types (where
 638          --  we use the applicable equality routine) and floating-point,
 639          --  (where we need to worry about negative zeroes), and also the
 640          --  case of any composite type recursively containing such fields.
 641
 642          else
 643             return Expand_Array_Equality
 644                      (Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
 645          end if;
 646
 647       elsif Is_Tagged_Type (Full_Type) then
 648
 649          --  Call the primitive operation "=" of this type
 650
 651          if Is_Class_Wide_Type (Full_Type) then
 652             Full_Type := Root_Type (Full_Type);
 653          end if;
 654
 655          --  If this is derived from an untagged private type completed
 656          --  with a tagged type, it does not have a full view, so we
 657          --  use the primitive operations of the private type.
 658          --  This check should no longer be necessary when these
 659          --  types receive their full views ???
 660
 661          if Is_Private_Type (Typ)
 662            and then not Is_Tagged_Type (Typ)
 663            and then not Is_Controlled (Typ)
 664            and then Is_Derived_Type (Typ)
 665            and then No (Full_View (Typ))
 666          then
 667             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
 668          else
 669             Prim := First_Elmt (Primitive_Operations (Full_Type));
 670          end if;
 671
 672          loop
 673             Eq_Op := Node (Prim);
 674             exit when Chars (Eq_Op) = Name_Op_Eq
 675               and then Etype (First_Formal (Eq_Op)) =
 676                        Etype (Next_Formal (First_Formal (Eq_Op)));
 677             Next_Elmt (Prim);
 678             pragma Assert (Present (Prim));
 679          end loop;
 680
 681          Eq_Op := Node (Prim);
 682
 683          return
 684            Make_Function_Call (Loc,
 685              Name => New_Reference_To (Eq_Op, Loc),
 686              Parameter_Associations =>
 687                New_List
 688                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
 689                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
 690
 691       elsif Is_Record_Type (Full_Type) then
 692          Eq_Op := TSS (Full_Type, Name_uEquality);
 693
 694          if Present (Eq_Op) then
 695             if Etype (First_Formal (Eq_Op)) /= Full_Type then
 696
 697                --  Inherited equality from parent type. Convert the actuals
 698                --  to match signature of operation.
 699
 700                declare
 701                   T : Entity_Id := Etype (First_Formal (Eq_Op));
 702
 703                begin
 704                   return
 705                     Make_Function_Call (Loc,
 706                       Name => New_Reference_To (Eq_Op, Loc),
 707                       Parameter_Associations =>
 708                         New_List (OK_Convert_To (T, Lhs),
 709                                   OK_Convert_To (T, Rhs)));
 710                end;
 711
 712             else
 713                return
 714                  Make_Function_Call (Loc,
 715                    Name => New_Reference_To (Eq_Op, Loc),
 716                    Parameter_Associations => New_List (Lhs, Rhs));
 717             end if;
 718
 719          else
 720             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
 721          end if;
 722
 723       else
 724          --  It can be a simple record or the full view of a scalar private
 725
 726          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
 727       end if;
 728    end Expand_Composite_Equality;
 729
 730    ------------------------------
 731    -- Expand_Concatenate_Other --
 732    ------------------------------
 733
 734    --  Let n be the number of array operands to be concatenated, Base_Typ
 735    --  their base type, Ind_Typ their index type, and Arr_Typ the original
 736    --  array type to which the concatenantion operator applies, then the
 737    --  following subprogram is constructed:
 738    --
 739    --  [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
 740    --      L : Ind_Typ;
 741    --   begin
 742    --      if S1'Length /= 0 then
 743    --         L := XXX;   -->  XXX = S1'First       if Arr_Typ is unconstrained
 744    --                          XXX = Arr_Typ'First  otherwise
 745    --      elsif S2'Length /= 0 then
 746    --         L := YYY;   -->  YYY = S2'First       if Arr_Typ is unconstrained
 747    --                          YYY = Arr_Typ'First  otherwise
 748    --      ...
 749    --      elsif Sn-1'Length /= 0 then
 750    --         L := ZZZ;   -->  ZZZ = Sn-1'First     if Arr_Typ is unconstrained
 751    --                          ZZZ = Arr_Typ'First  otherwise
 752    --      else
 753    --         return Sn;
 754    --      end if;
 755    --
 756    --      declare
 757    --         P : Ind_Typ;
 758    --         H : Ind_Typ :=
 759    --          Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
 760    --                       + Ind_Typ'Pos (L));
 761    --         R : Base_Typ (L .. H);
 762    --      begin
 763    --         if S1'Length /= 0 then
 764    --            P := S1'First;
 765    --            loop
 766    --               R (L) := S1 (P);
 767    --               L := Ind_Typ'Succ (L);
 768    --               exit when P = S1'Last;
 769    --               P := Ind_Typ'Succ (P);
 770    --            end loop;
 771    --         end if;
 772    --
 773    --         if S2'Length /= 0 then
 774    --            L := Ind_Typ'Succ (L);
 775    --            loop
 776    --               R (L) := S2 (P);
 777    --               L := Ind_Typ'Succ (L);
 778    --               exit when P = S2'Last;
 779    --               P := Ind_Typ'Succ (P);
 780    --            end loop;
 781    --         end if;
 782    --
 783    --         ...
 784    --
 785    --         if Sn'Length /= 0 then
 786    --            P := Sn'First;
 787    --            loop
 788    --               R (L) := Sn (P);
 789    --               L := Ind_Typ'Succ (L);
 790    --               exit when P = Sn'Last;
 791    --               P := Ind_Typ'Succ (P);
 792    --            end loop;
 793    --         end if;
 794    --
 795    --         return R;
 796    --      end;
 797    --   end Cnn;]
 798
 799    procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
 800       Loc      : constant Source_Ptr := Sloc (Cnode);
 801       Nb_Opnds : constant Nat        := List_Length (Opnds);
 802
 803       Arr_Typ  : constant Entity_Id := Etype (Entity (Cnode));
 804       Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
 805       Ind_Typ  : constant Entity_Id := Etype (First_Index (Base_Typ));
 806
 807       Func_Id     : Node_Id;
 808       Func_Spec   : Node_Id;
 809       Param_Specs : List_Id;
 810
 811       Func_Body  : Node_Id;
 812       Func_Decls : List_Id;
 813       Func_Stmts : List_Id;
 814
 815       L_Decl     : Node_Id;
 816
 817       If_Stmt    : Node_Id;
 818       Elsif_List : List_Id;
 819
 820       Declare_Block : Node_Id;
 821       Declare_Decls : List_Id;
 822       Declare_Stmts : List_Id;
 823
 824       H_Decl   : Node_Id;
 825       H_Init   : Node_Id;
 826       P_Decl   : Node_Id;
 827       R_Decl   : Node_Id;
 828       R_Constr : Node_Id;
 829       R_Range  : Node_Id;
 830
 831       Params  : List_Id;
 832       Operand : Node_Id;
 833
 834       function Copy_Into_R_S (I : Nat) return List_Id;
 835       --  Builds the sequence of statement:
 836       --    P := Si'First;
 837       --    loop
 838       --       R (L) := Si (P);
 839       --       L := Ind_Typ'Succ (L);
 840       --       exit when P = Si'Last;
 841       --       P := Ind_Typ'Succ (P);
 842       --    end loop;
 843       --
 844       --  where i is the input parameter I given.
 845
 846       function Init_L (I : Nat) return Node_Id;
 847       --  Builds the statement:
 848       --    L := Arr_Typ'First;  If Arr_Typ is constrained
 849       --    L := Si'First;       otherwise (where I is the input param given)
 850
 851       function H return Node_Id;
 852       --  Builds reference to identifier H.
 853
 854       function Ind_Val (E : Node_Id) return Node_Id;
 855       --  Builds expression Ind_Typ'Val (E);
 856
 857       function L return Node_Id;
 858       --  Builds reference to identifier L.
 859
 860       function L_Pos return Node_Id;
 861       --  Builds expression Ind_Typ'Pos (L).
 862
 863       function L_Succ return Node_Id;
 864       --  Builds expression Ind_Typ'Succ (L).
 865
 866       function One return Node_Id;
 867       --  Builds integer literal one.
 868
 869       function P return Node_Id;
 870       --  Builds reference to identifier P.
 871
 872       function P_Succ return Node_Id;
 873       --  Builds expression Ind_Typ'Succ (P).
 874
 875       function R return Node_Id;
 876       --  Builds reference to identifier R.
 877
 878       function S (I : Nat) return Node_Id;
 879       --  Builds reference to identifier Si, where I is the value given.
 880
 881       function S_First (I : Nat) return Node_Id;
 882       --  Builds expression Si'First, where I is the value given.
 883
 884       function S_Last (I : Nat) return Node_Id;
 885       --  Builds expression Si'Last, where I is the value given.
 886
 887       function S_Length (I : Nat) return Node_Id;
 888       --  Builds expression Si'Length, where I is the value given.
 889
 890       function S_Length_Test (I : Nat) return Node_Id;
 891       --  Builds expression Si'Length /= 0, where I is the value given.
 892
 893       -------------------
 894       -- Copy_Into_R_S --
 895       -------------------
 896
 897       function Copy_Into_R_S (I : Nat) return List_Id is
 898          Stmts     : List_Id := New_List;
 899          P_Start   : Node_Id;
 900          Loop_Stmt : Node_Id;
 901          R_Copy    : Node_Id;
 902          Exit_Stmt : Node_Id;
 903          L_Inc     : Node_Id;
 904          P_Inc     : Node_Id;
 905
 906       begin
 907          --  First construct the initializations
 908
 909          P_Start := Make_Assignment_Statement (Loc,
 910                       Name       => P,
 911                       Expression => S_First (I));
 912          Append_To (Stmts, P_Start);
 913
 914          --  Then build the loop
 915
 916          R_Copy := Make_Assignment_Statement (Loc,
 917                      Name       => Make_Indexed_Component (Loc,
 918                                      Prefix      => R,
 919                                      Expressions => New_List (L)),
 920                      Expression => Make_Indexed_Component (Loc,
 921                                      Prefix      => S (I),
 922                                      Expressions => New_List (P)));
 923
 924          L_Inc := Make_Assignment_Statement (Loc,
 925                     Name       => L,
 926                     Expression => L_Succ);
 927
 928          Exit_Stmt := Make_Exit_Statement (Loc,
 929                         Condition => Make_Op_Eq (Loc, P, S_Last (I)));
 930
 931          P_Inc := Make_Assignment_Statement (Loc,
 932                     Name       => P,
 933                     Expression => P_Succ);
 934
 935          Loop_Stmt :=
 936            Make_Implicit_Loop_Statement (Cnode,
 937              Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
 938
 939          Append_To (Stmts, Loop_Stmt);
 940
 941          return Stmts;
 942       end Copy_Into_R_S;
 943
 944       -------
 945       -- H --
 946       -------
 947
 948       function H return Node_Id is
 949       begin
 950          return Make_Identifier (Loc, Name_uH);
 951       end H;
 952
 953       -------------
 954       -- Ind_Val --
 955       -------------
 956
 957       function Ind_Val (E : Node_Id) return Node_Id is
 958       begin
 959          return
 960            Make_Attribute_Reference (Loc,
 961              Prefix         => New_Reference_To (Ind_Typ, Loc),
 962              Attribute_Name => Name_Val,
 963              Expressions    => New_List (E));
 964       end Ind_Val;
 965
 966       ------------
 967       -- Init_L --
 968       ------------
 969
 970       function Init_L (I : Nat) return Node_Id is
 971          E : Node_Id;
 972
 973       begin
 974          if Is_Constrained (Arr_Typ) then
 975             E := Make_Attribute_Reference (Loc,
 976                    Prefix         => New_Reference_To (Arr_Typ, Loc),
 977                    Attribute_Name => Name_First);
 978
 979          else
 980             E := S_First (I);
 981          end if;
 982
 983          return Make_Assignment_Statement (Loc, Name => L, Expression => E);
 984       end Init_L;
 985
 986       -------
 987       -- L --
 988       -------
 989
 990       function L return Node_Id is
 991       begin
 992          return Make_Identifier (Loc, Name_uL);
 993       end L;
 994
 995       -----------
 996       -- L_Pos --
 997       -----------
 998
 999       function L_Pos return Node_Id is
1000       begin
1001          return
1002            Make_Attribute_Reference (Loc,
1003              Prefix         => New_Reference_To (Ind_Typ, Loc),
1004              Attribute_Name => Name_Pos,
1005              Expressions    => New_List (L));
1006       end L_Pos;
1007
1008       ------------
1009       -- L_Succ --
1010       ------------
1011
1012       function L_Succ return Node_Id is
1013       begin
1014          return
1015            Make_Attribute_Reference (Loc,
1016              Prefix         => New_Reference_To (Ind_Typ, Loc),
1017              Attribute_Name => Name_Succ,
1018              Expressions    => New_List (L));
1019       end L_Succ;
1020
1021       ---------
1022       -- One --
1023       ---------
1024
1025       function One return Node_Id is
1026       begin
1027          return Make_Integer_Literal (Loc, 1);
1028       end One;
1029
1030       -------
1031       -- P --
1032       -------
1033
1034       function P return Node_Id is
1035       begin
1036          return Make_Identifier (Loc, Name_uP);
1037       end P;
1038
1039       ------------
1040       -- P_Succ --
1041       ------------
1042
1043       function P_Succ return Node_Id is
1044       begin
1045          return
1046            Make_Attribute_Reference (Loc,
1047              Prefix         => New_Reference_To (Ind_Typ, Loc),
1048              Attribute_Name => Name_Succ,
1049              Expressions    => New_List (P));
1050       end P_Succ;
1051
1052       -------
1053       -- R --
1054       -------
1055
1056       function R return Node_Id is
1057       begin
1058          return Make_Identifier (Loc, Name_uR);
1059       end R;
1060
1061       -------
1062       -- S --
1063       -------
1064
1065       function S (I : Nat) return Node_Id is
1066       begin
1067          return Make_Identifier (Loc, New_External_Name ('S', I));
1068       end S;
1069
1070       -------------
1071       -- S_First --
1072       -------------
1073
1074       function S_First (I : Nat) return Node_Id is
1075       begin
1076          return Make_Attribute_Reference (Loc,
1077                   Prefix         => S (I),
1078                   Attribute_Name => Name_First);
1079       end S_First;
1080
1081       ------------
1082       -- S_Last --
1083       ------------
1084
1085       function S_Last (I : Nat) return Node_Id is
1086       begin
1087          return Make_Attribute_Reference (Loc,
1088                   Prefix         => S (I),
1089                   Attribute_Name => Name_Last);
1090       end S_Last;
1091
1092       --------------
1093       -- S_Length --
1094       --------------
1095
1096       function S_Length (I : Nat) return Node_Id is
1097       begin
1098          return Make_Attribute_Reference (Loc,
1099                   Prefix         => S (I),
1100                   Attribute_Name => Name_Length);
1101       end S_Length;
1102
1103       -------------------
1104       -- S_Length_Test --
1105       -------------------
1106
1107       function S_Length_Test (I : Nat) return Node_Id is
1108       begin
1109          return
1110            Make_Op_Ne (Loc,
1111              Left_Opnd  => S_Length (I),
1112              Right_Opnd => Make_Integer_Literal (Loc, 0));
1113       end S_Length_Test;
1114
1115    --  Start of processing for Expand_Concatenate_Other
1116
1117    begin
1118       --  Construct the parameter specs and the overall function spec
1119
1120       Param_Specs := New_List;
1121       for I in 1 .. Nb_Opnds loop
1122          Append_To
1123            (Param_Specs,
1124             Make_Parameter_Specification (Loc,
1125               Defining_Identifier =>
1126                 Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
1127               Parameter_Type      => New_Reference_To (Base_Typ, Loc)));
1128       end loop;
1129
1130       Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
1131       Func_Spec :=
1132         Make_Function_Specification (Loc,
1133           Defining_Unit_Name       => Func_Id,
1134           Parameter_Specifications => Param_Specs,
1135           Subtype_Mark             => New_Reference_To (Base_Typ, Loc));
1136
1137       --  Construct L's object declaration
1138
1139       L_Decl :=
1140         Make_Object_Declaration (Loc,
1141           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
1142           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
1143
1144       Func_Decls := New_List (L_Decl);
1145
1146       --  Construct the if-then-elsif statements
1147
1148       Elsif_List := New_List;
1149       for I in 2 .. Nb_Opnds - 1 loop
1150          Append_To (Elsif_List, Make_Elsif_Part (Loc,
1151                                   Condition       => S_Length_Test (I),
1152                                   Then_Statements => New_List (Init_L (I))));
1153       end loop;
1154
1155       If_Stmt :=
1156         Make_Implicit_If_Statement (Cnode,
1157           Condition       => S_Length_Test (1),
1158           Then_Statements => New_List (Init_L (1)),
1159           Elsif_Parts     => Elsif_List,
1160           Else_Statements => New_List (Make_Return_Statement (Loc,
1161                                          Expression => S (Nb_Opnds))));
1162
1163       --  Construct the declaration for H
1164
1165       P_Decl :=
1166         Make_Object_Declaration (Loc,
1167           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
1168           Object_Definition   => New_Reference_To (Ind_Typ, Loc));
1169
1170       H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
1171       for I in 2 .. Nb_Opnds loop
1172          H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
1173       end loop;
1174       H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
1175
1176       H_Decl :=
1177         Make_Object_Declaration (Loc,
1178           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
1179           Object_Definition   => New_Reference_To (Ind_Typ, Loc),
1180           Expression          => H_Init);
1181
1182       --  Construct the declaration for R
1183
1184       R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
1185       R_Constr :=
1186         Make_Index_Or_Discriminant_Constraint (Loc,
1187           Constraints => New_List (R_Range));
1188
1189       R_Decl :=
1190         Make_Object_Declaration (Loc,
1191           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
1192           Object_Definition   =>
1193             Make_Subtype_Indication (Loc,
1194                Subtype_Mark => New_Reference_To (Base_Typ, Loc),
1195                Constraint   => R_Constr));
1196
1197       --  Construct the declarations for the declare block
1198
1199       Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
1200
1201       --  Construct list of statements for the declare block
1202
1203       Declare_Stmts := New_List;
1204       for I in 1 .. Nb_Opnds loop
1205          Append_To (Declare_Stmts,
1206                     Make_Implicit_If_Statement (Cnode,
1207                       Condition       => S_Length_Test (I),
1208                       Then_Statements => Copy_Into_R_S (I)));
1209       end loop;
1210
1211       Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
1212
1213       --  Construct the declare block
1214
1215       Declare_Block := Make_Block_Statement (Loc,
1216         Declarations               => Declare_Decls,
1217         Handled_Statement_Sequence =>
1218           Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
1219
1220       --  Construct the list of function statements
1221
1222       Func_Stmts := New_List (If_Stmt, Declare_Block);
1223
1224       --  Construct the function body
1225
1226       Func_Body :=
1227         Make_Subprogram_Body (Loc,
1228           Specification              => Func_Spec,
1229           Declarations               => Func_Decls,
1230           Handled_Statement_Sequence =>
1231             Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
1232
1233       --  Insert the newly generated function in the code. This is analyzed
1234       --  with all checks off, since we have completed all the checks.
1235
1236       --  Note that this does *not* fix the array concatenation bug when the
1237       --  low bound is Integer'first sibce that bug comes from the pointer
1238       --  dereferencing an unconstrained array. An there we need a constraint
1239       --  check to make sure the length of the concatenated array is ok. ???
1240
1241       Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
1242
1243       --  Construct list of arguments for the function call
1244
1245       Params := New_List;
1246       Operand  := First (Opnds);
1247       for I in 1 .. Nb_Opnds loop
1248          Append_To (Params, Relocate_Node (Operand));
1249          Next (Operand);
1250       end loop;
1251
1252       --  Insert the function call
1253
1254       Rewrite
1255         (Cnode,
1256          Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
1257
1258       Analyze_And_Resolve (Cnode, Base_Typ);
1259       Set_Is_Inlined (Func_Id);
1260    end Expand_Concatenate_Other;
1261
1262    -------------------------------
1263    -- Expand_Concatenate_String --
1264    -------------------------------
1265
1266    procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
1267       Loc   : constant Source_Ptr := Sloc (Cnode);
1268       Opnd1 : constant Node_Id    := First (Opnds);
1269       Opnd2 : constant Node_Id    := Next (Opnd1);
1270       Typ1  : constant Entity_Id  := Base_Type (Etype (Opnd1));
1271       Typ2  : constant Entity_Id  := Base_Type (Etype (Opnd2));
1272
1273       R : RE_Id;
1274       --  RE_Id value for function to be called
1275
1276    begin
1277       --  In all cases, we build a call to a routine giving the list of
1278       --  arguments as the parameter list to the routine.
1279
1280       case List_Length (Opnds) is
1281          when 2 =>
1282             if Typ1 = Standard_Character then
1283                if Typ2 = Standard_Character then
1284                   R := RE_Str_Concat_CC;
1285
1286                else
1287                   pragma Assert (Typ2 = Standard_String);
1288                   R := RE_Str_Concat_CS;
1289                end if;
1290
1291             elsif Typ1 = Standard_String then
1292                if Typ2 = Standard_Character then
1293                   R := RE_Str_Concat_SC;
1294
1295                else
1296                   pragma Assert (Typ2 = Standard_String);
1297                   R := RE_Str_Concat;
1298                end if;
1299
1300             --  If we have anything other than Standard_Character or
1301             --  Standard_String, then we must have had an error earlier.
1302             --  So we just abandon the attempt at expansion.
1303
1304             else
1305                pragma Assert (Errors_Detected > 0);
1306                return;
1307             end if;
1308
1309          when 3 =>
1310             R := RE_Str_Concat_3;
1311
1312          when 4 =>
1313             R := RE_Str_Concat_4;
1314
1315          when 5 =>
1316             R := RE_Str_Concat_5;
1317
1318          when others =>
1319             R := RE_Null;
1320             raise Program_Error;
1321       end case;
1322
1323       --  Now generate the appropriate call
1324
1325       Rewrite (Cnode,
1326         Make_Function_Call (Sloc (Cnode),
1327           Name => New_Occurrence_Of (RTE (R), Loc),
1328           Parameter_Associations => Opnds));
1329
1330       Analyze_And_Resolve (Cnode, Standard_String);
1331    end Expand_Concatenate_String;
1332
1333    ------------------------
1334    -- Expand_N_Allocator --
1335    ------------------------
1336
1337    procedure Expand_N_Allocator (N : Node_Id) is
1338       PtrT  : constant Entity_Id  := Etype (N);
1339       Desig : Entity_Id;
1340       Loc   : constant Source_Ptr := Sloc (N);
1341       Temp  : Entity_Id;
1342       Node  : Node_Id;
1343
1344    begin
1345       --  RM E.2.3(22). We enforce that the expected type of an allocator
1346       --  shall not be a remote access-to-class-wide-limited-private type
1347
1348       --  Why is this being done at expansion time, seems clearly wrong ???
1349
1350       Validate_Remote_Access_To_Class_Wide_Type (N);
1351
1352       --  Set the Storage Pool
1353
1354       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
1355
1356       if Present (Storage_Pool (N)) then
1357          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
1358             if not Java_VM then
1359                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
1360             end if;
1361          else
1362             Set_Procedure_To_Call (N,
1363               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
1364          end if;
1365       end if;
1366
1367       --  Under certain circumstances we can replace an allocator by an
1368       --  access to statically allocated storage. The conditions, as noted
1369       --  in AARM 3.10 (10c) are as follows:
1370
1371       --    Size and initial value is known at compile time
1372       --    Access type is access-to-constant
1373
1374       if Is_Access_Constant (PtrT)
1375         and then Nkind (Expression (N)) = N_Qualified_Expression
1376         and then Compile_Time_Known_Value (Expression (Expression (N)))
1377         and then Size_Known_At_Compile_Time (Etype (Expression
1378                                                     (Expression (N))))
1379       then
1380          --  Here we can do the optimization. For the allocator
1381
1382          --    new x'(y)
1383
1384          --  We insert an object declaration
1385
1386          --    Tnn : aliased x := y;
1387
1388          --  and replace the allocator by Tnn'Unrestricted_Access.
1389          --  Tnn is marked as requiring static allocation.
1390
1391          Temp :=
1392            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
1393
1394          Desig := Subtype_Mark (Expression (N));
1395
1396          --  If context is constrained, use constrained subtype directly,
1397          --  so that the constant is not labelled as having a nomimally
1398          --  unconstrained subtype.
1399
1400          if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
1401             Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
1402          end if;
1403
1404          Insert_Action (N,
1405            Make_Object_Declaration (Loc,
1406              Defining_Identifier => Temp,
1407              Aliased_Present     => True,
1408              Constant_Present    => Is_Access_Constant (PtrT),
1409              Object_Definition   => Desig,
1410              Expression          => Expression (Expression (N))));
1411
1412          Rewrite (N,
1413            Make_Attribute_Reference (Loc,
1414              Prefix => New_Occurrence_Of (Temp, Loc),
1415              Attribute_Name => Name_Unrestricted_Access));
1416
1417          Analyze_And_Resolve (N, PtrT);
1418
1419          --  We set the variable as statically allocated, since we don't
1420          --  want it going on the stack of the current procedure!
1421
1422          Set_Is_Statically_Allocated (Temp);
1423          return;
1424       end if;
1425
1426       --  If the allocator is for a type which requires initialization, and
1427       --  there is no initial value (i.e. the operand is a subtype indication
1428       --  rather than a qualifed expression), then we must generate a call to
1429       --  the initialization routine. This is done using an expression actions
1430       --  node:
1431       --
1432       --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
1433       --
1434       --  Here ptr_T is the pointer type for the allocator, and T is the
1435       --  subtype of the allocator. A special case arises if the designated
1436       --  type of the access type is a task or contains tasks. In this case
1437       --  the call to Init (Temp.all ...) is replaced by code that ensures
1438       --  that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
1439       --  for details). In addition, if the type T is a task T, then the first
1440       --  argument to Init must be converted to the task record type.
1441
1442       if Nkind (Expression (N)) = N_Qualified_Expression then
1443          declare
1444             Indic : constant Node_Id   := Subtype_Mark (Expression (N));
1445             T     : constant Entity_Id := Entity (Indic);
1446             Exp   : constant Node_Id   := Expression (Expression (N));
1447
1448             Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
1449
1450             Tag_Assign : Node_Id;
1451             Tmp_Node   : Node_Id;
1452
1453          begin
1454             if Is_Tagged_Type (T) or else Controlled_Type (T) then
1455
1456                --    Actions inserted before:
1457                --              Temp : constant ptr_T := new T'(Expression);
1458                --   <no CW>    Temp._tag := T'tag;
1459                --   <CTRL>     Adjust (Finalizable (Temp.all));
1460                --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
1461
1462                --  We analyze by hand the new internal allocator to avoid
1463                --  any recursion and inappropriate call to Initialize
1464                if not Aggr_In_Place then
1465                   Remove_Side_Effects (Exp);
1466                end if;
1467
1468                Temp :=
1469                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1470
1471                --  For a class wide allocation generate the following code:
1472
1473                --    type Equiv_Record is record ... end record;
1474                --    implicit subtype CW is <Class_Wide_Subytpe>;
1475                --    temp : PtrT := new CW'(CW!(expr));
1476
1477                if Is_Class_Wide_Type (T) then
1478                   Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
1479
1480                   Set_Expression (Expression (N),
1481                     Unchecked_Convert_To (Entity (Indic), Exp));
1482
1483                   Analyze_And_Resolve (Expression (N), Entity (Indic));
1484                end if;
1485
1486                if Aggr_In_Place then
1487                   Tmp_Node :=
1488                     Make_Object_Declaration (Loc,
1489                       Defining_Identifier => Temp,
1490                       Object_Definition   => New_Reference_To (PtrT, Loc),
1491                       Expression          => Make_Allocator (Loc,
1492                           New_Reference_To (Etype (Exp), Loc)));
1493
1494                   Set_No_Initialization (Expression (Tmp_Node));
1495                   Insert_Action (N, Tmp_Node);
1496                   Convert_Aggr_In_Allocator (Tmp_Node, Exp);
1497                else
1498                   Node := Relocate_Node (N);
1499                   Set_Analyzed (Node);
1500                   Insert_Action (N,
1501                     Make_Object_Declaration (Loc,
1502                       Defining_Identifier => Temp,
1503                       Constant_Present    => True,
1504                       Object_Definition   => New_Reference_To (PtrT, Loc),
1505                       Expression          => Node));
1506                end if;
1507
1508                --  Suppress the tag assignment when Java_VM because JVM tags
1509                --  are represented implicitly in objects.
1510
1511                if Is_Tagged_Type (T)
1512                  and then not Is_Class_Wide_Type (T)
1513                  and then not Java_VM
1514                then
1515                   Tag_Assign :=
1516                     Make_Assignment_Statement (Loc,
1517                       Name =>
1518                         Make_Selected_Component (Loc,
1519                           Prefix => New_Reference_To (Temp, Loc),
1520                           Selector_Name =>
1521                             New_Reference_To (Tag_Component (T), Loc)),
1522
1523                       Expression =>
1524                         Unchecked_Convert_To (RTE (RE_Tag),
1525                           New_Reference_To (Access_Disp_Table (T), Loc)));
1526
1527                   --  The previous assignment has to be done in any case
1528
1529                   Set_Assignment_OK (Name (Tag_Assign));
1530                   Insert_Action (N, Tag_Assign);
1531
1532                elsif Is_Private_Type (T)
1533                  and then Is_Tagged_Type (Underlying_Type (T))
1534                  and then not Java_VM
1535                then
1536                   declare
1537                      Utyp : constant Entity_Id := Underlying_Type (T);
1538                      Ref  : constant Node_Id :=
1539                               Unchecked_Convert_To (Utyp,
1540                                 Make_Explicit_Dereference (Loc,
1541                                   New_Reference_To (Temp, Loc)));
1542
1543                   begin
1544                      Tag_Assign :=
1545                        Make_Assignment_Statement (Loc,
1546                          Name =>
1547                            Make_Selected_Component (Loc,
1548                              Prefix => Ref,
1549                              Selector_Name =>
1550                                New_Reference_To (Tag_Component (Utyp), Loc)),
1551
1552                          Expression =>
1553                            Unchecked_Convert_To (RTE (RE_Tag),
1554                              New_Reference_To (
1555                                Access_Disp_Table (Utyp), Loc)));
1556
1557                      Set_Assignment_OK (Name (Tag_Assign));
1558                      Insert_Action (N, Tag_Assign);
1559                   end;
1560                end if;
1561
1562                if Controlled_Type (Designated_Type (PtrT))
1563                   and then Controlled_Type (T)
1564                then
1565                   declare
1566                      Flist  : Node_Id;
1567                      Attach : Node_Id;
1568                      Apool  : constant Entity_Id :=
1569                                 Associated_Storage_Pool (PtrT);
1570
1571                   begin
1572                      --  If it is an allocation on the secondary stack
1573                      --  (i.e. a value returned from a function), the object
1574                      --  is attached on the caller side as soon as the call
1575                      --  is completed (see Expand_Ctrl_Function_Call)
1576
1577                      if Is_RTE (Apool, RE_SS_Pool) then
1578                         declare
1579                            F : constant Entity_Id :=
1580                                  Make_Defining_Identifier (Loc,
1581                                    New_Internal_Name ('F'));
1582                         begin
1583                            Insert_Action (N,
1584                              Make_Object_Declaration (Loc,
1585                                Defining_Identifier => F,
1586                                Object_Definition   => New_Reference_To (RTE
1587                                 (RE_Finalizable_Ptr), Loc)));
1588
1589                            Flist := New_Reference_To (F, Loc);
1590                            Attach :=  Make_Integer_Literal (Loc, 1);
1591                         end;
1592
1593                      --  Normal case, not a secondary stack allocation
1594
1595                      else
1596                         Flist := Find_Final_List (PtrT);
1597                         Attach :=  Make_Integer_Literal (Loc, 2);
1598                      end if;
1599
1600                      if not Aggr_In_Place then
1601                         Insert_Actions (N,
1602                           Make_Adjust_Call (
1603                             Ref          =>
1604
1605                            --  An unchecked conversion is needed in the
1606                            --  classwide case because the designated type
1607                            --  can be an ancestor of the subtype mark of
1608                            --  the allocator.
1609
1610                             Unchecked_Convert_To (T,
1611                               Make_Explicit_Dereference (Loc,
1612                                 New_Reference_To (Temp, Loc))),
1613
1614                             Typ          => T,
1615                             Flist_Ref    => Flist,
1616                             With_Attach  => Attach));
1617                      end if;
1618                   end;
1619                end if;
1620
1621                Rewrite (N, New_Reference_To (Temp, Loc));
1622                Analyze_And_Resolve (N, PtrT);
1623
1624             elsif Aggr_In_Place then
1625                Temp :=
1626                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
1627                Tmp_Node :=
1628                  Make_Object_Declaration (Loc,
1629                    Defining_Identifier => Temp,
1630                    Object_Definition   => New_Reference_To (PtrT, Loc),
1631                    Expression          => Make_Allocator (Loc,
1632                        New_Reference_To (Etype (Exp), Loc)));
1633
1634                Set_No_Initialization (Expression (Tmp_Node));
1635                Insert_Action (N, Tmp_Node);
1636                Convert_Aggr_In_Allocator (Tmp_Node, Exp);
1637                Rewrite (N, New_Reference_To (Temp, Loc));
1638                Analyze_And_Resolve (N, PtrT);
1639
1640             elsif Is_Access_Type (Designated_Type (PtrT))
1641               and then Nkind (Exp) = N_Allocator
1642               and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1643             then
1644                --  Apply constraint to designated subtype indication.
1645
1646                Apply_Constraint_Check (Expression (Exp),
1647                  Designated_Type (Designated_Type (PtrT)),
1648                  No_Sliding => True);
1649
1650                if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1651
1652                   --  Propagate constraint_error to enclosing allocator.
1653
1654                   Rewrite
1655                     (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 Software_Overflow_Checking
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       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
3073       Exptyp : constant Entity_Id  := Etype (Exp);
3074       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
3075       Expv   : Uint;
3076       Xnode  : Node_Id;
3077       Temp   : Node_Id;
3078       Rent   : RE_Id;
3079       Ent    : Entity_Id;
3080
3081    begin
3082       Binary_Op_Validity_Checks (N);
3083
3084       --  At this point the exponentiation must be dynamic since the static
3085       --  case has already been folded after Resolve by Eval_Op_Expon.
3086
3087       --  Test for case of literal right argument
3088
3089       if Compile_Time_Known_Value (Exp) then
3090          Expv := Expr_Value (Exp);
3091
3092          --  We only fold small non-negative exponents. You might think we
3093          --  could fold small negative exponents for the real case, but we
3094          --  can't because we are required to raise Constraint_Error for
3095          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
3096          --  See ACVC test C4A012B.
3097
3098          if Expv >= 0 and then Expv <= 4 then
3099
3100             --  X ** 0 = 1 (or 1.0)
3101
3102             if Expv = 0 then
3103                if Ekind (Typ) in Integer_Kind then
3104                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
3105                else
3106                   Xnode := Make_Real_Literal (Loc, Ureal_1);
3107                end if;
3108
3109             --  X ** 1 = X
3110
3111             elsif Expv = 1 then
3112                Xnode := Base;
3113
3114             --  X ** 2 = X * X
3115
3116             elsif Expv = 2 then
3117                Xnode :=
3118                  Make_Op_Multiply (Loc,
3119                    Left_Opnd  => Duplicate_Subexpr (Base),
3120                    Right_Opnd => Duplicate_Subexpr (Base));
3121
3122             --  X ** 3 = X * X * X
3123
3124             elsif Expv = 3 then
3125                Xnode :=
3126                  Make_Op_Multiply (Loc,
3127                    Left_Opnd =>
3128                      Make_Op_Multiply (Loc,
3129                        Left_Opnd  => Duplicate_Subexpr (Base),
3130                        Right_Opnd => Duplicate_Subexpr (Base)),
3131                    Right_Opnd  => Duplicate_Subexpr (Base));
3132
3133             --  X ** 4  ->
3134             --    En : constant base'type := base * base;
3135             --    ...
3136             --    En * En
3137
3138             else -- Expv = 4
3139                Temp :=
3140                  Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
3141
3142                Insert_Actions (N, New_List (
3143                  Make_Object_Declaration (Loc,
3144                    Defining_Identifier => Temp,
3145                    Constant_Present    => True,
3146                    Object_Definition   => New_Reference_To (Typ, Loc),
3147                    Expression =>
3148                      Make_Op_Multiply (Loc,
3149                        Left_Opnd  => Duplicate_Subexpr (Base),
3150                        Right_Opnd => Duplicate_Subexpr (Base)))));
3151
3152                Xnode :=
3153                  Make_Op_Multiply (Loc,
3154                    Left_Opnd  => New_Reference_To (Temp, Loc),
3155                    Right_Opnd => New_Reference_To (Temp, Loc));
3156             end if;
3157
3158             Rewrite (N, Xnode);
3159             Analyze_And_Resolve (N, Typ);
3160             return;
3161          end if;
3162       end if;
3163
3164       --  Case of (2 ** expression) appearing as an argument of an integer
3165       --  multiplication, or as the right argument of a division of a non-
3166       --  negative integer. In such cases we lave the node untouched, setting
3167       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
3168       --  of the higher level node converts it into a shift.
3169
3170       if Nkind (Base) = N_Integer_Literal
3171         and then Intval (Base) = 2
3172         and then Is_Integer_Type (Root_Type (Exptyp))
3173         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
3174         and then Is_Unsigned_Type (Exptyp)
3175         and then not Ovflo
3176         and then Nkind (Parent (N)) in N_Binary_Op
3177       then
3178          declare
3179             P : constant Node_Id := Parent (N);
3180             L : constant Node_Id := Left_Opnd (P);
3181             R : constant Node_Id := Right_Opnd (P);
3182
3183          begin
3184             if (Nkind (P) = N_Op_Multiply
3185                  and then
3186                    ((Is_Integer_Type (Etype (L)) and then R = N)
3187                        or else
3188                     (Is_Integer_Type (Etype (R)) and then L = N))
3189                  and then not Do_Overflow_Check (P))
3190
3191               or else
3192                 (Nkind (P) = N_Op_Divide
3193                   and then Is_Integer_Type (Etype (L))
3194                   and then Is_Unsigned_Type (Etype (L))
3195                   and then R = N
3196                   and then not Do_Overflow_Check (P))
3197             then
3198                Set_Is_Power_Of_2_For_Shift (N);
3199                return;
3200             end if;
3201          end;
3202       end if;
3203
3204       --  Fall through if exponentiation must be done using a runtime routine.
3205
3206       --  First deal with modular case.
3207
3208       if Is_Modular_Integer_Type (Rtyp) then
3209
3210          --  Non-binary case, we call the special exponentiation routine for
3211          --  the non-binary case, converting the argument to Long_Long_Integer
3212          --  and passing the modulus value. Then the result is converted back
3213          --  to the base type.
3214
3215          if Non_Binary_Modulus (Rtyp) then
3216
3217             Rewrite (N,
3218               Convert_To (Typ,
3219                 Make_Function_Call (Loc,
3220                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
3221                   Parameter_Associations => New_List (
3222                     Convert_To (Standard_Integer, Base),
3223                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
3224                     Exp))));
3225
3226          --  Binary case, in this case, we call one of two routines, either
3227          --  the unsigned integer case, or the unsigned long long integer
3228          --  case, with a final "and" operation to do the required mod.
3229
3230          else
3231             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
3232                Ent := RTE (RE_Exp_Unsigned);
3233             else
3234                Ent := RTE (RE_Exp_Long_Long_Unsigned);
3235             end if;
3236
3237             Rewrite (N,
3238               Convert_To (Typ,
3239                 Make_Op_And (Loc,
3240                   Left_Opnd =>
3241                     Make_Function_Call (Loc,
3242                       Name => New_Reference_To (Ent, Loc),
3243                       Parameter_Associations => New_List (
3244                         Convert_To (Etype (First_Formal (Ent)), Base),
3245                         Exp)),
3246                    Right_Opnd =>
3247                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
3248
3249          end if;
3250
3251          --  Common exit point for modular type case
3252
3253          Analyze_And_Resolve (N, Typ);
3254          return;
3255
3256       --  Signed integer cases
3257
3258       elsif Rtyp = Base_Type (Standard_Integer) then
3259          if Ovflo then
3260             Rent := RE_Exp_Integer;
3261          else
3262             Rent := RE_Exn_Integer;
3263          end if;
3264
3265       elsif Rtyp = Base_Type (Standard_Short_Integer) then
3266          if Ovflo then
3267             Rent := RE_Exp_Short_Integer;
3268          else
3269             Rent := RE_Exn_Short_Integer;
3270          end if;
3271
3272       elsif Rtyp = Base_Type (Standard_Short_Short_Integer) then
3273          if Ovflo then
3274             Rent := RE_Exp_Short_Short_Integer;
3275          else
3276             Rent := RE_Exn_Short_Short_Integer;
3277          end if;
3278
3279       elsif Rtyp = Base_Type (Standard_Long_Integer) then
3280          if Ovflo then
3281             Rent := RE_Exp_Long_Integer;
3282          else
3283             Rent := RE_Exn_Long_Integer;
3284          end if;
3285
3286       elsif (Rtyp = Base_Type (Standard_Long_Long_Integer)
3287         or else Rtyp = Universal_Integer)
3288       then
3289          if Ovflo then
3290             Rent := RE_Exp_Long_Long_Integer;
3291          else
3292             Rent := RE_Exn_Long_Long_Integer;
3293          end if;
3294
3295       --  Floating-point cases
3296
3297       elsif Rtyp = Standard_Float then
3298          if Ovflo then
3299             Rent := RE_Exp_Float;
3300          else
3301             Rent := RE_Exn_Float;
3302          end if;
3303
3304       elsif Rtyp = Standard_Short_Float then
3305          if Ovflo then
3306             Rent := RE_Exp_Short_Float;
3307          else
3308             Rent := RE_Exn_Short_Float;
3309          end if;
3310
3311       elsif Rtyp = Standard_Long_Float then
3312          if Ovflo then
3313             Rent := RE_Exp_Long_Float;
3314          else
3315             Rent := RE_Exn_Long_Float;
3316          end if;
3317
3318       else
3319          pragma Assert
3320            (Rtyp = Standard_Long_Long_Float or else Rtyp = Universal_Real);
3321
3322          if Ovflo then
3323             Rent := RE_Exp_Long_Long_Float;
3324          else
3325             Rent := RE_Exn_Long_Long_Float;
3326          end if;
3327       end if;
3328
3329       --  Common processing for integer cases and floating-point cases.
3330       --  If we are in the base type, we can call runtime routine directly
3331
3332       if Typ = Rtyp
3333         and then Rtyp /= Universal_Integer
3334         and then Rtyp /= Universal_Real
3335       then
3336          Rewrite (N,
3337            Make_Function_Call (Loc,
3338              Name => New_Reference_To (RTE (Rent), Loc),
3339              Parameter_Associations => New_List (Base, Exp)));
3340
3341       --  Otherwise we have to introduce conversions (conversions are also
3342       --  required in the universal cases, since the runtime routine was
3343       --  typed using the largest integer or real case.
3344
3345       else
3346          Rewrite (N,
3347            Convert_To (Typ,
3348              Make_Function_Call (Loc,
3349                Name => New_Reference_To (RTE (Rent), Loc),
3350                Parameter_Associations => New_List (
3351                  Convert_To (Rtyp, Base),
3352                  Exp))));
3353       end if;
3354
3355       Analyze_And_Resolve (N, Typ);
3356       return;
3357
3358    end Expand_N_Op_Expon;
3359
3360    --------------------
3361    -- Expand_N_Op_Ge --
3362    --------------------
3363
3364    procedure Expand_N_Op_Ge (N : Node_Id) is
3365       Typ  : constant Entity_Id := Etype (N);
3366       Op1  : constant Node_Id   := Left_Opnd (N);
3367       Op2  : constant Node_Id   := Right_Opnd (N);
3368       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3369
3370    begin
3371       Binary_Op_Validity_Checks (N);
3372
3373       if Vax_Float (Typ1) then
3374          Expand_Vax_Comparison (N);
3375          return;
3376
3377       elsif Is_Array_Type (Typ1) then
3378          Expand_Array_Comparison (N);
3379          return;
3380       end if;
3381
3382       if Is_Boolean_Type (Typ1) then
3383          Adjust_Condition (Op1);
3384          Adjust_Condition (Op2);
3385          Set_Etype (N, Standard_Boolean);
3386          Adjust_Result_Type (N, Typ);
3387       end if;
3388
3389       Rewrite_Comparison (N);
3390    end Expand_N_Op_Ge;
3391
3392    --------------------
3393    -- Expand_N_Op_Gt --
3394    --------------------
3395
3396    procedure Expand_N_Op_Gt (N : Node_Id) is
3397       Typ  : constant Entity_Id := Etype (N);
3398       Op1  : constant Node_Id   := Left_Opnd (N);
3399       Op2  : constant Node_Id   := Right_Opnd (N);
3400       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3401
3402    begin
3403       Binary_Op_Validity_Checks (N);
3404
3405       if Vax_Float (Typ1) then
3406          Expand_Vax_Comparison (N);
3407          return;
3408
3409       elsif Is_Array_Type (Typ1) then
3410          Expand_Array_Comparison (N);
3411          return;
3412       end if;
3413
3414       if Is_Boolean_Type (Typ1) then
3415          Adjust_Condition (Op1);
3416          Adjust_Condition (Op2);
3417          Set_Etype (N, Standard_Boolean);
3418          Adjust_Result_Type (N, Typ);
3419       end if;
3420
3421       Rewrite_Comparison (N);
3422    end Expand_N_Op_Gt;
3423
3424    --------------------
3425    -- Expand_N_Op_Le --
3426    --------------------
3427
3428    procedure Expand_N_Op_Le (N : Node_Id) is
3429       Typ  : constant Entity_Id := Etype (N);
3430       Op1  : constant Node_Id   := Left_Opnd (N);
3431       Op2  : constant Node_Id   := Right_Opnd (N);
3432       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3433
3434    begin
3435       Binary_Op_Validity_Checks (N);
3436
3437       if Vax_Float (Typ1) then
3438          Expand_Vax_Comparison (N);
3439          return;
3440
3441       elsif Is_Array_Type (Typ1) then
3442          Expand_Array_Comparison (N);
3443          return;
3444       end if;
3445
3446       if Is_Boolean_Type (Typ1) then
3447          Adjust_Condition (Op1);
3448          Adjust_Condition (Op2);
3449          Set_Etype (N, Standard_Boolean);
3450          Adjust_Result_Type (N, Typ);
3451       end if;
3452
3453       Rewrite_Comparison (N);
3454    end Expand_N_Op_Le;
3455
3456    --------------------
3457    -- Expand_N_Op_Lt --
3458    --------------------
3459
3460    procedure Expand_N_Op_Lt (N : Node_Id) is
3461       Typ  : constant Entity_Id := Etype (N);
3462       Op1  : constant Node_Id   := Left_Opnd (N);
3463       Op2  : constant Node_Id   := Right_Opnd (N);
3464       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
3465
3466    begin
3467       Binary_Op_Validity_Checks (N);
3468
3469       if Vax_Float (Typ1) then
3470          Expand_Vax_Comparison (N);
3471          return;
3472
3473       elsif Is_Array_Type (Typ1) then
3474          Expand_Array_Comparison (N);
3475          return;
3476       end if;
3477
3478       if Is_Boolean_Type (Typ1) then
3479          Adjust_Condition (Op1);
3480          Adjust_Condition (Op2);
3481          Set_Etype (N, Standard_Boolean);
3482          Adjust_Result_Type (N, Typ);
3483       end if;
3484
3485       Rewrite_Comparison (N);
3486    end Expand_N_Op_Lt;
3487
3488    -----------------------
3489    -- Expand_N_Op_Minus --
3490    -----------------------
3491
3492    procedure Expand_N_Op_Minus (N : Node_Id) is
3493       Loc : constant Source_Ptr := Sloc (N);
3494       Typ : constant Entity_Id  := Etype (N);
3495
3496    begin
3497       Unary_Op_Validity_Checks (N);
3498
3499       if Software_Overflow_Checking
3500          and then Is_Signed_Integer_Type (Etype (N))
3501          and then Do_Overflow_Check (N)
3502       then
3503          --  Software overflow checking expands -expr into (0 - expr)
3504
3505          Rewrite (N,
3506            Make_Op_Subtract (Loc,
3507              Left_Opnd  => Make_Integer_Literal (Loc, 0),
3508              Right_Opnd => Right_Opnd (N)));
3509
3510          Analyze_And_Resolve (N, Typ);
3511
3512       --  Vax floating-point types case
3513
3514       elsif Vax_Float (Etype (N)) then
3515          Expand_Vax_Arith (N);
3516       end if;
3517    end Expand_N_Op_Minus;
3518
3519    ---------------------
3520    -- Expand_N_Op_Mod --
3521    ---------------------
3522
3523    procedure Expand_N_Op_Mod (N : Node_Id) is
3524       Loc   : constant Source_Ptr := Sloc (N);
3525       T     : constant Entity_Id  := Etype (N);
3526       Left  : constant Node_Id    := Left_Opnd (N);
3527       Right : constant Node_Id    := Right_Opnd (N);
3528       DOC   : constant Boolean    := Do_Overflow_Check (N);
3529       DDC   : constant Boolean    := Do_Division_Check (N);
3530
3531       LLB : Uint;
3532       Llo : Uint;
3533       Lhi : Uint;
3534       LOK : Boolean;
3535       Rlo : Uint;
3536       Rhi : Uint;
3537       ROK : Boolean;
3538
3539    begin
3540       Binary_Op_Validity_Checks (N);
3541
3542       Determine_Range (Right, ROK, Rlo, Rhi);
3543       Determine_Range (Left,  LOK, Llo, Lhi);
3544
3545       --  Convert mod to rem if operands are known non-negative. We do this
3546       --  since it is quite likely that this will improve the quality of code,
3547       --  (the operation now corresponds to the hardware remainder), and it
3548       --  does not seem likely that it could be harmful.
3549
3550       if LOK and then Llo >= 0
3551            and then
3552          ROK and then Rlo >= 0
3553       then
3554          Rewrite (N,
3555            Make_Op_Rem (Sloc (N),
3556              Left_Opnd  => Left_Opnd (N),
3557              Right_Opnd => Right_Opnd (N)));
3558
3559          --  Instead of reanalyzing the node we do the analysis manually.
3560          --  This avoids anomalies when the replacement is done in an
3561          --  instance and is epsilon more efficient.
3562
3563          Set_Entity            (N, Standard_Entity (S_Op_Rem));
3564          Set_Etype             (N, T);
3565          Set_Do_Overflow_Check (N, DOC);
3566          Set_Do_Division_Check (N, DDC);
3567          Expand_N_Op_Rem (N);
3568          Set_Analyzed (N);
3569
3570       --  Otherwise, normal mod processing
3571
3572       else
3573          if Is_Integer_Type (Etype (N)) then
3574             Apply_Divide_Check (N);
3575          end if;
3576
3577          --  Deal with annoying case of largest negative number remainder
3578          --  minus one. Gigi does not handle this case correctly, because
3579          --  it generates a divide instruction which may trap in this case.
3580
3581          --  In fact the check is quite easy, if the right operand is -1,
3582          --  then the mod value is always 0, and we can just ignore the
3583          --  left operand completely in this case.
3584
3585          LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
3586
3587          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
3588            and then
3589             ((not LOK) or else (Llo = LLB))
3590          then
3591             Rewrite (N,
3592               Make_Conditional_Expression (Loc,
3593                 Expressions => New_List (
3594                   Make_Op_Eq (Loc,
3595                     Left_Opnd => Duplicate_Subexpr (Right),
3596                     Right_Opnd =>
3597                       Make_Integer_Literal (Loc, -1)),
3598                   Make_Integer_Literal (Loc, Uint_0),
3599                   Relocate_Node (N))));
3600
3601             Set_Analyzed (Next (Next (First (Expressions (N)))));
3602             Analyze_And_Resolve (N, T);
3603          end if;
3604       end if;
3605    end Expand_N_Op_Mod;
3606
3607    --------------------------
3608    -- Expand_N_Op_Multiply --
3609    --------------------------
3610
3611    procedure Expand_N_Op_Multiply (N : Node_Id) is
3612       Loc  : constant Source_Ptr := Sloc (N);
3613       Lop  : constant Node_Id    := Left_Opnd (N);
3614       Rop  : constant Node_Id    := Right_Opnd (N);
3615       Ltyp : constant Entity_Id  := Etype (Lop);
3616       Rtyp : constant Entity_Id  := Etype (Rop);
3617       Typ  : Entity_Id           := Etype (N);
3618
3619    begin
3620       Binary_Op_Validity_Checks (N);
3621
3622       --  Special optimizations for integer types
3623
3624       if Is_Integer_Type (Typ) then
3625
3626          --  N * 0 = 0 * N = 0 for integer types
3627
3628          if (Compile_Time_Known_Value (Right_Opnd (N))
3629               and then Expr_Value (Right_Opnd (N)) = Uint_0)
3630            or else
3631             (Compile_Time_Known_Value (Left_Opnd (N))
3632               and then Expr_Value (Left_Opnd (N)) = Uint_0)
3633          then
3634             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
3635             Analyze_And_Resolve (N, Typ);
3636             return;
3637          end if;
3638
3639          --  N * 1 = 1 * N = N for integer types
3640
3641          if Compile_Time_Known_Value (Right_Opnd (N))
3642            and then Expr_Value (Right_Opnd (N)) = Uint_1
3643          then
3644             Rewrite (N, Left_Opnd (N));
3645             return;
3646
3647          elsif Compile_Time_Known_Value (Left_Opnd (N))
3648            and then Expr_Value (Left_Opnd (N)) = Uint_1
3649          then
3650             Rewrite (N, Right_Opnd (N));
3651             return;
3652          end if;
3653       end if;
3654
3655       --  Deal with VAX float case
3656
3657       if Vax_Float (Typ) then
3658          Expand_Vax_Arith (N);
3659          return;
3660       end if;
3661
3662       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
3663       --  Is_Power_Of_2_For_Shift is set means that we know that our left
3664       --  operand is an integer, as required for this to work.
3665
3666       if Nkind (Rop) = N_Op_Expon
3667         and then Is_Power_Of_2_For_Shift (Rop)
3668       then
3669          if Nkind (Lop) = N_Op_Expon
3670            and then Is_Power_Of_2_For_Shift (Lop)
3671          then
3672
3673             --  convert 2 ** A * 2 ** B into  2 ** (A + B)
3674
3675             Rewrite (N,
3676               Make_Op_Expon (Loc,
3677                 Left_Opnd => Make_Integer_Literal (Loc, 2),
3678                 Right_Opnd =>
3679                   Make_Op_Add (Loc,
3680                     Left_Opnd  => Right_Opnd (Lop),
3681                     Right_Opnd => Right_Opnd (Rop))));
3682             Analyze_And_Resolve (N, Typ);
3683             return;
3684
3685          else
3686             Rewrite (N,
3687               Make_Op_Shift_Left (Loc,
3688                 Left_Opnd  => Lop,
3689                 Right_Opnd =>
3690                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
3691             Analyze_And_Resolve (N, Typ);
3692             return;
3693          end if;
3694
3695       --  Same processing for the operands the other way round
3696
3697       elsif Nkind (Lop) = N_Op_Expon
3698         and then Is_Power_Of_2_For_Shift (Lop)
3699       then
3700          Rewrite (N,
3701            Make_Op_Shift_Left (Loc,
3702              Left_Opnd  => Rop,
3703              Right_Opnd =>
3704                Convert_To (Standard_Natural, Right_Opnd (Lop))));
3705          Analyze_And_Resolve (N, Typ);
3706          return;
3707       end if;
3708
3709       --  Do required fixup of universal fixed operation
3710
3711       if Typ = Universal_Fixed then
3712          Fixup_Universal_Fixed_Operation (N);
3713          Typ := Etype (N);
3714       end if;
3715
3716       --  Multiplications with fixed-point results
3717
3718       if Is_Fixed_Point_Type (Typ) then
3719
3720          --  No special processing if Treat_Fixed_As_Integer is set,
3721          --  since from a semantic point of view such operations are
3722          --  simply integer operations and will be treated that way.
3723
3724          if not Treat_Fixed_As_Integer (N) then
3725
3726             --  Case of fixed * integer => fixed
3727
3728             if Is_Integer_Type (Rtyp) then
3729                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
3730
3731             --  Case of integer * fixed => fixed
3732
3733             elsif Is_Integer_Type (Ltyp) then
3734                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
3735
3736             --  Case of fixed * fixed => fixed
3737
3738             else
3739                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
3740             end if;
3741          end if;
3742
3743       --  Other cases of multiplication of fixed-point operands. Again
3744       --  we exclude the cases where Treat_Fixed_As_Integer flag is set.
3745
3746       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
3747         and then not Treat_Fixed_As_Integer (N)
3748       then
3749          if Is_Integer_Type (Typ) then
3750             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
3751          else
3752             pragma Assert (Is_Floating_Point_Type (Typ));
3753             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
3754          end if;
3755
3756       --  Mixed-mode operations can appear in a non-static universal
3757       --  context, in  which case the integer argument must be converted
3758       --  explicitly.
3759
3760       elsif Typ = Universal_Real
3761         and then Is_Integer_Type (Rtyp)
3762       then
3763          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
3764
3765          Analyze_And_Resolve (Rop, Universal_Real);
3766
3767       elsif Typ = Universal_Real
3768         and then Is_Integer_Type (Ltyp)
3769       then
3770          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
3771
3772          Analyze_And_Resolve (Lop, Universal_Real);
3773
3774       --  Non-fixed point cases, check software overflow checking required
3775
3776       elsif Is_Signed_Integer_Type (Etype (N)) then
3777          Apply_Arithmetic_Overflow_Check (N);
3778       end if;
3779    end Expand_N_Op_Multiply;
3780
3781    --------------------
3782    -- Expand_N_Op_Ne --
3783    --------------------
3784
3785    --  Rewrite node as the negation of an equality operation, and reanalyze.
3786    --  The equality to be used is defined in the same scope and has the same
3787    --  signature. It must be set explicitly because in an instance it may not
3788    --  have the same visibility as in the generic unit.
3789
3790    procedure Expand_N_Op_Ne (N : Node_Id) is
3791       Loc : constant Source_Ptr := Sloc (N);
3792       Neg : Node_Id;
3793       Ne  : constant Entity_Id := Entity (N);
3794
3795    begin
3796       Binary_Op_Validity_Checks (N);
3797
3798       Neg :=
3799         Make_Op_Not (Loc,
3800           Right_Opnd =>
3801             Make_Op_Eq (Loc,
3802               Left_Opnd =>  Left_Opnd (N),
3803               Right_Opnd => Right_Opnd (N)));
3804       Set_Paren_Count (Right_Opnd (Neg), 1);
3805
3806       if Scope (Ne) /= Standard_Standard then
3807          Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
3808       end if;
3809
3810       Rewrite (N, Neg);
3811       Analyze_And_Resolve (N, Standard_Boolean);
3812    end Expand_N_Op_Ne;
3813
3814    ---------------------
3815    -- Expand_N_Op_Not --
3816    ---------------------
3817
3818    --  If the argument is other than a Boolean array type, there is no
3819    --  special expansion required.
3820
3821    --  For the packed case, we call the special routine in Exp_Pakd, except
3822    --  that if the component size is greater than one, we use the standard
3823    --  routine generating a gruesome loop (it is so peculiar to have packed
3824    --  arrays with non-standard Boolean representations anyway, so it does
3825    --  not matter that we do not handle this case efficiently).
3826
3827    --  For the unpacked case (and for the special packed case where we have
3828    --  non standard Booleans, as discussed above), we generate and insert
3829    --  into the tree the following function definition:
3830
3831    --     function Nnnn (A : arr) is
3832    --       B : arr;
3833    --     begin
3834    --       for J in a'range loop
3835    --          B (J) := not A (J);
3836    --       end loop;
3837    --       return B;
3838    --     end Nnnn;
3839
3840    --  Here arr is the actual subtype of the parameter (and hence always
3841    --  constrained). Then we replace the not with a call to this function.
3842
3843    procedure Expand_N_Op_Not (N : Node_Id) is
3844       Loc  : constant Source_Ptr := Sloc (N);
3845       Typ  : constant Entity_Id  := Etype (N);
3846       Opnd : Node_Id;
3847       Arr  : Entity_Id;
3848       A    : Entity_Id;
3849       B    : Entity_Id;
3850       J    : Entity_Id;
3851       A_J  : Node_Id;
3852       B_J  : Node_Id;
3853
3854       Func_Name      : Entity_Id;
3855       Loop_Statement : Node_Id;
3856
3857    begin
3858       Unary_Op_Validity_Checks (N);
3859
3860       --  For boolean operand, deal with non-standard booleans
3861
3862       if Is_Boolean_Type (Typ) then
3863          Adjust_Condition (Right_Opnd (N));
3864          Set_Etype (N, Standard_Boolean);
3865          Adjust_Result_Type (N, Typ);
3866          return;
3867       end if;
3868
3869       --  Only array types need any other processing
3870
3871       if not Is_Array_Type (Typ) then
3872          return;
3873       end if;
3874
3875       --  Case of array operand. If bit packed, handle it in Exp_Pakd
3876
3877       if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
3878          Expand_Packed_Not (N);
3879          return;
3880       end if;
3881
3882       --  Case of array operand which is not bit-packed
3883
3884       Opnd := Relocate_Node (Right_Opnd (N));
3885       Convert_To_Actual_Subtype (Opnd);
3886       Arr := Etype (Opnd);
3887       Ensure_Defined (Arr, N);
3888
3889       A := Make_Defining_Identifier (Loc, Name_uA);
3890       B := Make_Defining_Identifier (Loc, Name_uB);
3891       J := Make_Defining_Identifier (Loc, Name_uJ);
3892
3893       A_J :=
3894         Make_Indexed_Component (Loc,
3895           Prefix      => New_Reference_To (A, Loc),
3896           Expressions => New_List (New_Reference_To (J, Loc)));
3897
3898       B_J :=
3899         Make_Indexed_Component (Loc,
3900           Prefix      => New_Reference_To (B, Loc),
3901           Expressions => New_List (New_Reference_To (J, Loc)));
3902
3903       Loop_Statement :=
3904         Make_Implicit_Loop_Statement (N,
3905           Identifier => Empty,
3906
3907           Iteration_Scheme =>
3908             Make_Iteration_Scheme (Loc,
3909               Loop_Parameter_Specification =>
3910                 Make_Loop_Parameter_Specification (Loc,
3911                   Defining_Identifier => J,
3912                   Discrete_Subtype_Definition =>
3913                     Make_Attribute_Reference (Loc,
3914                       Prefix => Make_Identifier (Loc, Chars (A)),
3915                       Attribute_Name => Name_Range))),
3916
3917           Statements => New_List (
3918             Make_Assignment_Statement (Loc,
3919               Name       => B_J,
3920               Expression => Make_Op_Not (Loc, A_J))));
3921
3922       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
3923       Set_Is_Inlined (Func_Name);
3924
3925       Insert_Action (N,
3926         Make_Subprogram_Body (Loc,
3927           Specification =>
3928             Make_Function_Specification (Loc,
3929               Defining_Unit_Name => Func_Name,
3930               Parameter_Specifications => New_List (
3931                 Make_Parameter_Specification (Loc,
3932                   Defining_Identifier => A,
3933                   Parameter_Type      => New_Reference_To (Typ, Loc))),
3934               Subtype_Mark => New_Reference_To (Typ, Loc)),
3935
3936           Declarations => New_List (
3937             Make_Object_Declaration (Loc,
3938               Defining_Identifier => B,
3939               Object_Definition   => New_Reference_To (Arr, Loc))),
3940
3941           Handled_Statement_Sequence =>
3942             Make_Handled_Sequence_Of_Statements (Loc,
3943               Statements => New_List (
3944                 Loop_Statement,
3945                 Make_Return_Statement (Loc,
3946                   Expression =>
3947                     Make_Identifier (Loc, Chars (B)))))));
3948
3949       Rewrite (N,
3950         Make_Function_Call (Loc,
3951           Name => New_Reference_To (Func_Name, Loc),
3952           Parameter_Associations => New_List (Opnd)));
3953
3954       Analyze_And_Resolve (N, Typ);
3955    end Expand_N_Op_Not;
3956
3957    --------------------
3958    -- Expand_N_Op_Or --
3959    --------------------
3960
3961    procedure Expand_N_Op_Or (N : Node_Id) is
3962       Typ : constant Entity_Id := Etype (N);
3963
3964    begin
3965       Binary_Op_Validity_Checks (N);
3966
3967       if Is_Array_Type (Etype (N)) then
3968          Expand_Boolean_Operator (N);
3969
3970       elsif Is_Boolean_Type (Etype (N)) then
3971          Adjust_Condition (Left_Opnd (N));
3972          Adjust_Condition (Right_Opnd (N));
3973          Set_Etype (N, Standard_Boolean);
3974          Adjust_Result_Type (N, Typ);
3975       end if;
3976    end Expand_N_Op_Or;
3977
3978    ----------------------
3979    -- Expand_N_Op_Plus --
3980    ----------------------
3981
3982    procedure Expand_N_Op_Plus (N : Node_Id) is
3983    begin
3984       Unary_Op_Validity_Checks (N);
3985    end Expand_N_Op_Plus;
3986
3987    ---------------------
3988    -- Expand_N_Op_Rem --
3989    ---------------------
3990
3991    procedure Expand_N_Op_Rem (N : Node_Id) is
3992       Loc : constant Source_Ptr := Sloc (N);
3993
3994       Left  : constant Node_Id := Left_Opnd (N);
3995       Right : constant Node_Id := Right_Opnd (N);
3996
3997       LLB : Uint;
3998       Llo : Uint;
3999       Lhi : Uint;
4000       LOK : Boolean;
4001       Rlo : Uint;
4002       Rhi : Uint;
4003       ROK : Boolean;
4004       Typ : Entity_Id;
4005
4006    begin
4007       Binary_Op_Validity_Checks (N);
4008
4009       if Is_Integer_Type (Etype (N)) then
4010          Apply_Divide_Check (N);
4011       end if;
4012
4013       --  Deal with annoying case of largest negative number remainder
4014       --  minus one. Gigi does not handle this case correctly, because
4015       --  it generates a divide instruction which may trap in this case.
4016
4017       --  In fact the check is quite easy, if the right operand is -1,
4018       --  then the remainder is always 0, and we can just ignore the
4019       --  left operand completely in this case.
4020
4021       Determine_Range (Right, ROK, Rlo, Rhi);
4022       Determine_Range (Left, LOK, Llo, Lhi);
4023       LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
4024       Typ := Etype (N);
4025
4026       if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
4027         and then
4028          ((not LOK) or else (Llo = LLB))
4029       then
4030          Rewrite (N,
4031            Make_Conditional_Expression (Loc,
4032              Expressions => New_List (
4033                Make_Op_Eq (Loc,
4034                  Left_Opnd => Duplicate_Subexpr (Right),
4035                  Right_Opnd =>
4036                    Make_Integer_Literal (Loc, -1)),
4037
4038                Make_Integer_Literal (Loc, Uint_0),
4039
4040                Relocate_Node (N))));
4041
4042          Set_Analyzed (Next (Next (First (Expressions (N)))));
4043          Analyze_And_Resolve (N, Typ);
4044       end if;
4045    end Expand_N_Op_Rem;
4046
4047    -----------------------------
4048    -- Expand_N_Op_Rotate_Left --
4049    -----------------------------
4050
4051    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
4052    begin
4053       Binary_Op_Validity_Checks (N);
4054    end Expand_N_Op_Rotate_Left;
4055
4056    ------------------------------
4057    -- Expand_N_Op_Rotate_Right --
4058    ------------------------------
4059
4060    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
4061    begin
4062       Binary_Op_Validity_Checks (N);
4063    end Expand_N_Op_Rotate_Right;
4064
4065    ----------------------------
4066    -- Expand_N_Op_Shift_Left --
4067    ----------------------------
4068
4069    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
4070    begin
4071       Binary_Op_Validity_Checks (N);
4072    end Expand_N_Op_Shift_Left;
4073
4074    -----------------------------
4075    -- Expand_N_Op_Shift_Right --
4076    -----------------------------
4077
4078    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
4079    begin
4080       Binary_Op_Validity_Checks (N);
4081    end Expand_N_Op_Shift_Right;
4082
4083    ----------------------------------------
4084    -- Expand_N_Op_Shift_Right_Arithmetic --
4085    ----------------------------------------
4086
4087    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
4088    begin
4089       Binary_Op_Validity_Checks (N);
4090    end Expand_N_Op_Shift_Right_Arithmetic;
4091
4092    --------------------------
4093    -- Expand_N_Op_Subtract --
4094    --------------------------
4095
4096    procedure Expand_N_Op_Subtract (N : Node_Id) is
4097       Typ : constant Entity_Id := Etype (N);
4098
4099    begin
4100       Binary_Op_Validity_Checks (N);
4101
4102       --  N - 0 = N for integer types
4103
4104       if Is_Integer_Type (Typ)
4105         and then Compile_Time_Known_Value (Right_Opnd (N))
4106         and then Expr_Value (Right_Opnd (N)) = 0
4107       then
4108          Rewrite (N, Left_Opnd (N));
4109          return;
4110       end if;
4111
4112       --  Arithemtic overflow checks for signed integer/fixed point types
4113
4114       if Is_Signed_Integer_Type (Typ)
4115         or else Is_Fixed_Point_Type (Typ)
4116       then
4117          Apply_Arithmetic_Overflow_Check (N);
4118
4119       --  Vax floating-point types case
4120
4121       elsif Vax_Float (Typ) then
4122          Expand_Vax_Arith (N);
4123       end if;
4124    end Expand_N_Op_Subtract;
4125
4126    ---------------------
4127    -- Expand_N_Op_Xor --
4128    ---------------------
4129
4130    procedure Expand_N_Op_Xor (N : Node_Id) is
4131       Typ : constant Entity_Id := Etype (N);
4132
4133    begin
4134       Binary_Op_Validity_Checks (N);
4135
4136       if Is_Array_Type (Etype (N)) then
4137          Expand_Boolean_Operator (N);
4138
4139       elsif Is_Boolean_Type (Etype (N)) then
4140          Adjust_Condition (Left_Opnd (N));
4141          Adjust_Condition (Right_Opnd (N));
4142          Set_Etype (N, Standard_Boolean);
4143          Adjust_Result_Type (N, Typ);
4144       end if;
4145    end Expand_N_Op_Xor;
4146
4147    ----------------------
4148    -- Expand_N_Or_Else --
4149    ----------------------
4150
4151    --  Expand into conditional expression if Actions present, and also
4152    --  deal with optimizing case of arguments being True or False.
4153
4154    procedure Expand_N_Or_Else (N : Node_Id) is
4155       Loc     : constant Source_Ptr := Sloc (N);
4156       Typ     : constant Entity_Id  := Etype (N);
4157       Left    : constant Node_Id    := Left_Opnd (N);
4158       Right   : constant Node_Id    := Right_Opnd (N);
4159       Actlist : List_Id;
4160
4161    begin
4162       --  Deal with non-standard booleans
4163
4164       if Is_Boolean_Type (Typ) then
4165          Adjust_Condition (Left);
4166          Adjust_Condition (Right);
4167          Set_Etype (N, Standard_Boolean);
4168
4169       --  Check for cases of left argument is True or False
4170
4171       elsif Nkind (Left) = N_Identifier then
4172
4173          --  If left argument is False, change (False or else Right) to Right.
4174          --  Any actions associated with Right will be executed unconditionally
4175          --  and can thus be inserted into the tree unconditionally.
4176
4177          if Entity (Left) = Standard_False then
4178             if Present (Actions (N)) then
4179                Insert_Actions (N, Actions (N));
4180             end if;
4181
4182             Rewrite (N, Right);
4183             Adjust_Result_Type (N, Typ);
4184             return;
4185
4186          --  If left argument is True, change (True and then Right) to
4187          --  True. In this case we can forget the actions associated with
4188          --  Right, since they will never be executed.
4189
4190          elsif Entity (Left) = Standard_True then
4191             Kill_Dead_Code (Right);
4192             Kill_Dead_Code (Actions (N));
4193             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4194             Adjust_Result_Type (N, Typ);
4195             return;
4196          end if;
4197       end if;
4198
4199       --  If Actions are present, we expand
4200
4201       --     left or else right
4202
4203       --  into
4204
4205       --     if left then True else right end
4206
4207       --  with the actions becoming the Else_Actions of the conditional
4208       --  expression. This conditional expression is then further expanded
4209       --  (and will eventually disappear)
4210
4211       if Present (Actions (N)) then
4212          Actlist := Actions (N);
4213          Rewrite (N,
4214             Make_Conditional_Expression (Loc,
4215               Expressions => New_List (
4216                 Left,
4217                 New_Occurrence_Of (Standard_True, Loc),
4218                 Right)));
4219
4220          Set_Else_Actions (N, Actlist);
4221          Analyze_And_Resolve (N, Standard_Boolean);
4222          Adjust_Result_Type (N, Typ);
4223          return;
4224       end if;
4225
4226       --  No actions present, check for cases of right argument True/False
4227
4228       if Nkind (Right) = N_Identifier then
4229
4230          --  Change (Left or else False) to Left. Note that we know there
4231          --  are no actions associated with the True operand, since we
4232          --  just checked for this case above.
4233
4234          if Entity (Right) = Standard_False then
4235             Rewrite (N, Left);
4236
4237          --  Change (Left or else True) to True, making sure to preserve
4238          --  any side effects associated with the Left operand.
4239
4240          elsif Entity (Right) = Standard_True then
4241             Remove_Side_Effects (Left);
4242             Rewrite
4243               (N, New_Occurrence_Of (Standard_True, Loc));
4244          end if;
4245       end if;
4246
4247       Adjust_Result_Type (N, Typ);
4248    end Expand_N_Or_Else;
4249
4250    -----------------------------------
4251    -- Expand_N_Qualified_Expression --
4252    -----------------------------------
4253
4254    procedure Expand_N_Qualified_Expression (N : Node_Id) is
4255       Operand     : constant Node_Id   := Expression (N);
4256       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
4257
4258    begin
4259       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
4260    end Expand_N_Qualified_Expression;
4261
4262    ---------------------------------
4263    -- Expand_N_Selected_Component --
4264    ---------------------------------
4265
4266    --  If the selector is a discriminant of a concurrent object, rewrite the
4267    --  prefix to denote the corresponding record type.
4268
4269    procedure Expand_N_Selected_Component (N : Node_Id) is
4270       Loc   : constant Source_Ptr := Sloc (N);
4271       Par   : constant Node_Id    := Parent (N);
4272       P     : constant Node_Id    := Prefix (N);
4273       Disc  : Entity_Id;
4274       Ptyp  : Entity_Id := Underlying_Type (Etype (P));
4275       New_N : Node_Id;
4276
4277       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
4278       --  Gigi needs a temporary for prefixes that depend on a discriminant,
4279       --  unless the context of an assignment can provide size information.
4280
4281       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
4282       begin
4283          return
4284              (Nkind (Parent (Comp)) = N_Assignment_Statement
4285                and then Comp = Name (Parent (Comp)))
4286            or else
4287              (Present (Parent (Comp))
4288                 and then Nkind (Parent (Comp)) in N_Subexpr
4289                 and then In_Left_Hand_Side (Parent (Comp)));
4290       end In_Left_Hand_Side;
4291
4292    begin
4293       if Do_Discriminant_Check (N) then
4294
4295          --  Present the discrminant checking function to the backend,
4296          --  so that it can inline the call to the function.
4297
4298          Add_Inlined_Body
4299            (Discriminant_Checking_Func
4300              (Original_Record_Component (Entity (Selector_Name (N)))));
4301       end if;
4302
4303       --  Insert explicit dereference call for the checked storage pool case
4304
4305       if Is_Access_Type (Ptyp) then
4306          Insert_Dereference_Action (P);
4307          return;
4308       end if;
4309
4310    --  Gigi cannot handle unchecked conversions that are the prefix of
4311    --  a selected component with discriminants. This must be checked
4312    --  during expansion, because during analysis the type of the selector
4313    --  is not known at the point the prefix is analyzed. If the conversion
4314    --  is the target of an assignment, we cannot force the evaluation, of
4315    --  course.
4316
4317       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
4318         and then Has_Discriminants (Etype (N))
4319         and then not In_Left_Hand_Side (N)
4320       then
4321          Force_Evaluation (Prefix (N));
4322       end if;
4323
4324       --  Remaining processing applies only if selector is a discriminant
4325
4326       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
4327
4328          --  If the selector is a discriminant of a constrained record type,
4329          --  rewrite the expression with the actual value of the discriminant.
4330          --  Don't do this on the left hand of an assignment statement (this
4331          --  happens in generated code, and means we really want to set it!)
4332          --  We also only do this optimization for discrete types, and not
4333          --  for access types (access discriminants get us into trouble!)
4334          --  We also do not expand the prefix of an attribute or the
4335          --  operand of an object renaming declaration.
4336
4337          if Is_Record_Type (Ptyp)
4338            and then Has_Discriminants (Ptyp)
4339            and then Is_Constrained (Ptyp)
4340            and then Is_Discrete_Type (Etype (N))
4341            and then (Nkind (Par) /= N_Assignment_Statement
4342                        or else Name (Par) /= N)
4343            and then (Nkind (Par) /= N_Attribute_Reference
4344                        or else Prefix (Par) /= N)
4345            and then not Is_Renamed_Object (N)
4346          then
4347             declare
4348                D : Entity_Id;
4349                E : Elmt_Id;
4350
4351             begin
4352                D := First_Discriminant (Ptyp);
4353                E := First_Elmt (Discriminant_Constraint (Ptyp));
4354
4355                while Present (E) loop
4356                   if D = Entity (Selector_Name (N)) then
4357
4358                      --  In the context of a case statement, the expression
4359                      --  may have the base type of the discriminant, and we
4360                      --  need to preserve the constraint to avoid spurious
4361                      --  errors on missing cases.
4362
4363                      if Nkind (Parent (N)) = N_Case_Statement
4364                        and then Etype (Node (E)) /= Etype (D)
4365                      then
4366                         Rewrite (N,
4367                           Make_Qualified_Expression (Loc,
4368                             Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
4369                             Expression   => New_Copy (Node (E))));
4370                         Analyze (N);
4371                      else
4372                         Rewrite (N, New_Copy (Node (E)));
4373                      end if;
4374
4375                      Set_Is_Static_Expression (N, False);
4376                      return;
4377                   end if;
4378
4379                   Next_Elmt (E);
4380                   Next_Discriminant (D);
4381                end loop;
4382
4383                --  Note: the above loop should always terminate, but if
4384                --  it does not, we just missed an optimization due to
4385                --  some glitch (perhaps a previous error), so ignore!
4386             end;
4387          end if;
4388
4389          --  The only remaining processing is in the case of a discriminant of
4390          --  a concurrent object, where we rewrite the prefix to denote the
4391          --  corresponding record type. If the type is derived and has renamed
4392          --  discriminants, use corresponding discriminant, which is the one
4393          --  that appears in the corresponding record.
4394
4395          if not Is_Concurrent_Type (Ptyp) then
4396             return;
4397          end if;
4398
4399          Disc := Entity (Selector_Name (N));
4400
4401          if Is_Derived_Type (Ptyp)
4402            and then Present (Corresponding_Discriminant (Disc))
4403          then
4404             Disc := Corresponding_Discriminant (Disc);
4405          end if;
4406
4407          New_N :=
4408            Make_Selected_Component (Loc,
4409              Prefix =>
4410                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
4411                  New_Copy_Tree (P)),
4412              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
4413
4414          Rewrite (N, New_N);
4415          Analyze (N);
4416       end if;
4417
4418    end Expand_N_Selected_Component;
4419
4420    --------------------
4421    -- Expand_N_Slice --
4422    --------------------
4423
4424    procedure Expand_N_Slice (N : Node_Id) is
4425       Loc  : constant Source_Ptr := Sloc (N);
4426       Typ  : constant Entity_Id  := Etype (N);
4427       Pfx  : constant Node_Id    := Prefix (N);
4428       Ptp  : Entity_Id           := Etype (Pfx);
4429       Ent  : Entity_Id;
4430       Decl : Node_Id;
4431
4432    begin
4433       --  Special handling for access types
4434
4435       if Is_Access_Type (Ptp) then
4436
4437          --  Check for explicit dereference required for checked pool
4438
4439          Insert_Dereference_Action (Pfx);
4440
4441          --  If we have an access to a packed array type, then put in an
4442          --  explicit dereference. We do this in case the slice must be
4443          --  expanded, and we want to make sure we get an access check.
4444
4445          Ptp := Designated_Type (Ptp);
4446
4447          if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
4448             Rewrite (Pfx,
4449               Make_Explicit_Dereference (Sloc (N),
4450                 Prefix => Relocate_Node (Pfx)));
4451
4452             Analyze_And_Resolve (Pfx, Ptp);
4453
4454             --  The prefix will now carry the Access_Check flag for the back
4455             --  end, remove it from slice itself.
4456
4457             Set_Do_Access_Check (N, False);
4458          end if;
4459       end if;
4460
4461       --  Range checks are potentially also needed for cases involving
4462       --  a slice indexed by a subtype indication, but Do_Range_Check
4463       --  can currently only be set for expressions ???
4464
4465       if not Index_Checks_Suppressed (Ptp)
4466         and then (not Is_Entity_Name (Pfx)
4467                    or else not Index_Checks_Suppressed (Entity (Pfx)))
4468         and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
4469       then
4470          Enable_Range_Check (Discrete_Range (N));
4471       end if;
4472
4473       --  The remaining case to be handled is packed slices. We can leave
4474       --  packed slices as they are in the following situations:
4475
4476       --    1. Right or left side of an assignment (we can handle this
4477       --       situation correctly in the assignment statement expansion).
4478
4479       --    2. Prefix of indexed component (the slide is optimized away
4480       --       in this case, see the start of Expand_N_Slice.
4481
4482       --    3. Object renaming declaration, since we want the name of
4483       --       the slice, not the value.
4484
4485       --    4. Argument to procedure call, since copy-in/copy-out handling
4486       --       may be required, and this is handled in the expansion of
4487       --       call itself.
4488
4489       --    5. Prefix of an address attribute (this is an error which
4490       --       is caught elsewhere, and the expansion would intefere
4491       --       with generating the error message).
4492
4493       if Is_Packed (Typ)
4494         and then Nkind (Parent (N)) /= N_Assignment_Statement
4495         and then Nkind (Parent (N)) /= N_Indexed_Component
4496         and then not Is_Renamed_Object (N)
4497         and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
4498         and then (Nkind (Parent (N)) /= N_Attribute_Reference
4499                     or else
4500                   Attribute_Name (Parent (N)) /= Name_Address)
4501       then
4502          Ent :=
4503            Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
4504
4505          Decl :=
4506            Make_Object_Declaration (Loc,
4507              Defining_Identifier => Ent,
4508              Object_Definition   => New_Occurrence_Of (Typ, Loc));
4509
4510          Set_No_Initialization (Decl);
4511
4512          Insert_Actions (N, New_List (
4513            Decl,
4514            Make_Assignment_Statement (Loc,
4515              Name => New_Occurrence_Of (Ent, Loc),
4516              Expression => Relocate_Node (N))));
4517
4518          Rewrite (N, New_Occurrence_Of (Ent, Loc));
4519          Analyze_And_Resolve (N, Typ);
4520       end if;
4521    end Expand_N_Slice;
4522
4523    ------------------------------
4524    -- Expand_N_Type_Conversion --
4525    ------------------------------
4526
4527    procedure Expand_N_Type_Conversion (N : Node_Id) is
4528       Loc          : constant Source_Ptr := Sloc (N);
4529       Operand      : constant Node_Id    := Expression (N);
4530       Target_Type  : constant Entity_Id  := Etype (N);
4531       Operand_Type : Entity_Id           := Etype (Operand);
4532
4533       procedure Handle_Changed_Representation;
4534       --  This is called in the case of record and array type conversions
4535       --  to see if there is a change of representation to be handled.
4536       --  Change of representation is actually handled at the assignment
4537       --  statement level, and what this procedure does is rewrite node N
4538       --  conversion as an assignment to temporary. If there is no change
4539       --  of representation, then the conversion node is unchanged.
4540
4541       procedure Real_Range_Check;
4542       --  Handles generation of range check for real target value
4543
4544       -----------------------------------
4545       -- Handle_Changed_Representation --
4546       -----------------------------------
4547
4548       procedure Handle_Changed_Representation is
4549          Temp : Entity_Id;
4550          Decl : Node_Id;
4551          Odef : Node_Id;
4552          Disc : Node_Id;
4553          N_Ix : Node_Id;
4554          Cons : List_Id;
4555
4556       begin
4557          --  Nothing to do if no change of representation
4558
4559          if Same_Representation (Operand_Type, Target_Type) then
4560             return;
4561
4562          --  The real change of representation work is done by the assignment
4563          --  statement processing. So if this type conversion is appearing as
4564          --  the expression of an assignment statement, nothing needs to be
4565          --  done to the conversion.
4566
4567          elsif Nkind (Parent (N)) = N_Assignment_Statement then
4568             return;
4569
4570          --  Otherwise we need to generate a temporary variable, and do the
4571          --  change of representation assignment into that temporary variable.
4572          --  The conversion is then replaced by a reference to this variable.
4573
4574          else
4575             Cons := No_List;
4576
4577             --  If type is unconstrained we have to add a constraint,
4578             --  copied from the actual value of the left hand side.
4579
4580             if not Is_Constrained (Target_Type) then
4581                if Has_Discriminants (Operand_Type) then
4582                   Disc := First_Discriminant (Operand_Type);
4583                   Cons := New_List;
4584                   while Present (Disc) loop
4585                      Append_To (Cons,
4586                        Make_Selected_Component (Loc,
4587                          Prefix => Duplicate_Subexpr (Operand),
4588                          Selector_Name =>
4589                            Make_Identifier (Loc, Chars (Disc))));
4590                      Next_Discriminant (Disc);
4591                   end loop;
4592
4593                elsif Is_Array_Type (Operand_Type) then
4594                   N_Ix := First_Index (Target_Type);
4595                   Cons := New_List;
4596
4597                   for J in 1 .. Number_Dimensions (Operand_Type) loop
4598
4599                      --  We convert the bounds explicitly. We use an unchecked
4600                      --  conversion because bounds checks are done elsewhere.
4601
4602                      Append_To (Cons,
4603                        Make_Range (Loc,
4604                          Low_Bound =>
4605                            Unchecked_Convert_To (Etype (N_Ix),
4606                              Make_Attribute_Reference (Loc,
4607                                Prefix =>
4608                                  Duplicate_Subexpr
4609                                    (Operand, Name_Req => True),
4610                                Attribute_Name => Name_First,
4611                                Expressions    => New_List (
4612                                  Make_Integer_Literal (Loc, J)))),
4613
4614                          High_Bound =>
4615                            Unchecked_Convert_To (Etype (N_Ix),
4616                              Make_Attribute_Reference (Loc,
4617                                Prefix =>
4618                                  Duplicate_Subexpr
4619                                    (Operand, Name_Req => True),
4620                                Attribute_Name => Name_Last,
4621                                Expressions    => New_List (
4622                                  Make_Integer_Literal (Loc, J))))));
4623
4624                      Next_Index (N_Ix);
4625                   end loop;
4626                end if;
4627             end if;
4628
4629             Odef := New_Occurrence_Of (Target_Type, Loc);
4630
4631             if Present (Cons) then
4632                Odef :=
4633                  Make_Subtype_Indication (Loc,
4634                    Subtype_Mark => Odef,
4635                    Constraint =>
4636                      Make_Index_Or_Discriminant_Constraint (Loc,
4637                        Constraints => Cons));
4638             end if;
4639
4640             Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
4641             Decl :=
4642               Make_Object_Declaration (Loc,
4643                 Defining_Identifier => Temp,
4644                 Object_Definition   => Odef);
4645
4646             Set_No_Initialization (Decl, True);
4647
4648             --  Insert required actions. It is essential to suppress checks
4649             --  since we have suppressed default initialization, which means
4650             --  that the variable we create may have no discriminants.
4651
4652             Insert_Actions (N,
4653               New_List (
4654                 Decl,
4655                 Make_Assignment_Statement (Loc,
4656                   Name => New_Occurrence_Of (Temp, Loc),
4657                   Expression => Relocate_Node (N))),
4658                 Suppress => All_Checks);
4659
4660             Rewrite (N, New_Occurrence_Of (Temp, Loc));
4661             return;
4662          end if;
4663       end Handle_Changed_Representation;
4664
4665       ----------------------
4666       -- Real_Range_Check --
4667       ----------------------
4668
4669       --  Case of conversions to floating-point or fixed-point. If range
4670       --  checks are enabled and the target type has a range constraint,
4671       --  we convert:
4672
4673       --     typ (x)
4674
4675       --       to
4676
4677       --     Tnn : typ'Base := typ'Base (x);
4678       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
4679       --     Tnn
4680
4681       procedure Real_Range_Check is
4682          Btyp : constant Entity_Id := Base_Type (Target_Type);
4683          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
4684          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
4685          Conv : Node_Id;
4686          Tnn  : Entity_Id;
4687
4688       begin
4689          --  Nothing to do if conversion was rewritten
4690
4691          if Nkind (N) /= N_Type_Conversion then
4692             return;
4693          end if;
4694
4695          --  Nothing to do if range checks suppressed, or target has the
4696          --  same range as the base type (or is the base type).
4697
4698          if Range_Checks_Suppressed (Target_Type)
4699            or else (Lo = Type_Low_Bound (Btyp)
4700                       and then
4701                     Hi = Type_High_Bound (Btyp))
4702          then
4703             return;
4704          end if;
4705
4706          --  Nothing to do if expression is an entity on which checks
4707          --  have been suppressed.
4708
4709          if Is_Entity_Name (Expression (N))
4710            and then Range_Checks_Suppressed (Entity (Expression (N)))
4711          then
4712             return;
4713          end if;
4714
4715          --  Here we rewrite the conversion as described above
4716
4717          Conv := Relocate_Node (N);
4718          Rewrite
4719            (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
4720          Set_Etype (Conv, Btyp);
4721
4722          --  Skip overflow check for integer to float conversions,
4723          --  since it is not needed, and in any case gigi generates
4724          --  incorrect code for such overflow checks ???
4725
4726          if not Is_Integer_Type (Etype (Expression (N))) then
4727             Set_Do_Overflow_Check (Conv, True);
4728          end if;
4729
4730          Tnn :=
4731            Make_Defining_Identifier (Loc,
4732              Chars => New_Internal_Name ('T'));
4733
4734          Insert_Actions (N, New_List (
4735            Make_Object_Declaration (Loc,
4736              Defining_Identifier => Tnn,
4737              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
4738              Expression => Conv),
4739
4740            Make_Raise_Constraint_Error (Loc,
4741             Condition =>
4742              Make_Or_Else (Loc,
4743                Left_Opnd =>
4744                  Make_Op_Lt (Loc,
4745                    Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
4746                    Right_Opnd =>
4747                      Make_Attribute_Reference (Loc,
4748                        Attribute_Name => Name_First,
4749                        Prefix =>
4750                          New_Occurrence_Of (Target_Type, Loc))),
4751
4752                Right_Opnd =>
4753                  Make_Op_Gt (Loc,
4754                    Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
4755                    Right_Opnd =>
4756                      Make_Attribute_Reference (Loc,
4757                        Attribute_Name => Name_Last,
4758                        Prefix =>
4759                          New_Occurrence_Of (Target_Type, Loc)))))));
4760
4761          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
4762          Analyze_And_Resolve (N, Btyp);
4763       end Real_Range_Check;
4764
4765    --  Start of processing for Expand_N_Type_Conversion
4766
4767    begin
4768       --  Nothing at all to do if conversion is to the identical type
4769       --  so remove the conversion completely, it is useless.
4770
4771       if Operand_Type = Target_Type then
4772          Rewrite (N, Relocate_Node (Expression (N)));
4773          return;
4774       end if;
4775
4776       --  Deal with Vax floating-point cases
4777
4778       if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
4779          Expand_Vax_Conversion (N);
4780          return;
4781       end if;
4782
4783       --  Nothing to do if this is the second argument of read. This
4784       --  is a "backwards" conversion that will be handled by the
4785       --  specialized code in attribute processing.
4786
4787       if Nkind (Parent (N)) = N_Attribute_Reference
4788         and then Attribute_Name (Parent (N)) = Name_Read
4789         and then Next (First (Expressions (Parent (N)))) = N
4790       then
4791          return;
4792       end if;
4793
4794       --  Here if we may need to expand conversion
4795
4796       --  Special case of converting from non-standard boolean type
4797
4798       if Is_Boolean_Type (Operand_Type)
4799         and then (Nonzero_Is_True (Operand_Type))
4800       then
4801          Adjust_Condition (Operand);
4802          Set_Etype (Operand, Standard_Boolean);
4803          Operand_Type := Standard_Boolean;
4804       end if;
4805
4806       --  Case of converting to an access type
4807
4808       if Is_Access_Type (Target_Type) then
4809
4810          --  Apply an accessibility check if the operand is an
4811          --  access parameter. Note that other checks may still
4812          --  need to be applied below (such as tagged type checks).
4813
4814          if Is_Entity_Name (Operand)
4815            and then Ekind (Entity (Operand)) in Formal_Kind
4816            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
4817          then
4818             Apply_Accessibility_Check (Operand, Target_Type);
4819
4820          --  If the level of the operand type is statically deeper
4821          --  then the level of the target type, then force Program_Error.
4822          --  Note that this can only occur for cases where the attribute
4823          --  is within the body of an instantiation (otherwise the
4824          --  conversion will already have been rejected as illegal).
4825          --  Note: warnings are issued by the analyzer for the instance
4826          --  cases.
4827
4828          elsif In_Instance_Body
4829            and then Type_Access_Level (Operand_Type)
4830                   > Type_Access_Level (Target_Type)
4831          then
4832             Rewrite (N, Make_Raise_Program_Error (Sloc (N)));
4833             Set_Etype (N, Target_Type);
4834
4835          --  When the operand is a selected access discriminant
4836          --  the check needs to be made against the level of the
4837          --  object denoted by the prefix of the selected name.
4838          --  Force Program_Error for this case as well (this
4839          --  accessibility violation can only happen if within
4840          --  the body of an instantiation).
4841
4842          elsif In_Instance_Body
4843            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
4844            and then Nkind (Operand) = N_Selected_Component
4845            and then Object_Access_Level (Operand) >
4846                       Type_Access_Level (Target_Type)
4847          then
4848             Rewrite (N, Make_Raise_Program_Error (Sloc (N)));
4849             Set_Etype (N, Target_Type);
4850          end if;
4851       end if;
4852
4853       --  Case of conversions of tagged types and access to tagged types
4854
4855       --  When needed, that is to say when the expression is class-wide,
4856       --  Add runtime a tag check for (strict) downward conversion by using
4857       --  the membership test, generating:
4858
4859       --      [constraint_error when Operand not in Target_Type'Class]
4860
4861       --  or in the access type case
4862
4863       --      [constraint_error
4864       --        when Operand /= null
4865       --          and then Operand.all not in
4866       --            Designated_Type (Target_Type)'Class]
4867
4868       if (Is_Access_Type (Target_Type)
4869            and then Is_Tagged_Type (Designated_Type (Target_Type)))
4870         or else Is_Tagged_Type (Target_Type)
4871       then
4872          --  Do not do any expansion in the access type case if the
4873          --  parent is a renaming, since this is an error situation
4874          --  which will be caught by Sem_Ch8, and the expansion can
4875          --  intefere with this error check.
4876
4877          if Is_Access_Type (Target_Type)
4878            and then Is_Renamed_Object (N)
4879          then
4880             return;
4881          end if;
4882
4883          --  Oherwise, proceed with processing tagged conversion
4884
4885          declare
4886             Actual_Operand_Type : Entity_Id;
4887             Actual_Target_Type  : Entity_Id;
4888
4889             Cond : Node_Id;
4890
4891          begin
4892             if Is_Access_Type (Target_Type) then
4893                Actual_Operand_Type := Designated_Type (Operand_Type);
4894                Actual_Target_Type  := Designated_Type (Target_Type);
4895
4896             else
4897                Actual_Operand_Type := Operand_Type;
4898                Actual_Target_Type  := Target_Type;
4899             end if;
4900
4901             if Is_Class_Wide_Type (Actual_Operand_Type)
4902               and then Root_Type (Actual_Operand_Type) /=  Actual_Target_Type
4903               and then Is_Ancestor
4904                          (Root_Type (Actual_Operand_Type),
4905                           Actual_Target_Type)
4906               and then not Tag_Checks_Suppressed (Actual_Target_Type)
4907             then
4908                --  The conversion is valid for any descendant of the
4909                --  target type
4910
4911                Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
4912
4913                if Is_Access_Type (Target_Type) then
4914                   Cond :=
4915                      Make_And_Then (Loc,
4916                        Left_Opnd =>
4917                          Make_Op_Ne (Loc,
4918                            Left_Opnd  => Duplicate_Subexpr (Operand),
4919                            Right_Opnd => Make_Null (Loc)),
4920
4921                        Right_Opnd =>
4922                          Make_Not_In (Loc,
4923                            Left_Opnd  =>
4924                              Make_Explicit_Dereference (Loc,
4925                                Prefix => Duplicate_Subexpr (Operand)),
4926                            Right_Opnd =>
4927                              New_Reference_To (Actual_Target_Type, Loc)));
4928
4929                else
4930                   Cond :=
4931                     Make_Not_In (Loc,
4932                       Left_Opnd  => Duplicate_Subexpr (Operand),
4933                       Right_Opnd =>
4934                         New_Reference_To (Actual_Target_Type, Loc));
4935                end if;
4936
4937                Insert_Action (N,
4938                  Make_Raise_Constraint_Error (Loc,
4939                    Condition => Cond));
4940
4941                Change_Conversion_To_Unchecked (N);
4942                Analyze_And_Resolve (N, Target_Type);
4943             end if;
4944          end;
4945
4946       --  Case of other access type conversions
4947
4948       elsif Is_Access_Type (Target_Type) then
4949          Apply_Constraint_Check (Operand, Target_Type);
4950
4951       --  Case of conversions from a fixed-point type
4952
4953       --  These conversions require special expansion and processing, found
4954       --  in the Exp_Fixd package. We ignore cases where Conversion_OK is
4955       --  set, since from a semantic point of view, these are simple integer
4956       --  conversions, which do not need further processing.
4957
4958       elsif Is_Fixed_Point_Type (Operand_Type)
4959         and then not Conversion_OK (N)
4960       then
4961          --  We should never see universal fixed at this case, since the
4962          --  expansion of the constituent divide or multiply should have
4963          --  eliminated the explicit mention of universal fixed.
4964
4965          pragma Assert (Operand_Type /= Universal_Fixed);
4966
4967          --  Check for special case of the conversion to universal real
4968          --  that occurs as a result of the use of a round attribute.
4969          --  In this case, the real type for the conversion is taken
4970          --  from the target type of the Round attribute and the
4971          --  result must be marked as rounded.
4972
4973          if Target_Type = Universal_Real
4974            and then Nkind (Parent (N)) = N_Attribute_Reference
4975            and then Attribute_Name (Parent (N)) = Name_Round
4976          then
4977             Set_Rounded_Result (N);
4978             Set_Etype (N, Etype (Parent (N)));
4979          end if;
4980
4981          --  Otherwise do correct fixed-conversion, but skip these if the
4982          --  Conversion_OK flag is set, because from a semantic point of
4983          --  view these are simple integer conversions needing no further
4984          --  processing (the backend will simply treat them as integers)
4985
4986          if not Conversion_OK (N) then
4987             if Is_Fixed_Point_Type (Etype (N)) then
4988                Expand_Convert_Fixed_To_Fixed (N);
4989                Real_Range_Check;
4990
4991             elsif Is_Integer_Type (Etype (N)) then
4992                Expand_Convert_Fixed_To_Integer (N);
4993
4994             else
4995                pragma Assert (Is_Floating_Point_Type (Etype (N)));
4996                Expand_Convert_Fixed_To_Float (N);
4997                Real_Range_Check;
4998             end if;
4999          end if;
5000
5001       --  Case of conversions to a fixed-point type
5002
5003       --  These conversions require special expansion and processing, found
5004       --  in the Exp_Fixd package. Again, ignore cases where Conversion_OK
5005       --  is set, since from a semantic point of view, these are simple
5006       --  integer conversions, which do not need further processing.
5007
5008       elsif Is_Fixed_Point_Type (Target_Type)
5009         and then not Conversion_OK (N)
5010       then
5011          if Is_Integer_Type (Operand_Type) then
5012             Expand_Convert_Integer_To_Fixed (N);
5013             Real_Range_Check;
5014          else
5015             pragma Assert (Is_Floating_Point_Type (Operand_Type));
5016             Expand_Convert_Float_To_Fixed (N);
5017             Real_Range_Check;
5018          end if;
5019
5020       --  Case of float-to-integer conversions
5021
5022       --  We also handle float-to-fixed conversions with Conversion_OK set
5023       --  since semantically the fixed-point target is treated as though it
5024       --  were an integer in such cases.
5025
5026       elsif Is_Floating_Point_Type (Operand_Type)
5027         and then
5028           (Is_Integer_Type (Target_Type)
5029             or else
5030           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
5031       then
5032          --  Special processing required if the conversion is the expression
5033          --  of a Truncation attribute reference. In this case we replace:
5034
5035          --     ityp (ftyp'Truncation (x))
5036
5037          --  by
5038
5039          --     ityp (x)
5040
5041          --  with the Float_Truncate flag set. This is clearly more efficient.
5042
5043          if Nkind (Operand) = N_Attribute_Reference
5044            and then Attribute_Name (Operand) = Name_Truncation
5045          then
5046             Rewrite (Operand,
5047               Relocate_Node (First (Expressions (Operand))));
5048             Set_Float_Truncate (N, True);
5049          end if;
5050
5051          --  One more check here, gcc is still not able to do conversions of
5052          --  this type with proper overflow checking, and so gigi is doing an
5053          --  approximation of what is required by doing floating-point compares
5054          --  with the end-point. But that can lose precision in some cases, and
5055          --  give a wrong result. Converting the operand to Long_Long_Float is
5056          --  helpful, but still does not catch all cases with 64-bit integers
5057          --  on targets with only 64-bit floats ???
5058
5059          if Do_Range_Check (Expression (N)) then
5060             Rewrite (Expression (N),
5061               Make_Type_Conversion (Loc,
5062                 Subtype_Mark =>
5063                   New_Occurrence_Of (Standard_Long_Long_Float, Loc),
5064                 Expression =>
5065                   Relocate_Node (Expression (N))));
5066
5067             Set_Etype (Expression (N), Standard_Long_Long_Float);
5068             Enable_Range_Check (Expression (N));
5069             Set_Do_Range_Check (Expression (Expression (N)), False);
5070          end if;
5071
5072       --  Case of array conversions
5073
5074       --  Expansion of array conversions, add required length/range checks
5075       --  but only do this if there is no change of representation. For
5076       --  handling of this case, see Handle_Changed_Representation.
5077
5078       elsif Is_Array_Type (Target_Type) then
5079
5080          if Is_Constrained (Target_Type) then
5081             Apply_Length_Check (Operand, Target_Type);
5082          else
5083             Apply_Range_Check (Operand, Target_Type);
5084          end if;
5085
5086          Handle_Changed_Representation;
5087
5088       --  Case of conversions of discriminated types
5089
5090       --  Add required discriminant checks if target is constrained. Again
5091       --  this change is skipped if we have a change of representation.
5092
5093       elsif Has_Discriminants (Target_Type)
5094         and then Is_Constrained (Target_Type)
5095       then
5096          Apply_Discriminant_Check (Operand, Target_Type);
5097          Handle_Changed_Representation;
5098
5099       --  Case of all other record conversions. The only processing required
5100       --  is to check for a change of representation requiring the special
5101       --  assignment processing.
5102
5103       elsif Is_Record_Type (Target_Type) then
5104          Handle_Changed_Representation;
5105
5106       --  Case of conversions of enumeration types
5107
5108       elsif Is_Enumeration_Type (Target_Type) then
5109
5110          --  Special processing is required if there is a change of
5111          --  representation (from enumeration representation clauses)
5112
5113          if not Same_Representation (Target_Type, Operand_Type) then
5114
5115             --  Convert: x(y) to x'val (ytyp'val (y))
5116
5117             Rewrite (N,
5118                Make_Attribute_Reference (Loc,
5119                  Prefix => New_Occurrence_Of (Target_Type, Loc),
5120                  Attribute_Name => Name_Val,
5121                  Expressions => New_List (
5122                    Make_Attribute_Reference (Loc,
5123                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
5124                      Attribute_Name => Name_Pos,
5125                      Expressions => New_List (Operand)))));
5126
5127             Analyze_And_Resolve (N, Target_Type);
5128          end if;
5129
5130       --  Case of conversions to floating-point
5131
5132       elsif Is_Floating_Point_Type (Target_Type) then
5133          Real_Range_Check;
5134
5135       --  The remaining cases require no front end processing
5136
5137       else
5138          null;
5139       end if;
5140
5141       --  At this stage, either the conversion node has been transformed
5142       --  into some other equivalent expression, or left as a conversion
5143       --  that can be handled by Gigi. The conversions that Gigi can handle
5144       --  are the following:
5145
5146       --    Conversions with no change of representation or type
5147
5148       --    Numeric conversions involving integer values, floating-point
5149       --    values, and fixed-point values. Fixed-point values are allowed
5150       --    only if Conversion_OK is set, i.e. if the fixed-point values
5151       --    are to be treated as integers.
5152
5153       --  No other conversions should be passed to Gigi.
5154
5155    end Expand_N_Type_Conversion;
5156
5157    -----------------------------------
5158    -- Expand_N_Unchecked_Expression --
5159    -----------------------------------
5160
5161    --  Remove the unchecked expression node from the tree. It's job was simply
5162    --  to make sure that its constituent expression was handled with checks
5163    --  off, and now that that is done, we can remove it from the tree, and
5164    --  indeed must, since gigi does not expect to see these nodes.
5165
5166    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
5167       Exp : constant Node_Id := Expression (N);
5168
5169    begin
5170       Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
5171       Rewrite (N, Exp);
5172    end Expand_N_Unchecked_Expression;
5173
5174    ----------------------------------------
5175    -- Expand_N_Unchecked_Type_Conversion --
5176    ----------------------------------------
5177
5178    --  If this cannot be handled by Gigi and we haven't already made
5179    --  a temporary for it, do it now.
5180
5181    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
5182       Target_Type  : constant Entity_Id := Etype (N);
5183       Operand      : constant Node_Id   := Expression (N);
5184       Operand_Type : constant Entity_Id := Etype (Operand);
5185
5186    begin
5187       --  If we have a conversion of a compile time known value to a target
5188       --  type and the value is in range of the target type, then we can simply
5189       --  replace the construct by an integer literal of the correct type. We
5190       --  only apply this to integer types being converted. Possibly it may
5191       --  apply in other cases, but it is too much trouble to worry about.
5192
5193       --  Note that we do not do this transformation if the Kill_Range_Check
5194       --  flag is set, since then the value may be outside the expected range.
5195       --  This happens in the Normalize_Scalars case.
5196
5197       if Is_Integer_Type (Target_Type)
5198         and then Is_Integer_Type (Operand_Type)
5199         and then Compile_Time_Known_Value (Operand)
5200         and then not Kill_Range_Check (N)
5201       then
5202          declare
5203             Val : constant Uint := Expr_Value (Operand);
5204
5205          begin
5206             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
5207                  and then
5208                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
5209                  and then
5210                Val >= Expr_Value (Type_Low_Bound (Target_Type))
5211                  and then
5212                Val <= Expr_Value (Type_High_Bound (Target_Type))
5213             then
5214                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
5215                Analyze_And_Resolve (N, Target_Type);
5216                return;
5217             end if;
5218          end;
5219       end if;
5220
5221       --  Nothing to do if conversion is safe
5222
5223       if Safe_Unchecked_Type_Conversion (N) then
5224          return;
5225       end if;
5226
5227       --  Otherwise force evaluation unless Assignment_OK flag is set (this
5228       --  flag indicates ??? -- more comments needed here)
5229
5230       if Assignment_OK (N) then
5231          null;
5232       else
5233          Force_Evaluation (N);
5234       end if;
5235    end Expand_N_Unchecked_Type_Conversion;
5236
5237    ----------------------------
5238    -- Expand_Record_Equality --
5239    ----------------------------
5240
5241    --  For non-variant records, Equality is expanded when needed into:
5242
5243    --      and then Lhs.Discr1 = Rhs.Discr1
5244    --      and then ...
5245    --      and then Lhs.Discrn = Rhs.Discrn
5246    --      and then Lhs.Cmp1 = Rhs.Cmp1
5247    --      and then ...
5248    --      and then Lhs.Cmpn = Rhs.Cmpn
5249
5250    --  The expression is folded by the back-end for adjacent fields. This
5251    --  function is called for tagged record in only one occasion: for imple-
5252    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
5253    --  otherwise the primitive "=" is used directly.
5254
5255    function Expand_Record_Equality
5256      (Nod    : Node_Id;
5257       Typ    : Entity_Id;
5258       Lhs    : Node_Id;
5259       Rhs    : Node_Id;
5260       Bodies : List_Id)
5261       return   Node_Id
5262    is
5263       Loc : constant Source_Ptr := Sloc (Nod);
5264
5265       function Suitable_Element (C : Entity_Id) return Entity_Id;
5266       --  Return the first field to compare beginning with C, skipping the
5267       --  inherited components
5268
5269       function Suitable_Element (C : Entity_Id) return Entity_Id is
5270       begin
5271          if No (C) then
5272             return Empty;
5273
5274          elsif Ekind (C) /= E_Discriminant
5275            and then Ekind (C) /= E_Component
5276          then
5277             return Suitable_Element (Next_Entity (C));
5278
5279          elsif Is_Tagged_Type (Typ)
5280            and then C /= Original_Record_Component (C)
5281          then
5282             return Suitable_Element (Next_Entity (C));
5283
5284          elsif Chars (C) = Name_uController
5285            or else Chars (C) = Name_uTag
5286          then
5287             return Suitable_Element (Next_Entity (C));
5288
5289          else
5290             return C;
5291          end if;
5292       end Suitable_Element;
5293
5294       Result : Node_Id;
5295       C      : Entity_Id;
5296
5297       First_Time : Boolean := True;
5298
5299    --  Start of processing for Expand_Record_Equality
5300
5301    begin
5302       --  Special processing for the unchecked union case, which will occur
5303       --  only in the context of tagged types and dynamic dispatching, since
5304       --  other cases are handled statically. We return True, but insert a
5305       --  raise Program_Error statement.
5306
5307       if Is_Unchecked_Union (Typ) then
5308
5309          --  If this is a component of an enclosing record, return the Raise
5310          --  statement directly.
5311
5312          if No (Parent (Lhs)) then
5313             Result := Make_Raise_Program_Error (Loc);
5314             Set_Etype (Result, Standard_Boolean);
5315             return Result;
5316
5317          else
5318             Insert_Action (Lhs,
5319               Make_Raise_Program_Error (Loc));
5320             return New_Occurrence_Of (Standard_True, Loc);
5321          end if;
5322       end if;
5323
5324       --  Generates the following code: (assuming that Typ has one Discr and
5325       --  component C2 is also a record)
5326
5327       --   True
5328       --     and then Lhs.Discr1 = Rhs.Discr1
5329       --     and then Lhs.C1 = Rhs.C1
5330       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
5331       --     and then ...
5332       --     and then Lhs.Cmpn = Rhs.Cmpn
5333
5334       Result := New_Reference_To (Standard_True, Loc);
5335       C := Suitable_Element (First_Entity (Typ));
5336
5337       while Present (C) loop
5338
5339          declare
5340             New_Lhs : Node_Id;
5341             New_Rhs : Node_Id;
5342
5343          begin
5344             if First_Time then
5345                First_Time := False;
5346                New_Lhs := Lhs;
5347                New_Rhs := Rhs;
5348
5349             else
5350                New_Lhs := New_Copy_Tree (Lhs);
5351                New_Rhs := New_Copy_Tree (Rhs);
5352             end if;
5353
5354             Result :=
5355               Make_And_Then (Loc,
5356                 Left_Opnd  => Result,
5357                 Right_Opnd =>
5358                   Expand_Composite_Equality (Nod, Etype (C),
5359                     Lhs =>
5360                       Make_Selected_Component (Loc,
5361                         Prefix => New_Lhs,
5362                         Selector_Name => New_Reference_To (C, Loc)),
5363                     Rhs =>
5364                       Make_Selected_Component (Loc,
5365                         Prefix => New_Rhs,
5366                         Selector_Name => New_Reference_To (C, Loc)),
5367                     Bodies => Bodies));
5368          end;
5369
5370          C := Suitable_Element (Next_Entity (C));
5371       end loop;
5372
5373       return Result;
5374    end Expand_Record_Equality;
5375
5376    -------------------------------------
5377    -- Fixup_Universal_Fixed_Operation --
5378    -------------------------------------
5379
5380    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
5381       Conv : constant Node_Id := Parent (N);
5382
5383    begin
5384       --  We must have a type conversion immediately above us
5385
5386       pragma Assert (Nkind (Conv) = N_Type_Conversion);
5387
5388       --  Normally the type conversion gives our target type. The exception
5389       --  occurs in the case of the Round attribute, where the conversion
5390       --  will be to universal real, and our real type comes from the Round
5391       --  attribute (as well as an indication that we must round the result)
5392
5393       if Nkind (Parent (Conv)) = N_Attribute_Reference
5394         and then Attribute_Name (Parent (Conv)) = Name_Round
5395       then
5396          Set_Etype (N, Etype (Parent (Conv)));
5397          Set_Rounded_Result (N);
5398
5399       --  Normal case where type comes from conversion above us
5400
5401       else
5402          Set_Etype (N, Etype (Conv));
5403       end if;
5404    end Fixup_Universal_Fixed_Operation;
5405
5406    -------------------------------
5407    -- Insert_Dereference_Action --
5408    -------------------------------
5409
5410    procedure Insert_Dereference_Action (N : Node_Id) is
5411       Loc  : constant Source_Ptr := Sloc (N);
5412       Typ  : constant Entity_Id  := Etype (N);
5413       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
5414
5415       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
5416       --  return true if type of P is derived from Checked_Pool;
5417
5418       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
5419          T : Entity_Id;
5420
5421       begin
5422          if No (P) then
5423             return False;
5424          end if;
5425
5426          T := Etype (P);
5427          while T /= Etype (T) loop
5428             if Is_RTE (T, RE_Checked_Pool) then
5429                return True;
5430             else
5431                T := Etype (T);
5432             end if;
5433          end loop;
5434
5435          return False;
5436       end Is_Checked_Storage_Pool;
5437
5438    --  Start of processing for Insert_Dereference_Action
5439
5440    begin
5441       if not Comes_From_Source (Parent (N)) then
5442          return;
5443
5444       elsif not Is_Checked_Storage_Pool (Pool) then
5445          return;
5446       end if;
5447
5448       Insert_Action (N,
5449         Make_Procedure_Call_Statement (Loc,
5450           Name => New_Reference_To (
5451             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
5452
5453           Parameter_Associations => New_List (
5454
5455             --  Pool
5456
5457              New_Reference_To (Pool, Loc),
5458
5459             --  Storage_Address
5460
5461              Make_Attribute_Reference (Loc,
5462                Prefix         =>
5463                  Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
5464                Attribute_Name => Name_Address),
5465
5466             --  Size_In_Storage_Elements
5467
5468              Make_Op_Divide (Loc,
5469                Left_Opnd  =>
5470                 Make_Attribute_Reference (Loc,
5471                   Prefix         =>
5472                     Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
5473                   Attribute_Name => Name_Size),
5474                Right_Opnd =>
5475                  Make_Integer_Literal (Loc, System_Storage_Unit)),
5476
5477             --  Alignment
5478
5479              Make_Attribute_Reference (Loc,
5480                Prefix         =>
5481                  Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
5482                Attribute_Name => Name_Alignment))));
5483
5484    end Insert_Dereference_Action;
5485
5486    ------------------------------
5487    -- Make_Array_Comparison_Op --
5488    ------------------------------
5489
5490    --  This is a hand-coded expansion of the following generic function:
5491
5492    --  generic
5493    --    type elem is  (<>);
5494    --    type index is (<>);
5495    --    type a is array (index range <>) of elem;
5496    --
5497    --  function Gnnn (X : a; Y: a) return boolean is
5498    --    J : index := Y'first;
5499    --
5500    --  begin
5501    --    if X'length = 0 then
5502    --       return false;
5503    --
5504    --    elsif Y'length = 0 then
5505    --       return true;
5506    --
5507    --    else
5508    --      for I in X'range loop
5509    --        if X (I) = Y (J) then
5510    --          if J = Y'last then
5511    --            exit;
5512    --          else
5513    --            J := index'succ (J);
5514    --          end if;
5515    --
5516    --        else
5517    --           return X (I) > Y (J);
5518    --        end if;
5519    --      end loop;
5520    --
5521    --      return X'length > Y'length;
5522    --    end if;
5523    --  end Gnnn;
5524
5525    --  Note that since we are essentially doing this expansion by hand, we
5526    --  do not need to generate an actual or formal generic part, just the
5527    --  instantiated function itself.
5528
5529    function Make_Array_Comparison_Op
5530      (Typ   : Entity_Id;
5531       Nod   : Node_Id)
5532       return  Node_Id
5533    is
5534       Loc : constant Source_Ptr := Sloc (Nod);
5535
5536       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
5537       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
5538       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
5539       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
5540
5541       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
5542
5543       Loop_Statement : Node_Id;
5544       Loop_Body      : Node_Id;
5545       If_Stat        : Node_Id;
5546       Inner_If       : Node_Id;
5547       Final_Expr     : Node_Id;
5548       Func_Body      : Node_Id;
5549       Func_Name      : Entity_Id;
5550       Formals        : List_Id;
5551       Length1        : Node_Id;
5552       Length2        : Node_Id;
5553
5554    begin
5555       --  if J = Y'last then
5556       --     exit;
5557       --  else
5558       --     J := index'succ (J);
5559       --  end if;
5560
5561       Inner_If :=
5562         Make_Implicit_If_Statement (Nod,
5563           Condition =>
5564             Make_Op_Eq (Loc,
5565               Left_Opnd => New_Reference_To (J, Loc),
5566               Right_Opnd =>
5567                 Make_Attribute_Reference (Loc,
5568                   Prefix => New_Reference_To (Y, Loc),
5569                   Attribute_Name => Name_Last)),
5570
5571           Then_Statements => New_List (
5572                 Make_Exit_Statement (Loc)),
5573
5574           Else_Statements =>
5575             New_List (
5576               Make_Assignment_Statement (Loc,
5577                 Name => New_Reference_To (J, Loc),
5578                 Expression =>
5579                   Make_Attribute_Reference (Loc,
5580                     Prefix => New_Reference_To (Index, Loc),
5581                     Attribute_Name => Name_Succ,
5582                     Expressions => New_List (New_Reference_To (J, Loc))))));
5583
5584       --  if X (I) = Y (J) then
5585       --     if ... end if;
5586       --  else
5587       --     return X (I) > Y (J);
5588       --  end if;
5589
5590       Loop_Body :=
5591         Make_Implicit_If_Statement (Nod,
5592           Condition =>
5593             Make_Op_Eq (Loc,
5594               Left_Opnd =>
5595                 Make_Indexed_Component (Loc,
5596                   Prefix      => New_Reference_To (X, Loc),
5597                   Expressions => New_List (New_Reference_To (I, Loc))),
5598
5599               Right_Opnd =>
5600                 Make_Indexed_Component (Loc,
5601                   Prefix      => New_Reference_To (Y, Loc),
5602                   Expressions => New_List (New_Reference_To (J, Loc)))),
5603
5604           Then_Statements => New_List (Inner_If),
5605
5606           Else_Statements => New_List (
5607             Make_Return_Statement (Loc,
5608               Expression =>
5609                 Make_Op_Gt (Loc,
5610                   Left_Opnd =>
5611                     Make_Indexed_Component (Loc,
5612                       Prefix      => New_Reference_To (X, Loc),
5613                       Expressions => New_List (New_Reference_To (I, Loc))),
5614
5615                   Right_Opnd =>
5616                     Make_Indexed_Component (Loc,
5617                       Prefix      => New_Reference_To (Y, Loc),
5618                       Expressions => New_List (
5619                         New_Reference_To (J, Loc)))))));
5620
5621       --  for I in X'range loop
5622       --     if ... end if;
5623       --  end loop;
5624
5625       Loop_Statement :=
5626         Make_Implicit_Loop_Statement (Nod,
5627           Identifier => Empty,
5628
5629           Iteration_Scheme =>
5630             Make_Iteration_Scheme (Loc,
5631               Loop_Parameter_Specification =>
5632                 Make_Loop_Parameter_Specification (Loc,
5633                   Defining_Identifier => I,
5634                   Discrete_Subtype_Definition =>
5635                     Make_Attribute_Reference (Loc,
5636                       Prefix => New_Reference_To (X, Loc),
5637                       Attribute_Name => Name_Range))),
5638
5639           Statements => New_List (Loop_Body));
5640
5641       --    if X'length = 0 then
5642       --       return false;
5643       --    elsif Y'length = 0 then
5644       --       return true;
5645       --    else
5646       --      for ... loop ... end loop;
5647       --      return X'length > Y'length;
5648       --    end if;
5649
5650       Length1 :=
5651         Make_Attribute_Reference (Loc,
5652           Prefix => New_Reference_To (X, Loc),
5653           Attribute_Name => Name_Length);
5654
5655       Length2 :=
5656         Make_Attribute_Reference (Loc,
5657           Prefix => New_Reference_To (Y, Loc),
5658           Attribute_Name => Name_Length);
5659
5660       Final_Expr :=
5661         Make_Op_Gt (Loc,
5662           Left_Opnd  => Length1,
5663           Right_Opnd => Length2);
5664
5665       If_Stat :=
5666         Make_Implicit_If_Statement (Nod,
5667           Condition =>
5668             Make_Op_Eq (Loc,
5669               Left_Opnd =>
5670                 Make_Attribute_Reference (Loc,
5671                   Prefix => New_Reference_To (X, Loc),
5672                   Attribute_Name => Name_Length),
5673               Right_Opnd =>
5674                 Make_Integer_Literal (Loc, 0)),
5675
5676           Then_Statements =>
5677             New_List (
5678               Make_Return_Statement (Loc,
5679                 Expression => New_Reference_To (Standard_False, Loc))),
5680
5681           Elsif_Parts => New_List (
5682             Make_Elsif_Part (Loc,
5683               Condition =>
5684                 Make_Op_Eq (Loc,
5685                   Left_Opnd =>
5686                     Make_Attribute_Reference (Loc,
5687                       Prefix => New_Reference_To (Y, Loc),
5688                       Attribute_Name => Name_Length),
5689                   Right_Opnd =>
5690                     Make_Integer_Literal (Loc, 0)),
5691
5692               Then_Statements =>
5693                 New_List (
5694                   Make_Return_Statement (Loc,
5695                      Expression => New_Reference_To (Standard_True, Loc))))),
5696
5697           Else_Statements => New_List (
5698             Loop_Statement,
5699             Make_Return_Statement (Loc,
5700               Expression => Final_Expr)));
5701
5702       --  (X : a; Y: a)
5703
5704       Formals := New_List (
5705         Make_Parameter_Specification (Loc,
5706           Defining_Identifier => X,
5707           Parameter_Type      => New_Reference_To (Typ, Loc)),
5708
5709         Make_Parameter_Specification (Loc,
5710           Defining_Identifier => Y,
5711           Parameter_Type      => New_Reference_To (Typ, Loc)));
5712
5713       --  function Gnnn (...) return boolean is
5714       --    J : index := Y'first;
5715       --  begin
5716       --    if ... end if;
5717       --  end Gnnn;
5718
5719       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
5720
5721       Func_Body :=
5722         Make_Subprogram_Body (Loc,
5723           Specification =>
5724             Make_Function_Specification (Loc,
5725               Defining_Unit_Name       => Func_Name,
5726               Parameter_Specifications => Formals,
5727               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
5728
5729           Declarations => New_List (
5730             Make_Object_Declaration (Loc,
5731               Defining_Identifier => J,
5732               Object_Definition   => New_Reference_To (Index, Loc),
5733               Expression =>
5734                 Make_Attribute_Reference (Loc,
5735                   Prefix => New_Reference_To (Y, Loc),
5736                   Attribute_Name => Name_First))),
5737
5738           Handled_Statement_Sequence =>
5739             Make_Handled_Sequence_Of_Statements (Loc,
5740               Statements => New_List (If_Stat)));
5741
5742       return Func_Body;
5743
5744    end Make_Array_Comparison_Op;
5745
5746    ---------------------------
5747    -- Make_Boolean_Array_Op --
5748    ---------------------------
5749
5750    --  For logical operations on boolean arrays, expand in line the
5751    --  following, replacing 'and' with 'or' or 'xor' where needed:
5752
5753    --    function Annn (A : typ; B: typ) return typ is
5754    --       C : typ;
5755    --    begin
5756    --       for J in A'range loop
5757    --          C (J) := A (J) op B (J);
5758    --       end loop;
5759    --       return C;
5760    --    end Annn;
5761
5762    --  Here typ is the boolean array type
5763
5764    function Make_Boolean_Array_Op
5765      (Typ  : Entity_Id;
5766       N    : Node_Id)
5767       return Node_Id
5768    is
5769       Loc : constant Source_Ptr := Sloc (N);
5770
5771       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
5772       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
5773       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
5774       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
5775
5776       A_J : Node_Id;
5777       B_J : Node_Id;
5778       C_J : Node_Id;
5779       Op  : Node_Id;
5780
5781       Formals        : List_Id;
5782       Func_Name      : Entity_Id;
5783       Func_Body      : Node_Id;
5784       Loop_Statement : Node_Id;
5785
5786    begin
5787       A_J :=
5788         Make_Indexed_Component (Loc,
5789           Prefix      => New_Reference_To (A, Loc),
5790           Expressions => New_List (New_Reference_To (J, Loc)));
5791
5792       B_J :=
5793         Make_Indexed_Component (Loc,
5794           Prefix      => New_Reference_To (B, Loc),
5795           Expressions => New_List (New_Reference_To (J, Loc)));
5796
5797       C_J :=
5798         Make_Indexed_Component (Loc,
5799           Prefix      => New_Reference_To (C, Loc),
5800           Expressions => New_List (New_Reference_To (J, Loc)));
5801
5802       if Nkind (N) = N_Op_And then
5803          Op :=
5804            Make_Op_And (Loc,
5805              Left_Opnd  => A_J,
5806              Right_Opnd => B_J);
5807
5808       elsif Nkind (N) = N_Op_Or then
5809          Op :=
5810            Make_Op_Or (Loc,
5811              Left_Opnd  => A_J,
5812              Right_Opnd => B_J);
5813
5814       else
5815          Op :=
5816            Make_Op_Xor (Loc,
5817              Left_Opnd  => A_J,
5818              Right_Opnd => B_J);
5819       end if;
5820
5821       Loop_Statement :=
5822         Make_Implicit_Loop_Statement (N,
5823           Identifier => Empty,
5824
5825           Iteration_Scheme =>
5826             Make_Iteration_Scheme (Loc,
5827               Loop_Parameter_Specification =>
5828                 Make_Loop_Parameter_Specification (Loc,
5829                   Defining_Identifier => J,
5830                   Discrete_Subtype_Definition =>
5831                     Make_Attribute_Reference (Loc,
5832                       Prefix => New_Reference_To (A, Loc),
5833                       Attribute_Name => Name_Range))),
5834
5835           Statements => New_List (
5836             Make_Assignment_Statement (Loc,
5837               Name       => C_J,
5838               Expression => Op)));
5839
5840       Formals := New_List (
5841         Make_Parameter_Specification (Loc,
5842           Defining_Identifier => A,
5843           Parameter_Type      => New_Reference_To (Typ, Loc)),
5844
5845         Make_Parameter_Specification (Loc,
5846           Defining_Identifier => B,
5847           Parameter_Type      => New_Reference_To (Typ, Loc)));
5848
5849       Func_Name :=
5850         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
5851       Set_Is_Inlined (Func_Name);
5852
5853       Func_Body :=
5854         Make_Subprogram_Body (Loc,
5855           Specification =>
5856             Make_Function_Specification (Loc,
5857               Defining_Unit_Name       => Func_Name,
5858               Parameter_Specifications => Formals,
5859               Subtype_Mark             => New_Reference_To (Typ, Loc)),
5860
5861           Declarations => New_List (
5862             Make_Object_Declaration (Loc,
5863               Defining_Identifier => C,
5864               Object_Definition   => New_Reference_To (Typ, Loc))),
5865
5866           Handled_Statement_Sequence =>
5867             Make_Handled_Sequence_Of_Statements (Loc,
5868               Statements => New_List (
5869                 Loop_Statement,
5870                 Make_Return_Statement (Loc,
5871                   Expression => New_Reference_To (C, Loc)))));
5872
5873       return Func_Body;
5874    end Make_Boolean_Array_Op;
5875
5876    ------------------------
5877    -- Rewrite_Comparison --
5878    ------------------------
5879
5880    procedure Rewrite_Comparison (N : Node_Id) is
5881       Typ : constant Entity_Id := Etype (N);
5882       Op1 : constant Node_Id   := Left_Opnd (N);
5883       Op2 : constant Node_Id   := Right_Opnd (N);
5884
5885       Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
5886       --  Res indicates if compare outcome can be determined at compile time
5887
5888       True_Result  : Boolean;
5889       False_Result : Boolean;
5890
5891    begin
5892       case N_Op_Compare (Nkind (N)) is
5893          when N_Op_Eq =>
5894             True_Result  := Res = EQ;
5895             False_Result := Res = LT or else Res = GT or else Res = NE;
5896
5897          when N_Op_Ge =>
5898             True_Result  := Res in Compare_GE;
5899             False_Result := Res = LT;
5900
5901          when N_Op_Gt =>
5902             True_Result  := Res = GT;
5903             False_Result := Res in Compare_LE;
5904
5905          when N_Op_Lt =>
5906             True_Result  := Res = LT;
5907             False_Result := Res in Compare_GE;
5908
5909          when N_Op_Le =>
5910             True_Result  := Res in Compare_LE;
5911             False_Result := Res = GT;
5912
5913          when N_Op_Ne =>
5914             True_Result  := Res = NE;
5915             False_Result := Res = LT or else Res = GT or else Res = EQ;
5916       end case;
5917
5918       if True_Result then
5919          Rewrite (N,
5920            Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
5921          Analyze_And_Resolve (N, Typ);
5922
5923       elsif False_Result then
5924          Rewrite (N,
5925            Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
5926          Analyze_And_Resolve (N, Typ);
5927       end if;
5928    end Rewrite_Comparison;
5929
5930    -----------------------
5931    -- Tagged_Membership --
5932    -----------------------
5933
5934    --  There are two different cases to consider depending on whether
5935    --  the right operand is a class-wide type or not. If not we just
5936    --  compare the actual tag of the left expr to the target type tag:
5937    --
5938    --     Left_Expr.Tag = Right_Type'Tag;
5939    --
5940    --  If it is a class-wide type we use the RT function CW_Membership which
5941    --  is usually implemented by looking in the ancestor tables contained in
5942    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
5943
5944    function Tagged_Membership (N : Node_Id) return Node_Id is
5945       Left  : constant Node_Id    := Left_Opnd  (N);
5946       Right : constant Node_Id    := Right_Opnd (N);
5947       Loc   : constant Source_Ptr := Sloc (N);
5948
5949       Left_Type  : Entity_Id;
5950       Right_Type : Entity_Id;
5951       Obj_Tag    : Node_Id;
5952
5953    begin
5954       Left_Type  := Etype (Left);
5955       Right_Type := Etype (Right);
5956
5957       if Is_Class_Wide_Type (Left_Type) then
5958          Left_Type := Root_Type (Left_Type);
5959       end if;
5960
5961       Obj_Tag :=
5962         Make_Selected_Component (Loc,
5963           Prefix        => Relocate_Node (Left),
5964           Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
5965
5966       if Is_Class_Wide_Type (Right_Type) then
5967          return
5968            Make_DT_Access_Action (Left_Type,
5969              Action => CW_Membership,
5970              Args   => New_List (
5971                Obj_Tag,
5972                New_Reference_To (
5973                  Access_Disp_Table (Root_Type (Right_Type)), Loc)));
5974       else
5975          return
5976            Make_Op_Eq (Loc,
5977            Left_Opnd  => Obj_Tag,
5978            Right_Opnd =>
5979              New_Reference_To (Access_Disp_Table (Right_Type), Loc));
5980       end if;
5981
5982    end Tagged_Membership;
5983
5984    ------------------------------
5985    -- Unary_Op_Validity_Checks --
5986    ------------------------------
5987
5988    procedure Unary_Op_Validity_Checks (N : Node_Id) is
5989    begin
5990       if Validity_Checks_On and Validity_Check_Operands then
5991          Ensure_Valid (Right_Opnd (N));
5992       end if;
5993    end Unary_Op_Validity_Checks;
5994
5995 end Exp_Ch4;