gcc/ada/exp_util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ U T I L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2003, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Exp_Ch7;  use Exp_Ch7;
  33 with Exp_Ch11; use Exp_Ch11;
  34 with Exp_Tss;  use Exp_Tss;
  35 with Hostparm; use Hostparm;
  36 with Inline;   use Inline;
  37 with Itypes;   use Itypes;
  38 with Lib;      use Lib;
  39 with Namet;    use Namet;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Opt;      use Opt;
  43 with Restrict; use Restrict;
  44 with Sem;      use Sem;
  45 with Sem_Ch8;  use Sem_Ch8;
  46 with Sem_Eval; use Sem_Eval;
  47 with Sem_Res;  use Sem_Res;
  48 with Sem_Util; use Sem_Util;
  49 with Sinfo;    use Sinfo;
  50 with Snames;   use Snames;
  51 with Stand;    use Stand;
  52 with Stringt;  use Stringt;
  53 with Targparm; use Targparm;
  54 with Tbuild;   use Tbuild;
  55 with Ttypes;   use Ttypes;
  56 with Uintp;    use Uintp;
  57 with Urealp;   use Urealp;
  58 with Validsw;  use Validsw;
  59
  60 package body Exp_Util is
  61
  62    -----------------------
  63    -- Local Subprograms --
  64    -----------------------
  65
  66    function Build_Task_Array_Image
  67      (Loc    : Source_Ptr;
  68       Id_Ref : Node_Id;
  69       A_Type : Entity_Id;
  70       Dyn    : Boolean := False)
  71       return   Node_Id;
  72    --  Build function to generate the image string for a task that is an
  73    --  array component, concatenating the images of each index. To avoid
  74    --  storage leaks, the string is built with successive slice assignments.
  75    --  The flag Dyn indicates whether this is called for the initialization
  76    --  procedure of an array of tasks, or for the name of a dynamically
  77    --  created task that is assigned to an indexed component.
  78
  79    function Build_Task_Image_Function
  80      (Loc   : Source_Ptr;
  81       Decls : List_Id;
  82       Stats : List_Id;
  83       Res   : Entity_Id)
  84       return  Node_Id;
  85    --  Common processing for Task_Array_Image and Task_Record_Image.
  86    --  Build function body that computes image.
  87
  88    procedure Build_Task_Image_Prefix
  89       (Loc    : Source_Ptr;
  90        Len    : out Entity_Id;
  91        Res    : out Entity_Id;
  92        Pos    : out Entity_Id;
  93        Prefix : Entity_Id;
  94        Sum    : Node_Id;
  95        Decls  : in out List_Id;
  96        Stats  : in out List_Id);
  97    --  Common processing for Task_Array_Image and Task_Record_Image.
  98    --  Create local variables and assign prefix of name to result string.
  99
 100    function Build_Task_Record_Image
 101      (Loc    : Source_Ptr;
 102       Id_Ref : Node_Id;
 103       Dyn    : Boolean := False)
 104       return   Node_Id;
 105    --  Build function to generate the image string for a task that is a
 106    --  record component. Concatenate name of variable with that of selector.
 107    --  The flag Dyn indicates whether this is called for the initialization
 108    --  procedure of record with task components, or for a dynamically
 109    --  created task that is assigned to a selected component.
 110
 111    function Make_CW_Equivalent_Type
 112      (T    : Entity_Id;
 113       E    : Node_Id)
 114       return Entity_Id;
 115    --  T is a class-wide type entity, E is the initial expression node that
 116    --  constrains T in case such as: " X: T := E" or "new T'(E)"
 117    --  This function returns the entity of the Equivalent type and inserts
 118    --  on the fly the necessary declaration such as:
 119    --
 120    --    type anon is record
 121    --       _parent : Root_Type (T); constrained with E discriminants (if any)
 122    --       Extension : String (1 .. expr to match size of E);
 123    --    end record;
 124    --
 125    --  This record is compatible with any object of the class of T thanks
 126    --  to the first field and has the same size as E thanks to the second.
 127
 128    function Make_Literal_Range
 129      (Loc         : Source_Ptr;
 130       Literal_Typ : Entity_Id)
 131       return        Node_Id;
 132    --  Produce a Range node whose bounds are:
 133    --    Low_Bound (Literal_Type) ..
 134    --        Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
 135    --  this is used for expanding declarations like X : String := "sdfgdfg";
 136
 137    function New_Class_Wide_Subtype
 138      (CW_Typ : Entity_Id;
 139       N      : Node_Id)
 140       return   Entity_Id;
 141    --  Create an implicit subtype of CW_Typ attached to node N.
 142
 143    ----------------------
 144    -- Adjust_Condition --
 145    ----------------------
 146
 147    procedure Adjust_Condition (N : Node_Id) is
 148    begin
 149       if No (N) then
 150          return;
 151       end if;
 152
 153       declare
 154          Loc : constant Source_Ptr := Sloc (N);
 155          T   : constant Entity_Id  := Etype (N);
 156          Ti  : Entity_Id;
 157
 158       begin
 159          --  For now, we simply ignore a call where the argument has no
 160          --  type (probably case of unanalyzed condition), or has a type
 161          --  that is not Boolean. This is because this is a pretty marginal
 162          --  piece of functionality, and violations of these rules are
 163          --  likely to be truly marginal (how much code uses Fortran Logical
 164          --  as the barrier to a protected entry?) and we do not want to
 165          --  blow up existing programs. We can change this to an assertion
 166          --  after 3.12a is released ???
 167
 168          if No (T) or else not Is_Boolean_Type (T) then
 169             return;
 170          end if;
 171
 172          --  Apply validity checking if needed
 173
 174          if Validity_Checks_On and Validity_Check_Tests then
 175             Ensure_Valid (N);
 176          end if;
 177
 178          --  Immediate return if standard boolean, the most common case,
 179          --  where nothing needs to be done.
 180
 181          if Base_Type (T) = Standard_Boolean then
 182             return;
 183          end if;
 184
 185          --  Case of zero/non-zero semantics or non-standard enumeration
 186          --  representation. In each case, we rewrite the node as:
 187
 188          --      ityp!(N) /= False'Enum_Rep
 189
 190          --  where ityp is an integer type with large enough size to hold
 191          --  any value of type T.
 192
 193          if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
 194             if Esize (T) <= Esize (Standard_Integer) then
 195                Ti := Standard_Integer;
 196             else
 197                Ti := Standard_Long_Long_Integer;
 198             end if;
 199
 200             Rewrite (N,
 201               Make_Op_Ne (Loc,
 202                 Left_Opnd  => Unchecked_Convert_To (Ti, N),
 203                 Right_Opnd =>
 204                   Make_Attribute_Reference (Loc,
 205                     Attribute_Name => Name_Enum_Rep,
 206                     Prefix         =>
 207                       New_Occurrence_Of (First_Literal (T), Loc))));
 208             Analyze_And_Resolve (N, Standard_Boolean);
 209
 210          else
 211             Rewrite (N, Convert_To (Standard_Boolean, N));
 212             Analyze_And_Resolve (N, Standard_Boolean);
 213          end if;
 214       end;
 215    end Adjust_Condition;
 216
 217    ------------------------
 218    -- Adjust_Result_Type --
 219    ------------------------
 220
 221    procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
 222    begin
 223       --  Ignore call if current type is not Standard.Boolean
 224
 225       if Etype (N) /= Standard_Boolean then
 226          return;
 227       end if;
 228
 229       --  If result is already of correct type, nothing to do. Note that
 230       --  this will get the most common case where everything has a type
 231       --  of Standard.Boolean.
 232
 233       if Base_Type (T) = Standard_Boolean then
 234          return;
 235
 236       else
 237          declare
 238             KP : constant Node_Kind := Nkind (Parent (N));
 239
 240          begin
 241             --  If result is to be used as a Condition in the syntax, no need
 242             --  to convert it back, since if it was changed to Standard.Boolean
 243             --  using Adjust_Condition, that is just fine for this usage.
 244
 245             if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
 246                return;
 247
 248             --  If result is an operand of another logical operation, no need
 249             --  to reset its type, since Standard.Boolean is just fine, and
 250             --  such operations always do Adjust_Condition on their operands.
 251
 252             elsif KP in N_Op_Boolean
 253               or else KP = N_And_Then
 254               or else KP = N_Or_Else
 255               or else KP = N_Op_Not
 256             then
 257                return;
 258
 259             --  Otherwise we perform a conversion from the current type,
 260             --  which must be Standard.Boolean, to the desired type.
 261
 262             else
 263                Set_Analyzed (N);
 264                Rewrite (N, Convert_To (T, N));
 265                Analyze_And_Resolve (N, T);
 266             end if;
 267          end;
 268       end if;
 269    end Adjust_Result_Type;
 270
 271    --------------------------
 272    -- Append_Freeze_Action --
 273    --------------------------
 274
 275    procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
 276       Fnode : Node_Id := Freeze_Node (T);
 277
 278    begin
 279       Ensure_Freeze_Node (T);
 280       Fnode := Freeze_Node (T);
 281
 282       if not Present (Actions (Fnode)) then
 283          Set_Actions (Fnode, New_List);
 284       end if;
 285
 286       Append (N, Actions (Fnode));
 287    end Append_Freeze_Action;
 288
 289    ---------------------------
 290    -- Append_Freeze_Actions --
 291    ---------------------------
 292
 293    procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
 294       Fnode : constant Node_Id := Freeze_Node (T);
 295
 296    begin
 297       if No (L) then
 298          return;
 299
 300       else
 301          if No (Actions (Fnode)) then
 302             Set_Actions (Fnode, L);
 303
 304          else
 305             Append_List (L, Actions (Fnode));
 306          end if;
 307
 308       end if;
 309    end Append_Freeze_Actions;
 310
 311    ------------------------
 312    -- Build_Runtime_Call --
 313    ------------------------
 314
 315    function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
 316    begin
 317       --  If entity is not available, we can skip making the call (this avoids
 318       --  junk duplicated error messages in a number of cases).
 319
 320       if not RTE_Available (RE) then
 321          return Make_Null_Statement (Loc);
 322       else
 323          return
 324            Make_Procedure_Call_Statement (Loc,
 325              Name => New_Reference_To (RTE (RE), Loc));
 326       end if;
 327    end Build_Runtime_Call;
 328
 329    -----------------------------
 330    --  Build_Task_Array_Image --
 331    -----------------------------
 332
 333    --  This function generates the body for a function that constructs the
 334    --  image string for a task that is an array component. The function is
 335    --  local to the init proc for the array type, and is called for each one
 336    --  of the components. The constructed image has the form of an indexed
 337    --  component, whose prefix is the outer variable of the array type.
 338    --  The n-dimensional array type has known indices Index, Index2...
 339    --  Id_Ref is an indexed component form created by the enclosing init proc.
 340    --  Its successive indices are Val1, Val2,.. which are the loop variables
 341    --  in the loops that call the individual task init proc on each component.
 342
 343    --  The generated function has the following structure:
 344
 345    --  function F return String is
 346    --     Pref : string renames Task_Name;
 347    --     T1   : String := Index1'Image (Val1);
 348    --     ...
 349    --     Tn   : String := indexn'image (Valn);
 350    --     Len  : Integer := T1'Length + ... + Tn'Length + n + 1;
 351    --     --  Len includes commas and the end parentheses.
 352    --     Res  : String (1..Len);
 353    --     Pos  : Integer := Pref'Length;
 354    --
 355    --  begin
 356    --     Res (1 .. Pos) := Pref;
 357    --     Pos := Pos + 1;
 358    --     Res (Pos)    := '(';
 359    --     Pos := Pos + 1;
 360    --     Res (Pos .. Pos + T1'Length - 1) := T1;
 361    --     Pos := Pos + T1'Length;
 362    --     Res (Pos) := '.';
 363    --     Pos := Pos + 1;
 364    --     ...
 365    --     Res (Pos .. Pos + Tn'Length - 1) := Tn;
 366    --     Res (Len) := ')';
 367    --
 368    --     return Res;
 369    --  end F;
 370    --
 371    --  Needless to say, multidimensional arrays of tasks are rare enough
 372    --  that the bulkiness of this code is not really a concern.
 373
 374    function Build_Task_Array_Image
 375      (Loc    : Source_Ptr;
 376       Id_Ref : Node_Id;
 377       A_Type : Entity_Id;
 378       Dyn    : Boolean := False)
 379       return   Node_Id
 380    is
 381       Dims : constant Nat := Number_Dimensions (A_Type);
 382       --  Number of dimensions for array of tasks.
 383
 384       Temps : array (1 .. Dims) of Entity_Id;
 385       --  Array of temporaries to hold string for each index.
 386
 387       Indx : Node_Id;
 388       --  Index expression
 389
 390       Len : Entity_Id;
 391       --  Total length of generated name
 392
 393       Pos : Entity_Id;
 394       --  Running index for substring assignments
 395
 396       Pref : Entity_Id;
 397       --  Name of enclosing variable, prefix of resulting name
 398
 399       Res : Entity_Id;
 400       --  String to hold result
 401
 402       Val : Node_Id;
 403       --  Value of successive indices
 404
 405       Sum : Node_Id;
 406       --  Expression to compute total size of string
 407
 408       T : Entity_Id;
 409       --  Entity for name at one index position
 410
 411       Decls : List_Id := New_List;
 412       Stats : List_Id := New_List;
 413
 414    begin
 415       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 416
 417       --  For a dynamic task, the name comes from the target variable.
 418       --  For a static one it is a formal of the enclosing init proc.
 419
 420       if Dyn then
 421          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 422          Append_To (Decls,
 423            Make_Object_Declaration (Loc,
 424              Defining_Identifier => Pref,
 425              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 426              Expression =>
 427                Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
 428
 429       else
 430          Append_To (Decls,
 431            Make_Object_Renaming_Declaration (Loc,
 432              Defining_Identifier => Pref,
 433              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 434              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 435       end if;
 436
 437       Indx := First_Index (A_Type);
 438       Val  := First (Expressions (Id_Ref));
 439
 440       for J in 1 .. Dims loop
 441          T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 442          Temps (J) := T;
 443
 444          Append_To (Decls,
 445             Make_Object_Declaration (Loc,
 446                Defining_Identifier => T,
 447                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 448                Expression =>
 449                  Make_Attribute_Reference (Loc,
 450                    Attribute_Name => Name_Image,
 451                    Prefix =>
 452                      New_Occurrence_Of (Etype (Indx), Loc),
 453                    Expressions => New_List (
 454                      New_Copy_Tree (Val)))));
 455
 456          Next_Index (Indx);
 457          Next (Val);
 458       end loop;
 459
 460       Sum := Make_Integer_Literal (Loc, Dims + 1);
 461
 462       Sum :=
 463         Make_Op_Add (Loc,
 464           Left_Opnd => Sum,
 465           Right_Opnd =>
 466            Make_Attribute_Reference (Loc,
 467              Attribute_Name => Name_Length,
 468              Prefix =>
 469                New_Occurrence_Of (Pref, Loc),
 470              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 471
 472       for J in 1 .. Dims loop
 473          Sum :=
 474             Make_Op_Add (Loc,
 475              Left_Opnd => Sum,
 476              Right_Opnd =>
 477               Make_Attribute_Reference (Loc,
 478                 Attribute_Name => Name_Length,
 479                 Prefix =>
 480                   New_Occurrence_Of (Temps (J), Loc),
 481                 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 482       end loop;
 483
 484       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
 485
 486       Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
 487
 488       Append_To (Stats,
 489          Make_Assignment_Statement (Loc,
 490            Name => Make_Indexed_Component (Loc,
 491               Prefix => New_Occurrence_Of (Res, Loc),
 492               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 493            Expression =>
 494              Make_Character_Literal (Loc,
 495                Chars => Name_Find,
 496                Char_Literal_Value =>
 497                  Char_Code (Character'Pos ('(')))));
 498
 499       Append_To (Stats,
 500          Make_Assignment_Statement (Loc,
 501             Name => New_Occurrence_Of (Pos, Loc),
 502             Expression =>
 503               Make_Op_Add (Loc,
 504                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
 505                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
 506
 507       for J in 1 .. Dims loop
 508
 509          Append_To (Stats,
 510             Make_Assignment_Statement (Loc,
 511               Name => Make_Slice (Loc,
 512                  Prefix => New_Occurrence_Of (Res, Loc),
 513                  Discrete_Range  =>
 514                    Make_Range (Loc,
 515                       Low_Bound => New_Occurrence_Of  (Pos, Loc),
 516                       High_Bound => Make_Op_Subtract (Loc,
 517                         Left_Opnd =>
 518                           Make_Op_Add (Loc,
 519                             Left_Opnd => New_Occurrence_Of (Pos, Loc),
 520                             Right_Opnd =>
 521                               Make_Attribute_Reference (Loc,
 522                                 Attribute_Name => Name_Length,
 523                                 Prefix =>
 524                                   New_Occurrence_Of (Temps (J), Loc),
 525                                 Expressions =>
 526                                   New_List (Make_Integer_Literal (Loc, 1)))),
 527                          Right_Opnd => Make_Integer_Literal (Loc, 1)))),
 528
 529               Expression => New_Occurrence_Of (Temps (J), Loc)));
 530
 531          if J < Dims then
 532             Append_To (Stats,
 533                Make_Assignment_Statement (Loc,
 534                   Name => New_Occurrence_Of (Pos, Loc),
 535                   Expression =>
 536                     Make_Op_Add (Loc,
 537                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
 538                       Right_Opnd =>
 539                         Make_Attribute_Reference (Loc,
 540                           Attribute_Name => Name_Length,
 541                             Prefix => New_Occurrence_Of (Temps (J), Loc),
 542                             Expressions =>
 543                               New_List (Make_Integer_Literal (Loc, 1))))));
 544
 545             Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
 546
 547             Append_To (Stats,
 548                Make_Assignment_Statement (Loc,
 549                  Name => Make_Indexed_Component (Loc,
 550                     Prefix => New_Occurrence_Of (Res, Loc),
 551                     Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 552                  Expression =>
 553                    Make_Character_Literal (Loc,
 554                      Chars => Name_Find,
 555                      Char_Literal_Value =>
 556                        Char_Code (Character'Pos (',')))));
 557
 558             Append_To (Stats,
 559               Make_Assignment_Statement (Loc,
 560                 Name => New_Occurrence_Of (Pos, Loc),
 561                   Expression =>
 562                     Make_Op_Add (Loc,
 563                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
 564                       Right_Opnd => Make_Integer_Literal (Loc, 1))));
 565          end if;
 566       end loop;
 567
 568       Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
 569
 570       Append_To (Stats,
 571          Make_Assignment_Statement (Loc,
 572            Name => Make_Indexed_Component (Loc,
 573               Prefix => New_Occurrence_Of (Res, Loc),
 574               Expressions => New_List (New_Occurrence_Of (Len, Loc))),
 575            Expression =>
 576              Make_Character_Literal (Loc,
 577                Chars => Name_Find,
 578                Char_Literal_Value =>
 579                  Char_Code (Character'Pos (')')))));
 580       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
 581    end Build_Task_Array_Image;
 582
 583    ----------------------------
 584    -- Build_Task_Image_Decls --
 585    ----------------------------
 586
 587    function Build_Task_Image_Decls
 588      (Loc    : Source_Ptr;
 589       Id_Ref : Node_Id;
 590       A_Type : Entity_Id)
 591       return   List_Id
 592    is
 593       Decls  : constant List_Id   := New_List;
 594       T_Id   : Entity_Id := Empty;
 595       Decl   : Node_Id;
 596       Expr   : Node_Id   := Empty;
 597       Fun    : Node_Id   := Empty;
 598       Is_Dyn : constant Boolean :=
 599                  Nkind (Parent (Id_Ref)) = N_Assignment_Statement
 600                    and then
 601                  Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
 602
 603    begin
 604       --  If Discard_Names or No_Implicit_Heap_Allocations are in effect,
 605       --  generate a dummy declaration only.
 606
 607       if Restrictions (No_Implicit_Heap_Allocations)
 608         or else Global_Discard_Names
 609       then
 610          T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 611          Name_Len := 0;
 612
 613          return
 614            New_List (
 615              Make_Object_Declaration (Loc,
 616                Defining_Identifier => T_Id,
 617                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 618                Expression =>
 619                  Make_String_Literal
 620                    (Loc, Strval => String_From_Name_Buffer)));
 621
 622       else
 623          if Nkind (Id_Ref) = N_Identifier
 624            or else Nkind (Id_Ref) = N_Defining_Identifier
 625          then
 626             --  For a simple variable, the image of the task is the name
 627             --  of the variable.
 628
 629             T_Id :=
 630               Make_Defining_Identifier (Loc,
 631                 New_External_Name (Chars (Id_Ref), 'T'));
 632
 633             Get_Name_String (Chars (Id_Ref));
 634
 635             Expr := Make_String_Literal
 636               (Loc, Strval => String_From_Name_Buffer);
 637
 638          elsif Nkind (Id_Ref) = N_Selected_Component then
 639             T_Id :=
 640               Make_Defining_Identifier (Loc,
 641                 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
 642             Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
 643
 644          elsif Nkind (Id_Ref) = N_Indexed_Component then
 645             T_Id :=
 646               Make_Defining_Identifier (Loc,
 647                 New_External_Name (Chars (A_Type), 'N'));
 648
 649             Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
 650          end if;
 651       end if;
 652
 653       if Present (Fun) then
 654          Append (Fun, Decls);
 655          Expr := Make_Function_Call (Loc,
 656            Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
 657       end if;
 658
 659       Decl := Make_Object_Declaration (Loc,
 660         Defining_Identifier => T_Id,
 661         Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 662         Constant_Present    => True,
 663         Expression          => Expr);
 664
 665       Append (Decl, Decls);
 666       return Decls;
 667    end Build_Task_Image_Decls;
 668
 669    -------------------------------
 670    -- Build_Task_Image_Function --
 671    -------------------------------
 672
 673    function Build_Task_Image_Function
 674      (Loc   : Source_Ptr;
 675       Decls : List_Id;
 676       Stats : List_Id;
 677       Res   : Entity_Id)
 678       return  Node_Id
 679    is
 680       Spec : Node_Id;
 681
 682    begin
 683       Append_To (Stats,
 684         Make_Return_Statement (Loc,
 685           Expression => New_Occurrence_Of (Res, Loc)));
 686
 687       Spec := Make_Function_Specification (Loc,
 688         Defining_Unit_Name =>
 689           Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
 690         Subtype_Mark => New_Occurrence_Of (Standard_String, Loc));
 691
 692       --  Calls to 'Image use the secondary stack, which must be cleaned
 693       --  up after the task name is built.
 694
 695       Set_Uses_Sec_Stack (Defining_Unit_Name (Spec));
 696
 697       return Make_Subprogram_Body (Loc,
 698          Specification => Spec,
 699          Declarations => Decls,
 700          Handled_Statement_Sequence =>
 701            Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
 702    end Build_Task_Image_Function;
 703
 704    -----------------------------
 705    -- Build_Task_Image_Prefix --
 706    -----------------------------
 707
 708    procedure Build_Task_Image_Prefix
 709       (Loc    : Source_Ptr;
 710        Len    : out Entity_Id;
 711        Res    : out Entity_Id;
 712        Pos    : out Entity_Id;
 713        Prefix : Entity_Id;
 714        Sum    : Node_Id;
 715        Decls  : in out List_Id;
 716        Stats  : in out List_Id)
 717    is
 718    begin
 719       Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
 720
 721       Append_To (Decls,
 722         Make_Object_Declaration (Loc,
 723           Defining_Identifier => Len,
 724           Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
 725           Expression        => Sum));
 726
 727       Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
 728
 729       Append_To (Decls,
 730          Make_Object_Declaration (Loc,
 731             Defining_Identifier => Res,
 732             Object_Definition =>
 733                Make_Subtype_Indication (Loc,
 734                   Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
 735                Constraint =>
 736                  Make_Index_Or_Discriminant_Constraint (Loc,
 737                    Constraints =>
 738                      New_List (
 739                        Make_Range (Loc,
 740                          Low_Bound => Make_Integer_Literal (Loc, 1),
 741                          High_Bound => New_Occurrence_Of (Len, Loc)))))));
 742
 743       Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 744
 745       Append_To (Decls,
 746          Make_Object_Declaration (Loc,
 747             Defining_Identifier => Pos,
 748             Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
 749
 750       --  Pos := Prefix'Length;
 751
 752       Append_To (Stats,
 753          Make_Assignment_Statement (Loc,
 754             Name => New_Occurrence_Of (Pos, Loc),
 755             Expression =>
 756               Make_Attribute_Reference (Loc,
 757                 Attribute_Name => Name_Length,
 758                 Prefix => New_Occurrence_Of (Prefix, Loc),
 759                 Expressions =>
 760                     New_List (Make_Integer_Literal (Loc, 1)))));
 761
 762       --  Res (1 .. Pos) := Prefix;
 763
 764       Append_To (Stats,
 765          Make_Assignment_Statement (Loc,
 766            Name => Make_Slice (Loc,
 767               Prefix => New_Occurrence_Of (Res, Loc),
 768               Discrete_Range  =>
 769                 Make_Range (Loc,
 770                    Low_Bound => Make_Integer_Literal (Loc, 1),
 771                    High_Bound => New_Occurrence_Of (Pos, Loc))),
 772
 773            Expression => New_Occurrence_Of (Prefix, Loc)));
 774
 775       Append_To (Stats,
 776          Make_Assignment_Statement (Loc,
 777             Name => New_Occurrence_Of (Pos, Loc),
 778             Expression =>
 779               Make_Op_Add (Loc,
 780                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
 781                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
 782    end Build_Task_Image_Prefix;
 783
 784    -----------------------------
 785    -- Build_Task_Record_Image --
 786    -----------------------------
 787
 788    function Build_Task_Record_Image
 789      (Loc    : Source_Ptr;
 790       Id_Ref : Node_Id;
 791       Dyn    : Boolean := False)
 792       return   Node_Id
 793    is
 794       Len : Entity_Id;
 795       --  Total length of generated name
 796
 797       Pos : Entity_Id;
 798       --  Index into result
 799
 800       Res : Entity_Id;
 801       --  String to hold result
 802
 803       Pref : Entity_Id;
 804       --  Name of enclosing variable, prefix of resulting name
 805
 806       Sum : Node_Id;
 807       --  Expression to compute total size of string.
 808
 809       Sel : Entity_Id;
 810       --  Entity for selector name
 811
 812       Decls : List_Id := New_List;
 813       Stats : List_Id := New_List;
 814
 815    begin
 816       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 817
 818       --  For a dynamic task, the name comes from the target variable.
 819       --  For a static one it is a formal of the enclosing init proc.
 820
 821       if Dyn then
 822          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 823          Append_To (Decls,
 824            Make_Object_Declaration (Loc,
 825              Defining_Identifier => Pref,
 826              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 827              Expression =>
 828                Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
 829
 830       else
 831          Append_To (Decls,
 832            Make_Object_Renaming_Declaration (Loc,
 833              Defining_Identifier => Pref,
 834              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 835              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 836       end if;
 837
 838       Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 839
 840       Get_Name_String (Chars (Selector_Name (Id_Ref)));
 841
 842       Append_To (Decls,
 843          Make_Object_Declaration (Loc,
 844            Defining_Identifier => Sel,
 845            Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 846            Expression =>
 847               Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
 848
 849       Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
 850
 851       Sum :=
 852         Make_Op_Add (Loc,
 853           Left_Opnd => Sum,
 854           Right_Opnd =>
 855            Make_Attribute_Reference (Loc,
 856              Attribute_Name => Name_Length,
 857              Prefix =>
 858                New_Occurrence_Of (Pref, Loc),
 859              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 860
 861       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
 862
 863       Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
 864
 865       --  Res (Pos) := '.';
 866
 867       Append_To (Stats,
 868          Make_Assignment_Statement (Loc,
 869            Name => Make_Indexed_Component (Loc,
 870               Prefix => New_Occurrence_Of (Res, Loc),
 871               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 872            Expression =>
 873              Make_Character_Literal (Loc,
 874                Chars => Name_Find,
 875                Char_Literal_Value =>
 876                  Char_Code (Character'Pos ('.')))));
 877
 878       Append_To (Stats,
 879         Make_Assignment_Statement (Loc,
 880           Name => New_Occurrence_Of (Pos, Loc),
 881           Expression =>
 882             Make_Op_Add (Loc,
 883               Left_Opnd => New_Occurrence_Of (Pos, Loc),
 884               Right_Opnd => Make_Integer_Literal (Loc, 1))));
 885
 886       --  Res (Pos .. Len) := Selector;
 887
 888       Append_To (Stats,
 889         Make_Assignment_Statement (Loc,
 890           Name => Make_Slice (Loc,
 891              Prefix => New_Occurrence_Of (Res, Loc),
 892              Discrete_Range  =>
 893                Make_Range (Loc,
 894                  Low_Bound  => New_Occurrence_Of (Pos, Loc),
 895                  High_Bound => New_Occurrence_Of (Len, Loc))),
 896           Expression => New_Occurrence_Of (Sel, Loc)));
 897
 898       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
 899    end Build_Task_Record_Image;
 900
 901    -------------------------------
 902    -- Convert_To_Actual_Subtype --
 903    -------------------------------
 904
 905    procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
 906       Act_ST : Entity_Id;
 907
 908    begin
 909       Act_ST := Get_Actual_Subtype (Exp);
 910
 911       if Act_ST = Etype (Exp) then
 912          return;
 913
 914       else
 915          Rewrite (Exp,
 916            Convert_To (Act_ST, Relocate_Node (Exp)));
 917          Analyze_And_Resolve (Exp, Act_ST);
 918       end if;
 919    end Convert_To_Actual_Subtype;
 920
 921    -----------------------------------
 922    -- Current_Sem_Unit_Declarations --
 923    -----------------------------------
 924
 925    function Current_Sem_Unit_Declarations return List_Id is
 926       U     : Node_Id := Unit (Cunit (Current_Sem_Unit));
 927       Decls : List_Id;
 928
 929    begin
 930       --  If the current unit is a package body, locate the visible
 931       --  declarations of the package spec.
 932
 933       if Nkind (U) = N_Package_Body then
 934          U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
 935       end if;
 936
 937       if Nkind (U) = N_Package_Declaration then
 938          U := Specification (U);
 939          Decls := Visible_Declarations (U);
 940
 941          if No (Decls) then
 942             Decls := New_List;
 943             Set_Visible_Declarations (U, Decls);
 944          end if;
 945
 946       else
 947          Decls := Declarations (U);
 948
 949          if No (Decls) then
 950             Decls := New_List;
 951             Set_Declarations (U, Decls);
 952          end if;
 953       end if;
 954
 955       return Decls;
 956    end Current_Sem_Unit_Declarations;
 957
 958    -----------------------
 959    -- Duplicate_Subexpr --
 960    -----------------------
 961
 962    function Duplicate_Subexpr
 963      (Exp      : Node_Id;
 964       Name_Req : Boolean := False)
 965       return     Node_Id
 966    is
 967    begin
 968       Remove_Side_Effects (Exp, Name_Req);
 969       return New_Copy_Tree (Exp);
 970    end Duplicate_Subexpr;
 971
 972    ---------------------------------
 973    -- Duplicate_Subexpr_No_Checks --
 974    ---------------------------------
 975
 976    function Duplicate_Subexpr_No_Checks
 977      (Exp      : Node_Id;
 978       Name_Req : Boolean := False)
 979       return     Node_Id
 980    is
 981       New_Exp : Node_Id;
 982
 983    begin
 984       Remove_Side_Effects (Exp, Name_Req);
 985       New_Exp := New_Copy_Tree (Exp);
 986       Remove_Checks (New_Exp);
 987       return New_Exp;
 988    end Duplicate_Subexpr_No_Checks;
 989
 990    -----------------------------------
 991    -- Duplicate_Subexpr_Move_Checks --
 992    -----------------------------------
 993
 994    function Duplicate_Subexpr_Move_Checks
 995      (Exp      : Node_Id;
 996       Name_Req : Boolean := False)
 997       return     Node_Id
 998    is
 999       New_Exp : Node_Id;
1000
1001    begin
1002       Remove_Side_Effects (Exp, Name_Req);
1003       New_Exp := New_Copy_Tree (Exp);
1004       Remove_Checks (Exp);
1005       return New_Exp;
1006    end Duplicate_Subexpr_Move_Checks;
1007
1008    --------------------
1009    -- Ensure_Defined --
1010    --------------------
1011
1012    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1013       IR : Node_Id;
1014       P  : Node_Id;
1015
1016    begin
1017       if Is_Itype (Typ) then
1018          IR := Make_Itype_Reference (Sloc (N));
1019          Set_Itype (IR, Typ);
1020
1021          if not In_Open_Scopes (Scope (Typ))
1022            and then Is_Subprogram (Current_Scope)
1023            and then Scope (Current_Scope) /= Standard_Standard
1024          then
1025             --  Insert node in front of subprogram, to avoid scope anomalies
1026             --  in gigi.
1027
1028             P := Parent (N);
1029
1030             while Present (P)
1031               and then Nkind (P) /= N_Subprogram_Body
1032             loop
1033                P := Parent (P);
1034             end loop;
1035
1036             if Present (P) then
1037                Insert_Action (P, IR);
1038             else
1039                Insert_Action (N, IR);
1040             end if;
1041
1042          else
1043             Insert_Action (N, IR);
1044          end if;
1045       end if;
1046    end Ensure_Defined;
1047
1048    ---------------------
1049    -- Evolve_And_Then --
1050    ---------------------
1051
1052    procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1053    begin
1054       if No (Cond) then
1055          Cond := Cond1;
1056       else
1057          Cond :=
1058            Make_And_Then (Sloc (Cond1),
1059              Left_Opnd  => Cond,
1060              Right_Opnd => Cond1);
1061       end if;
1062    end Evolve_And_Then;
1063
1064    --------------------
1065    -- Evolve_Or_Else --
1066    --------------------
1067
1068    procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1069    begin
1070       if No (Cond) then
1071          Cond := Cond1;
1072       else
1073          Cond :=
1074            Make_Or_Else (Sloc (Cond1),
1075              Left_Opnd  => Cond,
1076              Right_Opnd => Cond1);
1077       end if;
1078    end Evolve_Or_Else;
1079
1080    ------------------------------
1081    -- Expand_Subtype_From_Expr --
1082    ------------------------------
1083
1084    --  This function is applicable for both static and dynamic allocation of
1085    --  objects which are constrained by an initial expression. Basically it
1086    --  transforms an unconstrained subtype indication into a constrained one.
1087    --  The expression may also be transformed in certain cases in order to
1088    --  avoid multiple evaulation. In the static allocation case, the general
1089    --  scheme is :
1090
1091    --     Val : T := Expr;
1092
1093    --        is transformed into
1094
1095    --     Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1096    --
1097    --  Here are the main cases :
1098    --
1099    --  <if Expr is a Slice>
1100    --    Val : T ([Index_Subtype (Expr)]) := Expr;
1101    --
1102    --  <elsif Expr is a String Literal>
1103    --    Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1104    --
1105    --  <elsif Expr is Constrained>
1106    --    subtype T is Type_Of_Expr
1107    --    Val : T := Expr;
1108    --
1109    --  <elsif Expr is an entity_name>
1110    --    Val : T (constraints taken from Expr) := Expr;
1111    --
1112    --  <else>
1113    --    type Axxx is access all T;
1114    --    Rval : Axxx := Expr'ref;
1115    --    Val  : T (constraints taken from Rval) := Rval.all;
1116
1117    --    ??? note: when the Expression is allocated in the secondary stack
1118    --              we could use it directly instead of copying it by declaring
1119    --              Val : T (...) renames Rval.all
1120
1121    procedure Expand_Subtype_From_Expr
1122      (N             : Node_Id;
1123       Unc_Type      : Entity_Id;
1124       Subtype_Indic : Node_Id;
1125       Exp           : Node_Id)
1126    is
1127       Loc     : constant Source_Ptr := Sloc (N);
1128       Exp_Typ : constant Entity_Id  := Etype (Exp);
1129       T       : Entity_Id;
1130
1131    begin
1132       --  In general we cannot build the subtype if expansion is disabled,
1133       --  because internal entities may not have been defined. However, to
1134       --  avoid some cascaded errors, we try to continue when the expression
1135       --  is an array (or string), because it is safe to compute the bounds.
1136       --  It is in fact required to do so even in a generic context, because
1137       --  there may be constants that depend on bounds of string literal.
1138
1139       if not Expander_Active
1140         and then (No (Etype (Exp))
1141                    or else Base_Type (Etype (Exp)) /= Standard_String)
1142       then
1143          return;
1144       end if;
1145
1146       if Nkind (Exp) = N_Slice then
1147          declare
1148             Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1149
1150          begin
1151             Rewrite (Subtype_Indic,
1152               Make_Subtype_Indication (Loc,
1153                 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1154                 Constraint =>
1155                   Make_Index_Or_Discriminant_Constraint (Loc,
1156                     Constraints => New_List
1157                       (New_Reference_To (Slice_Type, Loc)))));
1158
1159             --  This subtype indication may be used later for contraint checks
1160             --  we better make sure that if a variable was used as a bound of
1161             --  of the original slice, its value is frozen.
1162
1163             Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1164             Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1165          end;
1166
1167       elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1168          Rewrite (Subtype_Indic,
1169            Make_Subtype_Indication (Loc,
1170              Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1171              Constraint =>
1172                Make_Index_Or_Discriminant_Constraint (Loc,
1173                  Constraints => New_List (
1174                    Make_Literal_Range (Loc,
1175                      Literal_Typ => Exp_Typ)))));
1176
1177       elsif Is_Constrained (Exp_Typ)
1178         and then not Is_Class_Wide_Type (Unc_Type)
1179       then
1180          if Is_Itype (Exp_Typ) then
1181
1182             --  No need to generate a new one.
1183
1184             T := Exp_Typ;
1185
1186          else
1187             T :=
1188               Make_Defining_Identifier (Loc,
1189                 Chars => New_Internal_Name ('T'));
1190
1191             Insert_Action (N,
1192               Make_Subtype_Declaration (Loc,
1193                 Defining_Identifier => T,
1194                 Subtype_Indication  => New_Reference_To (Exp_Typ, Loc)));
1195
1196             --  This type is marked as an itype even though it has an
1197             --  explicit declaration because otherwise it can be marked
1198             --  with Is_Generic_Actual_Type and generate spurious errors.
1199             --  (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1200
1201             Set_Is_Itype (T);
1202             Set_Associated_Node_For_Itype (T, Exp);
1203          end if;
1204
1205          Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1206
1207       --  nothing needs to be done for private types with unknown discriminants
1208       --  if the underlying type is not an unconstrained composite type.
1209
1210       elsif Is_Private_Type (Unc_Type)
1211         and then Has_Unknown_Discriminants (Unc_Type)
1212         and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1213                     or else Is_Constrained (Underlying_Type (Unc_Type)))
1214       then
1215          null;
1216
1217       else
1218          Remove_Side_Effects (Exp);
1219          Rewrite (Subtype_Indic,
1220            Make_Subtype_From_Expr (Exp, Unc_Type));
1221       end if;
1222    end Expand_Subtype_From_Expr;
1223
1224    ------------------
1225    -- Find_Prim_Op --
1226    ------------------
1227
1228    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1229       Prim : Elmt_Id;
1230       Typ  : Entity_Id := T;
1231
1232    begin
1233       if Is_Class_Wide_Type (Typ) then
1234          Typ := Root_Type (Typ);
1235       end if;
1236
1237       Typ := Underlying_Type (Typ);
1238
1239       Prim := First_Elmt (Primitive_Operations (Typ));
1240       while Chars (Node (Prim)) /= Name loop
1241          Next_Elmt (Prim);
1242          pragma Assert (Present (Prim));
1243       end loop;
1244
1245       return Node (Prim);
1246    end Find_Prim_Op;
1247
1248    function Find_Prim_Op
1249      (T    : Entity_Id;
1250       Name : TSS_Name_Type) return Entity_Id
1251    is
1252       Prim : Elmt_Id;
1253       Typ  : Entity_Id := T;
1254
1255    begin
1256       if Is_Class_Wide_Type (Typ) then
1257          Typ := Root_Type (Typ);
1258       end if;
1259
1260       Typ := Underlying_Type (Typ);
1261
1262       Prim := First_Elmt (Primitive_Operations (Typ));
1263       while not Is_TSS (Node (Prim), Name) loop
1264          Next_Elmt (Prim);
1265          pragma Assert (Present (Prim));
1266       end loop;
1267
1268       return Node (Prim);
1269    end Find_Prim_Op;
1270
1271    ----------------------
1272    -- Force_Evaluation --
1273    ----------------------
1274
1275    procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1276    begin
1277       Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1278    end Force_Evaluation;
1279
1280    ------------------------
1281    -- Generate_Poll_Call --
1282    ------------------------
1283
1284    procedure Generate_Poll_Call (N : Node_Id) is
1285    begin
1286       --  No poll call if polling not active
1287
1288       if not Polling_Required then
1289          return;
1290
1291       --  Otherwise generate require poll call
1292
1293       else
1294          Insert_Before_And_Analyze (N,
1295            Make_Procedure_Call_Statement (Sloc (N),
1296              Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1297       end if;
1298    end Generate_Poll_Call;
1299
1300    ---------------------------------
1301    -- Get_Current_Value_Condition --
1302    ---------------------------------
1303
1304    procedure Get_Current_Value_Condition
1305      (Var : Node_Id;
1306       Op  : out Node_Kind;
1307       Val : out Node_Id)
1308    is
1309       Loc  : constant Source_Ptr := Sloc (Var);
1310       CV   : constant Node_Id    := Current_Value (Entity (Var));
1311       Sens : Boolean;
1312       Stm  : Node_Id;
1313       Cond : Node_Id;
1314
1315    begin
1316       Op  := N_Empty;
1317       Val := Empty;
1318
1319       --  If statement. Condition is known true in THEN section, known False
1320       --  in any ELSIF or ELSE part, and unknown outside the IF statement.
1321
1322       if Nkind (CV) = N_If_Statement then
1323
1324          --  Before start of IF statement
1325
1326          if Loc < Sloc (CV) then
1327             return;
1328
1329          --  After end of IF statement
1330
1331          elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1332             return;
1333          end if;
1334
1335          --  At this stage we know that we are within the IF statement, but
1336          --  unfortunately, the tree does not record the SLOC of the ELSE so
1337          --  we cannot use a simple SLOC comparison to distinguish between
1338          --  the then/else statements, so we have to climb the tree.
1339
1340          declare
1341             N : Node_Id;
1342
1343          begin
1344             N := Parent (Var);
1345             while Parent (N) /= CV loop
1346                N := Parent (N);
1347
1348                --  If we fall off the top of the tree, then that's odd, but
1349                --  perhaps it could occur in some error situation, and the
1350                --  safest response is simply to assume that the outcome of
1351                --  the condition is unknown. No point in bombing during an
1352                --  attempt to optimize things.
1353
1354                if No (N) then
1355                   return;
1356                end if;
1357             end loop;
1358
1359             --  Now we have N pointing to a node whose parent is the IF
1360             --  statement in question, so now we can tell if we are within
1361             --  the THEN statements.
1362
1363             if Is_List_Member (N)
1364               and then List_Containing (N) = Then_Statements (CV)
1365             then
1366                Sens := True;
1367
1368             --  Otherwise we must be in ELSIF or ELSE part
1369
1370             else
1371                Sens := False;
1372             end if;
1373          end;
1374
1375       --  ELSIF part. Condition is known true within the referenced
1376       --  ELSIF, known False in any subsequent ELSIF or ELSE part,
1377       --  and unknown before the ELSE part or after the IF statement.
1378
1379       elsif Nkind (CV) = N_Elsif_Part then
1380          Stm := Parent (CV);
1381
1382          --  Before start of ELSIF part
1383
1384          if Loc < Sloc (CV) then
1385             return;
1386
1387          --  After end of IF statement
1388
1389          elsif Loc >= Sloc (Stm) +
1390                         Text_Ptr (UI_To_Int (End_Span (Stm)))
1391          then
1392             return;
1393          end if;
1394
1395          --  Again we lack the SLOC of the ELSE, so we need to climb the
1396          --  tree to see if we are within the ELSIF part in question.
1397
1398          declare
1399             N : Node_Id;
1400
1401          begin
1402             N := Parent (Var);
1403             while Parent (N) /= Stm loop
1404                N := Parent (N);
1405
1406                --  If we fall off the top of the tree, then that's odd, but
1407                --  perhaps it could occur in some error situation, and the
1408                --  safest response is simply to assume that the outcome of
1409                --  the condition is unknown. No point in bombing during an
1410                --  attempt to optimize things.
1411
1412                if No (N) then
1413                   return;
1414                end if;
1415             end loop;
1416
1417             --  Now we have N pointing to a node whose parent is the IF
1418             --  statement in question, so see if is the ELSIF part we want.
1419             --  the THEN statements.
1420
1421             if N = CV then
1422                Sens := True;
1423
1424             --  Otherwise we must be in susbequent ELSIF or ELSE part
1425
1426             else
1427                Sens := False;
1428             end if;
1429          end;
1430
1431       --  All other cases of Current_Value settings
1432
1433       else
1434          return;
1435       end if;
1436
1437       --  If we fall through here, then we have a reportable
1438       --  condition, Sens is True if the condition is true and
1439       --  False if it needs inverting.
1440
1441       Cond := Condition (CV);
1442
1443       --  Deal with NOT operators, inverting sense
1444
1445       while Nkind (Cond) = N_Op_Not loop
1446          Cond := Right_Opnd (Cond);
1447          Sens := not Sens;
1448       end loop;
1449
1450       --  Now we must have a relational operator
1451
1452       pragma Assert (Entity (Var) = Entity (Left_Opnd (Cond)));
1453       Val := Right_Opnd (Cond);
1454       Op  := Nkind (Cond);
1455
1456       if Sens = False then
1457          case Op is
1458             when N_Op_Eq => Op := N_Op_Ne;
1459             when N_Op_Ne => Op := N_Op_Eq;
1460             when N_Op_Lt => Op := N_Op_Ge;
1461             when N_Op_Gt => Op := N_Op_Le;
1462             when N_Op_Le => Op := N_Op_Gt;
1463             when N_Op_Ge => Op := N_Op_Lt;
1464
1465             --  No other entry should be possible
1466
1467             when others =>
1468                raise Program_Error;
1469          end case;
1470       end if;
1471    end Get_Current_Value_Condition;
1472
1473    --------------------
1474    -- Homonym_Number --
1475    --------------------
1476
1477    function Homonym_Number (Subp : Entity_Id) return Nat is
1478       Count : Nat;
1479       Hom   : Entity_Id;
1480
1481    begin
1482       Count := 1;
1483       Hom := Homonym (Subp);
1484       while Present (Hom) loop
1485          if Scope (Hom) = Scope (Subp) then
1486             Count := Count + 1;
1487          end if;
1488
1489          Hom := Homonym (Hom);
1490       end loop;
1491
1492       return Count;
1493    end Homonym_Number;
1494
1495    ------------------------------
1496    -- In_Unconditional_Context --
1497    ------------------------------
1498
1499    function In_Unconditional_Context (Node : Node_Id) return Boolean is
1500       P : Node_Id;
1501
1502    begin
1503       P := Node;
1504       while Present (P) loop
1505          case Nkind (P) is
1506             when N_Subprogram_Body =>
1507                return True;
1508
1509             when N_If_Statement =>
1510                return False;
1511
1512             when N_Loop_Statement =>
1513                return False;
1514
1515             when N_Case_Statement =>
1516                return False;
1517
1518             when others =>
1519                P := Parent (P);
1520          end case;
1521       end loop;
1522
1523       return False;
1524    end In_Unconditional_Context;
1525
1526    -------------------
1527    -- Insert_Action --
1528    -------------------
1529
1530    procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
1531    begin
1532       if Present (Ins_Action) then
1533          Insert_Actions (Assoc_Node, New_List (Ins_Action));
1534       end if;
1535    end Insert_Action;
1536
1537    --  Version with check(s) suppressed
1538
1539    procedure Insert_Action
1540      (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
1541    is
1542    begin
1543       Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
1544    end Insert_Action;
1545
1546    --------------------
1547    -- Insert_Actions --
1548    --------------------
1549
1550    procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
1551       N : Node_Id;
1552       P : Node_Id;
1553
1554       Wrapped_Node : Node_Id := Empty;
1555
1556    begin
1557       if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
1558          return;
1559       end if;
1560
1561       --  Ignore insert of actions from inside default expression in the
1562       --  special preliminary analyze mode. Any insertions at this point
1563       --  have no relevance, since we are only doing the analyze to freeze
1564       --  the types of any static expressions. See section "Handling of
1565       --  Default Expressions" in the spec of package Sem for further details.
1566
1567       if In_Default_Expression then
1568          return;
1569       end if;
1570
1571       --  If the action derives from stuff inside a record, then the actions
1572       --  are attached to the current scope, to be inserted and analyzed on
1573       --  exit from the scope. The reason for this is that we may also
1574       --  be generating freeze actions at the same time, and they must
1575       --  eventually be elaborated in the correct order.
1576
1577       if Is_Record_Type (Current_Scope)
1578         and then not Is_Frozen (Current_Scope)
1579       then
1580          if No (Scope_Stack.Table
1581            (Scope_Stack.Last).Pending_Freeze_Actions)
1582          then
1583             Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
1584               Ins_Actions;
1585          else
1586             Append_List
1587               (Ins_Actions,
1588                Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
1589          end if;
1590
1591          return;
1592       end if;
1593
1594       --  We now intend to climb up the tree to find the right point to
1595       --  insert the actions. We start at Assoc_Node, unless this node is
1596       --  a subexpression in which case we start with its parent. We do this
1597       --  for two reasons. First it speeds things up. Second, if Assoc_Node
1598       --  is itself one of the special nodes like N_And_Then, then we assume
1599       --  that an initial request to insert actions for such a node does not
1600       --  expect the actions to get deposited in the node for later handling
1601       --  when the node is expanded, since clearly the node is being dealt
1602       --  with by the caller. Note that in the subexpression case, N is
1603       --  always the child we came from.
1604
1605       --  N_Raise_xxx_Error is an annoying special case, it is a statement
1606       --  if it has type Standard_Void_Type, and a subexpression otherwise.
1607       --  otherwise. Procedure attribute references are also statements.
1608
1609       if Nkind (Assoc_Node) in N_Subexpr
1610         and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
1611                    or else Etype (Assoc_Node) /= Standard_Void_Type)
1612         and then (Nkind (Assoc_Node) /= N_Attribute_Reference
1613                    or else
1614                      not Is_Procedure_Attribute_Name
1615                            (Attribute_Name (Assoc_Node)))
1616       then
1617          P := Assoc_Node;             -- ??? does not agree with above!
1618          N := Parent (Assoc_Node);
1619
1620       --  Non-subexpression case. Note that N is initially Empty in this
1621       --  case (N is only guaranteed Non-Empty in the subexpr case).
1622
1623       else
1624          P := Assoc_Node;
1625          N := Empty;
1626       end if;
1627
1628       --  Capture root of the transient scope
1629
1630       if Scope_Is_Transient then
1631          Wrapped_Node  := Node_To_Be_Wrapped;
1632       end if;
1633
1634       loop
1635          pragma Assert (Present (P));
1636
1637          case Nkind (P) is
1638
1639             --  Case of right operand of AND THEN or OR ELSE. Put the actions
1640             --  in the Actions field of the right operand. They will be moved
1641             --  out further when the AND THEN or OR ELSE operator is expanded.
1642             --  Nothing special needs to be done for the left operand since
1643             --  in that case the actions are executed unconditionally.
1644
1645             when N_And_Then | N_Or_Else =>
1646                if N = Right_Opnd (P) then
1647                   if Present (Actions (P)) then
1648                      Insert_List_After_And_Analyze
1649                       (Last (Actions (P)), Ins_Actions);
1650                   else
1651                      Set_Actions (P, Ins_Actions);
1652                      Analyze_List (Actions (P));
1653                   end if;
1654
1655                   return;
1656                end if;
1657
1658             --  Then or Else operand of conditional expression. Add actions to
1659             --  Then_Actions or Else_Actions field as appropriate. The actions
1660             --  will be moved further out when the conditional is expanded.
1661
1662             when N_Conditional_Expression =>
1663                declare
1664                   ThenX : constant Node_Id := Next (First (Expressions (P)));
1665                   ElseX : constant Node_Id := Next (ThenX);
1666
1667                begin
1668                   --  Actions belong to the then expression, temporarily
1669                   --  place them as Then_Actions of the conditional expr.
1670                   --  They will be moved to the proper place later when
1671                   --  the conditional expression is expanded.
1672
1673                   if N = ThenX then
1674                      if Present (Then_Actions (P)) then
1675                         Insert_List_After_And_Analyze
1676                           (Last (Then_Actions (P)), Ins_Actions);
1677                      else
1678                         Set_Then_Actions (P, Ins_Actions);
1679                         Analyze_List (Then_Actions (P));
1680                      end if;
1681
1682                      return;
1683
1684                   --  Actions belong to the else expression, temporarily
1685                   --  place them as Else_Actions of the conditional expr.
1686                   --  They will be moved to the proper place later when
1687                   --  the conditional expression is expanded.
1688
1689                   elsif N = ElseX then
1690                      if Present (Else_Actions (P)) then
1691                         Insert_List_After_And_Analyze
1692                           (Last (Else_Actions (P)), Ins_Actions);
1693                      else
1694                         Set_Else_Actions (P, Ins_Actions);
1695                         Analyze_List (Else_Actions (P));
1696                      end if;
1697
1698                      return;
1699
1700                   --  Actions belong to the condition. In this case they are
1701                   --  unconditionally executed, and so we can continue the
1702                   --  search for the proper insert point.
1703
1704                   else
1705                      null;
1706                   end if;
1707                end;
1708
1709             --  Case of appearing in the condition of a while expression or
1710             --  elsif. We insert the actions into the Condition_Actions field.
1711             --  They will be moved further out when the while loop or elsif
1712             --  is analyzed.
1713
1714             when N_Iteration_Scheme |
1715                  N_Elsif_Part
1716             =>
1717                if N = Condition (P) then
1718                   if Present (Condition_Actions (P)) then
1719                      Insert_List_After_And_Analyze
1720                        (Last (Condition_Actions (P)), Ins_Actions);
1721                   else
1722                      Set_Condition_Actions (P, Ins_Actions);
1723
1724                      --  Set the parent of the insert actions explicitly.
1725                      --  This is not a syntactic field, but we need the
1726                      --  parent field set, in particular so that freeze
1727                      --  can understand that it is dealing with condition
1728                      --  actions, and properly insert the freezing actions.
1729
1730                      Set_Parent (Ins_Actions, P);
1731                      Analyze_List (Condition_Actions (P));
1732                   end if;
1733
1734                   return;
1735                end if;
1736
1737             --  Statements, declarations, pragmas, representation clauses.
1738
1739             when
1740                --  Statements
1741
1742                N_Procedure_Call_Statement               |
1743                N_Statement_Other_Than_Procedure_Call    |
1744
1745                --  Pragmas
1746
1747                N_Pragma                                 |
1748
1749                --  Representation_Clause
1750
1751                N_At_Clause                              |
1752                N_Attribute_Definition_Clause            |
1753                N_Enumeration_Representation_Clause      |
1754                N_Record_Representation_Clause           |
1755
1756                --  Declarations
1757
1758                N_Abstract_Subprogram_Declaration        |
1759                N_Entry_Body                             |
1760                N_Exception_Declaration                  |
1761                N_Exception_Renaming_Declaration         |
1762                N_Formal_Object_Declaration              |
1763                N_Formal_Subprogram_Declaration          |
1764                N_Formal_Type_Declaration                |
1765                N_Full_Type_Declaration                  |
1766                N_Function_Instantiation                 |
1767                N_Generic_Function_Renaming_Declaration  |
1768                N_Generic_Package_Declaration            |
1769                N_Generic_Package_Renaming_Declaration   |
1770                N_Generic_Procedure_Renaming_Declaration |
1771                N_Generic_Subprogram_Declaration         |
1772                N_Implicit_Label_Declaration             |
1773                N_Incomplete_Type_Declaration            |
1774                N_Number_Declaration                     |
1775                N_Object_Declaration                     |
1776                N_Object_Renaming_Declaration            |
1777                N_Package_Body                           |
1778                N_Package_Body_Stub                      |
1779                N_Package_Declaration                    |
1780                N_Package_Instantiation                  |
1781                N_Package_Renaming_Declaration           |
1782                N_Private_Extension_Declaration          |
1783                N_Private_Type_Declaration               |
1784                N_Procedure_Instantiation                |
1785                N_Protected_Body_Stub                    |
1786                N_Protected_Type_Declaration             |
1787                N_Single_Task_Declaration                |
1788                N_Subprogram_Body                        |
1789                N_Subprogram_Body_Stub                   |
1790                N_Subprogram_Declaration                 |
1791                N_Subprogram_Renaming_Declaration        |
1792                N_Subtype_Declaration                    |
1793                N_Task_Body                              |
1794                N_Task_Body_Stub                         |
1795                N_Task_Type_Declaration                  |
1796
1797                --  Freeze entity behaves like a declaration or statement
1798
1799                N_Freeze_Entity
1800             =>
1801                --  Do not insert here if the item is not a list member (this
1802                --  happens for example with a triggering statement, and the
1803                --  proper approach is to insert before the entire select).
1804
1805                if not Is_List_Member (P) then
1806                   null;
1807
1808                --  Do not insert if parent of P is an N_Component_Association
1809                --  node (i.e. we are in the context of an N_Aggregate node.
1810                --  In this case we want to insert before the entire aggregate.
1811
1812                elsif Nkind (Parent (P)) = N_Component_Association then
1813                   null;
1814
1815                --  Do not insert if the parent of P is either an N_Variant
1816                --  node or an N_Record_Definition node, meaning in either
1817                --  case that P is a member of a component list, and that
1818                --  therefore the actions should be inserted outside the
1819                --  complete record declaration.
1820
1821                elsif Nkind (Parent (P)) = N_Variant
1822                  or else Nkind (Parent (P)) = N_Record_Definition
1823                then
1824                   null;
1825
1826                --  Do not insert freeze nodes within the loop generated for
1827                --  an aggregate, because they may be elaborated too late for
1828                --  subsequent use in the back end: within a package spec the
1829                --  loop is part of the elaboration procedure and is only
1830                --  elaborated during the second pass.
1831                --  If the loop comes from source, or the entity is local to
1832                --  the loop itself it must remain within.
1833
1834                elsif Nkind (Parent (P)) = N_Loop_Statement
1835                  and then not Comes_From_Source (Parent (P))
1836                  and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
1837                  and then
1838                    Scope (Entity (First (Ins_Actions))) /= Current_Scope
1839                then
1840                   null;
1841
1842                --  Otherwise we can go ahead and do the insertion
1843
1844                elsif  P = Wrapped_Node then
1845                   Store_Before_Actions_In_Scope (Ins_Actions);
1846                   return;
1847
1848                else
1849                   Insert_List_Before_And_Analyze (P, Ins_Actions);
1850                   return;
1851                end if;
1852
1853             --  A special case, N_Raise_xxx_Error can act either as a
1854             --  statement or a subexpression. We tell the difference
1855             --  by looking at the Etype. It is set to Standard_Void_Type
1856             --  in the statement case.
1857
1858             when
1859                N_Raise_xxx_Error =>
1860                   if Etype (P) = Standard_Void_Type then
1861                      if  P = Wrapped_Node then
1862                         Store_Before_Actions_In_Scope (Ins_Actions);
1863                      else
1864                         Insert_List_Before_And_Analyze (P, Ins_Actions);
1865                      end if;
1866
1867                      return;
1868
1869                   --  In the subexpression case, keep climbing
1870
1871                   else
1872                      null;
1873                   end if;
1874
1875             --  If a component association appears within a loop created for
1876             --  an array aggregate, attach the actions to the association so
1877             --  they can be subsequently inserted within the loop. For other
1878             --  component associations insert outside of the aggregate. For
1879             --  an association that will generate a loop, its Loop_Actions
1880             --  attribute is already initialized (see exp_aggr.adb).
1881
1882             --  The list of loop_actions can in turn generate additional ones,
1883             --  that are inserted before the associated node. If the associated
1884             --  node is outside the aggregate, the new actions are collected
1885             --  at the end of the loop actions, to respect the order in which
1886             --  they are to be elaborated.
1887
1888             when
1889                N_Component_Association =>
1890                   if Nkind (Parent (P)) = N_Aggregate
1891                     and then Present (Loop_Actions (P))
1892                   then
1893                      if Is_Empty_List (Loop_Actions (P)) then
1894                         Set_Loop_Actions (P, Ins_Actions);
1895                         Analyze_List (Ins_Actions);
1896
1897                      else
1898                         declare
1899                            Decl : Node_Id := Assoc_Node;
1900
1901                         begin
1902                            --  Check whether these actions were generated
1903                            --  by a declaration that is part of the loop_
1904                            --  actions for the component_association.
1905
1906                            while Present (Decl) loop
1907                               exit when Parent (Decl) = P
1908                                 and then Is_List_Member (Decl)
1909                                 and then
1910                                   List_Containing (Decl) = Loop_Actions (P);
1911                               Decl := Parent (Decl);
1912                            end loop;
1913
1914                            if Present (Decl) then
1915                               Insert_List_Before_And_Analyze
1916                                 (Decl, Ins_Actions);
1917                            else
1918                               Insert_List_After_And_Analyze
1919                                 (Last (Loop_Actions (P)), Ins_Actions);
1920                            end if;
1921                         end;
1922                      end if;
1923
1924                      return;
1925
1926                   else
1927                      null;
1928                   end if;
1929
1930             --  Another special case, an attribute denoting a procedure call
1931
1932             when
1933                N_Attribute_Reference =>
1934                   if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
1935                      if P = Wrapped_Node then
1936                         Store_Before_Actions_In_Scope (Ins_Actions);
1937                      else
1938                         Insert_List_Before_And_Analyze (P, Ins_Actions);
1939                      end if;
1940
1941                      return;
1942
1943                   --  In the subexpression case, keep climbing
1944
1945                   else
1946                      null;
1947                   end if;
1948
1949             --  For all other node types, keep climbing tree
1950
1951             when
1952                N_Abortable_Part                         |
1953                N_Accept_Alternative                     |
1954                N_Access_Definition                      |
1955                N_Access_Function_Definition             |
1956                N_Access_Procedure_Definition            |
1957                N_Access_To_Object_Definition            |
1958                N_Aggregate                              |
1959                N_Allocator                              |
1960                N_Case_Statement_Alternative             |
1961                N_Character_Literal                      |
1962                N_Compilation_Unit                       |
1963                N_Compilation_Unit_Aux                   |
1964                N_Component_Clause                       |
1965                N_Component_Declaration                  |
1966                N_Component_List                         |
1967                N_Constrained_Array_Definition           |
1968                N_Decimal_Fixed_Point_Definition         |
1969                N_Defining_Character_Literal             |
1970                N_Defining_Identifier                    |
1971                N_Defining_Operator_Symbol               |
1972                N_Defining_Program_Unit_Name             |
1973                N_Delay_Alternative                      |
1974                N_Delta_Constraint                       |
1975                N_Derived_Type_Definition                |
1976                N_Designator                             |
1977                N_Digits_Constraint                      |
1978                N_Discriminant_Association               |
1979                N_Discriminant_Specification             |
1980                N_Empty                                  |
1981                N_Entry_Body_Formal_Part                 |
1982                N_Entry_Call_Alternative                 |
1983                N_Entry_Declaration                      |
1984                N_Entry_Index_Specification              |
1985                N_Enumeration_Type_Definition            |
1986                N_Error                                  |
1987                N_Exception_Handler                      |
1988                N_Expanded_Name                          |
1989                N_Explicit_Dereference                   |
1990                N_Extension_Aggregate                    |
1991                N_Floating_Point_Definition              |
1992                N_Formal_Decimal_Fixed_Point_Definition  |
1993                N_Formal_Derived_Type_Definition         |
1994                N_Formal_Discrete_Type_Definition        |
1995                N_Formal_Floating_Point_Definition       |
1996                N_Formal_Modular_Type_Definition         |
1997                N_Formal_Ordinary_Fixed_Point_Definition |
1998                N_Formal_Package_Declaration             |
1999                N_Formal_Private_Type_Definition         |
2000                N_Formal_Signed_Integer_Type_Definition  |
2001                N_Function_Call                          |
2002                N_Function_Specification                 |
2003                N_Generic_Association                    |
2004                N_Handled_Sequence_Of_Statements         |
2005                N_Identifier                             |
2006                N_In                                     |
2007                N_Index_Or_Discriminant_Constraint       |
2008                N_Indexed_Component                      |
2009                N_Integer_Literal                        |
2010                N_Itype_Reference                        |
2011                N_Label                                  |
2012                N_Loop_Parameter_Specification           |
2013                N_Mod_Clause                             |
2014                N_Modular_Type_Definition                |
2015                N_Not_In                                 |
2016                N_Null                                   |
2017                N_Op_Abs                                 |
2018                N_Op_Add                                 |
2019                N_Op_And                                 |
2020                N_Op_Concat                              |
2021                N_Op_Divide                              |
2022                N_Op_Eq                                  |
2023                N_Op_Expon                               |
2024                N_Op_Ge                                  |
2025                N_Op_Gt                                  |
2026                N_Op_Le                                  |
2027                N_Op_Lt                                  |
2028                N_Op_Minus                               |
2029                N_Op_Mod                                 |
2030                N_Op_Multiply                            |
2031                N_Op_Ne                                  |
2032                N_Op_Not                                 |
2033                N_Op_Or                                  |
2034                N_Op_Plus                                |
2035                N_Op_Rem                                 |
2036                N_Op_Rotate_Left                         |
2037                N_Op_Rotate_Right                        |
2038                N_Op_Shift_Left                          |
2039                N_Op_Shift_Right                         |
2040                N_Op_Shift_Right_Arithmetic              |
2041                N_Op_Subtract                            |
2042                N_Op_Xor                                 |
2043                N_Operator_Symbol                        |
2044                N_Ordinary_Fixed_Point_Definition        |
2045                N_Others_Choice                          |
2046                N_Package_Specification                  |
2047                N_Parameter_Association                  |
2048                N_Parameter_Specification                |
2049                N_Pragma_Argument_Association            |
2050                N_Procedure_Specification                |
2051                N_Protected_Body                         |
2052                N_Protected_Definition                   |
2053                N_Qualified_Expression                   |
2054                N_Range                                  |
2055                N_Range_Constraint                       |
2056                N_Real_Literal                           |
2057                N_Real_Range_Specification               |
2058                N_Record_Definition                      |
2059                N_Reference                              |
2060                N_Selected_Component                     |
2061                N_Signed_Integer_Type_Definition         |
2062                N_Single_Protected_Declaration           |
2063                N_Slice                                  |
2064                N_String_Literal                         |
2065                N_Subprogram_Info                        |
2066                N_Subtype_Indication                     |
2067                N_Subunit                                |
2068                N_Task_Definition                        |
2069                N_Terminate_Alternative                  |
2070                N_Triggering_Alternative                 |
2071                N_Type_Conversion                        |
2072                N_Unchecked_Expression                   |
2073                N_Unchecked_Type_Conversion              |
2074                N_Unconstrained_Array_Definition         |
2075                N_Unused_At_End                          |
2076                N_Unused_At_Start                        |
2077                N_Use_Package_Clause                     |
2078                N_Use_Type_Clause                        |
2079                N_Variant                                |
2080                N_Variant_Part                           |
2081                N_Validate_Unchecked_Conversion          |
2082                N_With_Clause                            |
2083                N_With_Type_Clause
2084             =>
2085                null;
2086
2087          end case;
2088
2089          --  Make sure that inserted actions stay in the transient scope
2090
2091          if P = Wrapped_Node then
2092             Store_Before_Actions_In_Scope (Ins_Actions);
2093             return;
2094          end if;
2095
2096          --  If we fall through above tests, keep climbing tree
2097
2098          N := P;
2099
2100          if Nkind (Parent (N)) = N_Subunit then
2101
2102             --  This is the proper body corresponding to a stub. Insertion
2103             --  must be done at the point of the stub, which is in the decla-
2104             --  tive part of the parent unit.
2105
2106             P := Corresponding_Stub (Parent (N));
2107
2108          else
2109             P := Parent (N);
2110          end if;
2111       end loop;
2112
2113    end Insert_Actions;
2114
2115    --  Version with check(s) suppressed
2116
2117    procedure Insert_Actions
2118      (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
2119    is
2120    begin
2121       if Suppress = All_Checks then
2122          declare
2123             Svg : constant Suppress_Array := Scope_Suppress;
2124
2125          begin
2126             Scope_Suppress := (others => True);
2127             Insert_Actions (Assoc_Node, Ins_Actions);
2128             Scope_Suppress := Svg;
2129          end;
2130
2131       else
2132          declare
2133             Svg : constant Boolean := Scope_Suppress (Suppress);
2134
2135          begin
2136             Scope_Suppress (Suppress) := True;
2137             Insert_Actions (Assoc_Node, Ins_Actions);
2138             Scope_Suppress (Suppress) := Svg;
2139          end;
2140       end if;
2141    end Insert_Actions;
2142
2143    --------------------------
2144    -- Insert_Actions_After --
2145    --------------------------
2146
2147    procedure Insert_Actions_After
2148      (Assoc_Node  : Node_Id;
2149       Ins_Actions : List_Id)
2150    is
2151    begin
2152       if Scope_Is_Transient
2153         and then Assoc_Node = Node_To_Be_Wrapped
2154       then
2155          Store_After_Actions_In_Scope (Ins_Actions);
2156       else
2157          Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2158       end if;
2159    end Insert_Actions_After;
2160
2161    ---------------------------------
2162    -- Insert_Library_Level_Action --
2163    ---------------------------------
2164
2165    procedure Insert_Library_Level_Action (N : Node_Id) is
2166       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2167
2168    begin
2169       New_Scope (Cunit_Entity (Main_Unit));
2170
2171       if No (Actions (Aux)) then
2172          Set_Actions (Aux, New_List (N));
2173       else
2174          Append (N, Actions (Aux));
2175       end if;
2176
2177       Analyze (N);
2178       Pop_Scope;
2179    end Insert_Library_Level_Action;
2180
2181    ----------------------------------
2182    -- Insert_Library_Level_Actions --
2183    ----------------------------------
2184
2185    procedure Insert_Library_Level_Actions (L : List_Id) is
2186       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2187
2188    begin
2189       if Is_Non_Empty_List (L) then
2190          New_Scope (Cunit_Entity (Main_Unit));
2191
2192          if No (Actions (Aux)) then
2193             Set_Actions (Aux, L);
2194             Analyze_List (L);
2195          else
2196             Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2197          end if;
2198
2199          Pop_Scope;
2200       end if;
2201    end Insert_Library_Level_Actions;
2202
2203    ----------------------
2204    -- Inside_Init_Proc --
2205    ----------------------
2206
2207    function Inside_Init_Proc return Boolean is
2208       S : Entity_Id;
2209
2210    begin
2211       S := Current_Scope;
2212       while Present (S)
2213         and then S /= Standard_Standard
2214       loop
2215          if Is_Init_Proc (S) then
2216             return True;
2217          else
2218             S := Scope (S);
2219          end if;
2220       end loop;
2221
2222       return False;
2223    end Inside_Init_Proc;
2224
2225    ----------------------------
2226    -- Is_All_Null_Statements --
2227    ----------------------------
2228
2229    function Is_All_Null_Statements (L : List_Id) return Boolean is
2230       Stm : Node_Id;
2231
2232    begin
2233       Stm := First (L);
2234       while Present (Stm) loop
2235          if Nkind (Stm) /= N_Null_Statement then
2236             return False;
2237          end if;
2238
2239          Next (Stm);
2240       end loop;
2241
2242       return True;
2243    end Is_All_Null_Statements;
2244
2245    ----------------------------------
2246    -- Is_Possibly_Unaligned_Object --
2247    ----------------------------------
2248
2249    function Is_Possibly_Unaligned_Object (P : Node_Id) return Boolean is
2250    begin
2251       --  If target does not have strict alignment, result is always
2252       --  False, since correctness of code does no depend on alignment.
2253
2254       if not Target_Strict_Alignment then
2255          return False;
2256       end if;
2257
2258       --  If renamed object, apply test to underlying object
2259
2260       if Is_Entity_Name (P)
2261         and then Is_Object (Entity (P))
2262         and then Present (Renamed_Object (Entity (P)))
2263       then
2264          return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (P)));
2265       end if;
2266
2267       --  If this is an element of a packed array, may be unaligned
2268
2269       if Is_Ref_To_Bit_Packed_Array (P) then
2270          return True;
2271       end if;
2272
2273       --  Case of component reference
2274
2275       if Nkind (P) = N_Selected_Component then
2276
2277          --  If component reference is for a record that is bit packed
2278          --  or has a specified alignment (that might be too small) or
2279          --  the component reference has a component clause, then the
2280          --  object may be unaligned.
2281
2282          if Is_Packed (Etype (Prefix (P)))
2283            or else Known_Alignment (Etype (Prefix (P)))
2284            or else Present (Component_Clause (Entity (Selector_Name (P))))
2285          then
2286             return True;
2287
2288          --  Otherwise, for a component reference, test prefix
2289
2290          else
2291             return Is_Possibly_Unaligned_Object (Prefix (P));
2292          end if;
2293
2294       --  If not a component reference, must be aligned
2295
2296       else
2297          return False;
2298       end if;
2299    end Is_Possibly_Unaligned_Object;
2300
2301    ---------------------------------
2302    -- Is_Possibly_Unaligned_Slice --
2303    ---------------------------------
2304
2305    function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
2306    begin
2307       if Is_Entity_Name (P)
2308         and then Is_Object (Entity (P))
2309         and then Present (Renamed_Object (Entity (P)))
2310       then
2311          return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (P)));
2312       end if;
2313
2314       --  We only need to worry if the target has strict alignment, unless
2315       --  it is a nested record component with a component clause, which
2316       --  Gigi does not handle well. This patch should disappear with GCC 3.0
2317       --  and it is not clear why it is needed even when the representation
2318       --  clause is a confirming one, but in its absence gigi complains that
2319       --  the slice is not addressable.???
2320
2321       if not Target_Strict_Alignment then
2322          if Nkind (P) /= N_Slice
2323            or else Nkind (Prefix (P)) /= N_Selected_Component
2324            or else Nkind (Prefix (Prefix (P))) /= N_Selected_Component
2325          then
2326             return False;
2327          end if;
2328       end if;
2329
2330       --  The reference must be a slice
2331
2332       if Nkind (P) /= N_Slice then
2333          return False;
2334       end if;
2335
2336       --  If it is a slice, then look at the array type being sliced
2337
2338       declare
2339          Pref : constant Node_Id   := Prefix (P);
2340          Typ  : constant Entity_Id := Etype (Prefix (P));
2341
2342       begin
2343          --  The worrisome case is one where we don't know the alignment
2344          --  of the array, or we know it and it is greater than 1 (if the
2345          --  alignment is one, then obviously it cannot be misaligned).
2346
2347          if Known_Alignment (Typ) and then Alignment (Typ) = 1 then
2348             return False;
2349          end if;
2350
2351          --  The only way we can be unaligned is if the array being sliced
2352          --  is a component of a record, and either the record is packed,
2353          --  or the component has a component clause, or the record has
2354          --  a specified alignment (that might be too small).
2355
2356          return
2357             Nkind (Pref) = N_Selected_Component
2358               and then
2359                  (Is_Packed (Etype (Prefix (Pref)))
2360                     or else
2361                   Known_Alignment (Etype (Prefix (Pref)))
2362                     or else
2363                   Present (Component_Clause (Entity (Selector_Name (Pref)))));
2364       end;
2365    end Is_Possibly_Unaligned_Slice;
2366
2367    --------------------------------
2368    -- Is_Ref_To_Bit_Packed_Array --
2369    --------------------------------
2370
2371    function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is
2372       Result : Boolean;
2373       Expr   : Node_Id;
2374
2375    begin
2376       if Is_Entity_Name (P)
2377         and then Is_Object (Entity (P))
2378         and then Present (Renamed_Object (Entity (P)))
2379       then
2380          return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (P)));
2381       end if;
2382
2383       if Nkind (P) = N_Indexed_Component
2384            or else
2385          Nkind (P) = N_Selected_Component
2386       then
2387          if Is_Bit_Packed_Array (Etype (Prefix (P))) then
2388             Result := True;
2389          else
2390             Result := Is_Ref_To_Bit_Packed_Array (Prefix (P));
2391          end if;
2392
2393          if Result and then Nkind (P) = N_Indexed_Component then
2394             Expr := First (Expressions (P));
2395
2396             while Present (Expr) loop
2397                Force_Evaluation (Expr);
2398                Next (Expr);
2399             end loop;
2400          end if;
2401
2402          return Result;
2403
2404       else
2405          return False;
2406       end if;
2407    end Is_Ref_To_Bit_Packed_Array;
2408
2409    --------------------------------
2410    -- Is_Ref_To_Bit_Packed_Slice --
2411    --------------------------------
2412
2413    function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is
2414    begin
2415       if Is_Entity_Name (P)
2416         and then Is_Object (Entity (P))
2417         and then Present (Renamed_Object (Entity (P)))
2418       then
2419          return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (P)));
2420       end if;
2421
2422       if Nkind (P) = N_Slice
2423         and then Is_Bit_Packed_Array (Etype (Prefix (P)))
2424       then
2425          return True;
2426
2427       elsif Nkind (P) = N_Indexed_Component
2428            or else
2429          Nkind (P) = N_Selected_Component
2430       then
2431          return Is_Ref_To_Bit_Packed_Slice (Prefix (P));
2432
2433       else
2434          return False;
2435       end if;
2436    end Is_Ref_To_Bit_Packed_Slice;
2437
2438    -----------------------
2439    -- Is_Renamed_Object --
2440    -----------------------
2441
2442    function Is_Renamed_Object (N : Node_Id) return Boolean is
2443       Pnod : constant Node_Id   := Parent (N);
2444       Kind : constant Node_Kind := Nkind (Pnod);
2445
2446    begin
2447       if Kind = N_Object_Renaming_Declaration then
2448          return True;
2449
2450       elsif Kind = N_Indexed_Component
2451         or else Kind = N_Selected_Component
2452       then
2453          return Is_Renamed_Object (Pnod);
2454
2455       else
2456          return False;
2457       end if;
2458    end Is_Renamed_Object;
2459
2460    ----------------------------
2461    -- Is_Untagged_Derivation --
2462    ----------------------------
2463
2464    function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
2465    begin
2466       return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
2467                or else
2468              (Is_Private_Type (T) and then Present (Full_View (T))
2469                and then not Is_Tagged_Type (Full_View (T))
2470                and then Is_Derived_Type (Full_View (T))
2471                and then Etype (Full_View (T)) /= T);
2472
2473    end Is_Untagged_Derivation;
2474
2475    --------------------
2476    -- Kill_Dead_Code --
2477    --------------------
2478
2479    procedure Kill_Dead_Code (N : Node_Id) is
2480    begin
2481       if Present (N) then
2482          Remove_Handler_Entries (N);
2483          Remove_Warning_Messages (N);
2484
2485          --  Recurse into block statements and bodies to process declarations
2486          --  and statements
2487
2488          if Nkind (N) = N_Block_Statement
2489            or else Nkind (N) = N_Subprogram_Body
2490            or else Nkind (N) = N_Package_Body
2491          then
2492             Kill_Dead_Code (Declarations (N));
2493             Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
2494
2495             if Nkind (N) = N_Subprogram_Body then
2496                Set_Is_Eliminated (Defining_Entity (N));
2497             end if;
2498
2499          --  Recurse into composite statement to kill individual statements,
2500          --  in particular instantiations.
2501
2502          elsif Nkind (N) = N_If_Statement then
2503             Kill_Dead_Code (Then_Statements (N));
2504             Kill_Dead_Code (Elsif_Parts (N));
2505             Kill_Dead_Code (Else_Statements (N));
2506
2507          elsif Nkind (N) = N_Loop_Statement then
2508             Kill_Dead_Code (Statements (N));
2509
2510          elsif Nkind (N) = N_Case_Statement then
2511             declare
2512                Alt : Node_Id := First (Alternatives (N));
2513
2514             begin
2515                while Present (Alt) loop
2516                   Kill_Dead_Code (Statements (Alt));
2517                   Next (Alt);
2518                end loop;
2519             end;
2520
2521          elsif Nkind (N) = N_Case_Statement_Alternative then
2522             Kill_Dead_Code (Statements (N));
2523
2524          --  Deal with dead instances caused by deleting instantiations
2525
2526          elsif Nkind (N) in N_Generic_Instantiation then
2527             Remove_Dead_Instance (N);
2528          end if;
2529
2530          Delete_Tree (N);
2531       end if;
2532    end Kill_Dead_Code;
2533
2534    --  Case where argument is a list of nodes to be killed
2535
2536    procedure Kill_Dead_Code (L : List_Id) is
2537       N : Node_Id;
2538
2539    begin
2540       if Is_Non_Empty_List (L) then
2541          loop
2542             N := Remove_Head (L);
2543             exit when No (N);
2544             Kill_Dead_Code (N);
2545          end loop;
2546       end if;
2547    end Kill_Dead_Code;
2548
2549    ------------------------
2550    -- Known_Non_Negative --
2551    ------------------------
2552
2553    function Known_Non_Negative (Opnd : Node_Id) return Boolean is
2554    begin
2555       if Is_OK_Static_Expression (Opnd)
2556         and then Expr_Value (Opnd) >= 0
2557       then
2558          return True;
2559
2560       else
2561          declare
2562             Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
2563
2564          begin
2565             return
2566               Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
2567          end;
2568       end if;
2569    end Known_Non_Negative;
2570
2571    --------------------
2572    -- Known_Non_Null --
2573    --------------------
2574
2575    function Known_Non_Null (N : Node_Id) return Boolean is
2576    begin
2577       pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))));
2578
2579       --  Case of entity for which Is_Known_Non_Null is True
2580
2581       if Is_Entity_Name (N) and then Is_Known_Non_Null (Entity (N)) then
2582
2583          --  If the entity is aliased or volatile, then we decide that
2584          --  we don't know it is really non-null even if the sequential
2585          --  flow indicates that it is, since such variables can be
2586          --  changed without us noticing.
2587
2588          if Is_Aliased (Entity (N))
2589            or else Treat_As_Volatile (Entity (N))
2590          then
2591             return False;
2592
2593          --  For all other cases, the flag is decisive
2594
2595          else
2596             return True;
2597          end if;
2598
2599       --  True if access attribute
2600
2601       elsif Nkind (N) = N_Attribute_Reference
2602         and then (Attribute_Name (N) = Name_Access
2603                     or else
2604                   Attribute_Name (N) = Name_Unchecked_Access
2605                     or else
2606                   Attribute_Name (N) = Name_Unrestricted_Access)
2607       then
2608          return True;
2609
2610       --  True if allocator
2611
2612       elsif Nkind (N) = N_Allocator then
2613          return True;
2614
2615       --  For a conversion, true if expression is known non-null
2616
2617       elsif Nkind (N) = N_Type_Conversion then
2618          return Known_Non_Null (Expression (N));
2619
2620       --  One more case is when Current_Value references a condition
2621       --  that ensures a non-null value.
2622
2623       elsif Is_Entity_Name (N) then
2624          declare
2625             Op  : Node_Kind;
2626             Val : Node_Id;
2627
2628          begin
2629             Get_Current_Value_Condition (N, Op, Val);
2630             return Op = N_Op_Ne and then Nkind (Val) = N_Null;
2631          end;
2632
2633       --  Above are all cases where the value could be determined to be
2634       --  non-null. In all other cases, we don't know, so return False.
2635
2636       else
2637          return False;
2638       end if;
2639    end Known_Non_Null;
2640
2641    -----------------------------
2642    -- Make_CW_Equivalent_Type --
2643    -----------------------------
2644
2645    --  Create a record type used as an equivalent of any member
2646    --  of the class which takes its size from exp.
2647
2648    --  Generate the following code:
2649
2650    --   type Equiv_T is record
2651    --     _parent :  T (List of discriminant constaints taken from Exp);
2652    --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
2653    --   end Equiv_T;
2654    --
2655    --   ??? Note that this type does not guarantee same alignment as all
2656    --   derived types
2657
2658    function Make_CW_Equivalent_Type
2659      (T    : Entity_Id;
2660       E    : Node_Id)
2661       return Entity_Id
2662    is
2663       Loc         : constant Source_Ptr := Sloc (E);
2664       Root_Typ    : constant Entity_Id  := Root_Type (T);
2665       List_Def    : constant List_Id    := Empty_List;
2666       Equiv_Type  : Entity_Id;
2667       Range_Type  : Entity_Id;
2668       Str_Type    : Entity_Id;
2669       Constr_Root : Entity_Id;
2670       Sizexpr     : Node_Id;
2671
2672    begin
2673       if not Has_Discriminants (Root_Typ) then
2674          Constr_Root := Root_Typ;
2675       else
2676          Constr_Root :=
2677            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2678
2679          --  subtype cstr__n is T (List of discr constraints taken from Exp)
2680
2681          Append_To (List_Def,
2682            Make_Subtype_Declaration (Loc,
2683              Defining_Identifier => Constr_Root,
2684                Subtype_Indication =>
2685                  Make_Subtype_From_Expr (E, Root_Typ)));
2686       end if;
2687
2688       --  subtype rg__xx is Storage_Offset range
2689       --                           (Expr'size - typ'size) / Storage_Unit
2690
2691       Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
2692
2693       Sizexpr :=
2694         Make_Op_Subtract (Loc,
2695           Left_Opnd =>
2696             Make_Attribute_Reference (Loc,
2697               Prefix =>
2698                 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
2699               Attribute_Name => Name_Size),
2700           Right_Opnd =>
2701             Make_Attribute_Reference (Loc,
2702               Prefix => New_Reference_To (Constr_Root, Loc),
2703               Attribute_Name => Name_Object_Size));
2704
2705       Set_Paren_Count (Sizexpr, 1);
2706
2707       Append_To (List_Def,
2708         Make_Subtype_Declaration (Loc,
2709           Defining_Identifier => Range_Type,
2710           Subtype_Indication =>
2711             Make_Subtype_Indication (Loc,
2712               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
2713               Constraint => Make_Range_Constraint (Loc,
2714                 Range_Expression =>
2715                   Make_Range (Loc,
2716                     Low_Bound => Make_Integer_Literal (Loc, 1),
2717                     High_Bound =>
2718                       Make_Op_Divide (Loc,
2719                         Left_Opnd => Sizexpr,
2720                         Right_Opnd => Make_Integer_Literal (Loc,
2721                             Intval => System_Storage_Unit)))))));
2722
2723       --  subtype str__nn is Storage_Array (rg__x);
2724
2725       Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2726       Append_To (List_Def,
2727         Make_Subtype_Declaration (Loc,
2728           Defining_Identifier => Str_Type,
2729           Subtype_Indication =>
2730             Make_Subtype_Indication (Loc,
2731               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
2732               Constraint =>
2733                 Make_Index_Or_Discriminant_Constraint (Loc,
2734                   Constraints =>
2735                     New_List (New_Reference_To (Range_Type, Loc))))));
2736
2737       --  type Equiv_T is record
2738       --    _parent : Tnn;
2739       --    E : Str_Type;
2740       --  end Equiv_T;
2741
2742       Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2743
2744       --  When the target requires front-end layout, it's necessary to allow
2745       --  the equivalent type to be frozen so that layout can occur (when the
2746       --  associated class-wide subtype is frozen, the equivalent type will
2747       --  be frozen, see freeze.adb). For other targets, Gigi wants to have
2748       --  the equivalent type marked as frozen and deals with this type itself.
2749       --  In the Gigi case this will also avoid the generation of an init
2750       --  procedure for the type.
2751
2752       if not Frontend_Layout_On_Target then
2753          Set_Is_Frozen (Equiv_Type);
2754       end if;
2755
2756       Set_Ekind (Equiv_Type, E_Record_Type);
2757       Set_Parent_Subtype (Equiv_Type, Constr_Root);
2758
2759       Append_To (List_Def,
2760         Make_Full_Type_Declaration (Loc,
2761           Defining_Identifier => Equiv_Type,
2762
2763           Type_Definition =>
2764             Make_Record_Definition (Loc,
2765               Component_List => Make_Component_List (Loc,
2766                 Component_Items => New_List (
2767                   Make_Component_Declaration (Loc,
2768                     Defining_Identifier =>
2769                       Make_Defining_Identifier (Loc, Name_uParent),
2770                     Subtype_Indication => New_Reference_To (Constr_Root, Loc)),
2771
2772                   Make_Component_Declaration (Loc,
2773                     Defining_Identifier =>
2774                       Make_Defining_Identifier (Loc,
2775                         Chars => New_Internal_Name ('C')),
2776                     Subtype_Indication => New_Reference_To (Str_Type, Loc))),
2777                 Variant_Part => Empty))));
2778
2779       Insert_Actions (E, List_Def);
2780       return Equiv_Type;
2781    end Make_CW_Equivalent_Type;
2782
2783    ------------------------
2784    -- Make_Literal_Range --
2785    ------------------------
2786
2787    function Make_Literal_Range
2788      (Loc         : Source_Ptr;
2789       Literal_Typ : Entity_Id)
2790       return        Node_Id
2791    is
2792       Lo : constant Node_Id :=
2793              New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
2794
2795    begin
2796       Set_Analyzed (Lo, False);
2797
2798          return
2799            Make_Range (Loc,
2800              Low_Bound => Lo,
2801
2802              High_Bound =>
2803                Make_Op_Subtract (Loc,
2804                   Left_Opnd =>
2805                     Make_Op_Add (Loc,
2806                       Left_Opnd  => New_Copy_Tree (Lo),
2807                       Right_Opnd =>
2808                         Make_Integer_Literal (Loc,
2809                           String_Literal_Length (Literal_Typ))),
2810                   Right_Opnd => Make_Integer_Literal (Loc, 1)));
2811    end Make_Literal_Range;
2812
2813    ----------------------------
2814    -- Make_Subtype_From_Expr --
2815    ----------------------------
2816
2817    --  1. If Expr is an uncontrained array expression, creates
2818    --    Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
2819
2820    --  2. If Expr is a unconstrained discriminated type expression, creates
2821    --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
2822
2823    --  3. If Expr is class-wide, creates an implicit class wide subtype
2824
2825    function Make_Subtype_From_Expr
2826      (E       : Node_Id;
2827       Unc_Typ : Entity_Id)
2828       return    Node_Id
2829    is
2830       Loc         : constant Source_Ptr := Sloc (E);
2831       List_Constr : constant List_Id    := New_List;
2832       D           : Entity_Id;
2833
2834       Full_Subtyp  : Entity_Id;
2835       Priv_Subtyp  : Entity_Id;
2836       Utyp         : Entity_Id;
2837       Full_Exp     : Node_Id;
2838
2839    begin
2840       if Is_Private_Type (Unc_Typ)
2841         and then Has_Unknown_Discriminants (Unc_Typ)
2842       then
2843          --  Prepare the subtype completion, Go to base type to
2844          --  find underlying type.
2845
2846          Utyp        := Underlying_Type (Base_Type (Unc_Typ));
2847          Full_Subtyp := Make_Defining_Identifier (Loc,
2848                           New_Internal_Name ('C'));
2849          Full_Exp    :=
2850            Unchecked_Convert_To
2851              (Utyp, Duplicate_Subexpr_No_Checks (E));
2852          Set_Parent (Full_Exp, Parent (E));
2853
2854          Priv_Subtyp :=
2855            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2856
2857          Insert_Action (E,
2858            Make_Subtype_Declaration (Loc,
2859              Defining_Identifier => Full_Subtyp,
2860              Subtype_Indication  => Make_Subtype_From_Expr (Full_Exp, Utyp)));
2861
2862          --  Define the dummy private subtype
2863
2864          Set_Ekind          (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
2865          Set_Etype          (Priv_Subtyp, Unc_Typ);
2866          Set_Scope          (Priv_Subtyp, Full_Subtyp);
2867          Set_Is_Constrained (Priv_Subtyp);
2868          Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
2869          Set_Is_Itype       (Priv_Subtyp);
2870          Set_Associated_Node_For_Itype (Priv_Subtyp, E);
2871
2872          if Is_Tagged_Type  (Priv_Subtyp) then
2873             Set_Class_Wide_Type
2874               (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
2875             Set_Primitive_Operations (Priv_Subtyp,
2876               Primitive_Operations (Unc_Typ));
2877          end if;
2878
2879          Set_Full_View (Priv_Subtyp, Full_Subtyp);
2880
2881          return New_Reference_To (Priv_Subtyp, Loc);
2882
2883       elsif Is_Array_Type (Unc_Typ) then
2884          for J in 1 .. Number_Dimensions (Unc_Typ) loop
2885             Append_To (List_Constr,
2886               Make_Range (Loc,
2887                 Low_Bound =>
2888                   Make_Attribute_Reference (Loc,
2889                     Prefix => Duplicate_Subexpr_No_Checks (E),
2890                     Attribute_Name => Name_First,
2891                     Expressions => New_List (
2892                       Make_Integer_Literal (Loc, J))),
2893
2894                 High_Bound =>
2895                   Make_Attribute_Reference (Loc,
2896                     Prefix         => Duplicate_Subexpr_No_Checks (E),
2897                     Attribute_Name => Name_Last,
2898                     Expressions    => New_List (
2899                       Make_Integer_Literal (Loc, J)))));
2900          end loop;
2901
2902       elsif Is_Class_Wide_Type (Unc_Typ) then
2903          declare
2904             CW_Subtype : Entity_Id;
2905             EQ_Typ     : Entity_Id := Empty;
2906
2907          begin
2908             --  A class-wide equivalent type is not needed when Java_VM
2909             --  because the JVM back end handles the class-wide object
2910             --  initialization itself (and doesn't need or want the
2911             --  additional intermediate type to handle the assignment).
2912
2913             if Expander_Active and then not Java_VM then
2914                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
2915             end if;
2916
2917             CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
2918             Set_Equivalent_Type (CW_Subtype, EQ_Typ);
2919
2920             if Present (EQ_Typ) then
2921                Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
2922             end if;
2923
2924             Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
2925
2926             return New_Occurrence_Of (CW_Subtype, Loc);
2927          end;
2928
2929       --  Comment needed (what case is this ???)
2930
2931       else
2932          D := First_Discriminant (Unc_Typ);
2933          while Present (D) loop
2934             Append_To (List_Constr,
2935               Make_Selected_Component (Loc,
2936                 Prefix        => Duplicate_Subexpr_No_Checks (E),
2937                 Selector_Name => New_Reference_To (D, Loc)));
2938
2939             Next_Discriminant (D);
2940          end loop;
2941       end if;
2942
2943       return
2944         Make_Subtype_Indication (Loc,
2945           Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
2946           Constraint   =>
2947             Make_Index_Or_Discriminant_Constraint (Loc,
2948               Constraints => List_Constr));
2949    end Make_Subtype_From_Expr;
2950
2951    -----------------------------
2952    -- May_Generate_Large_Temp --
2953    -----------------------------
2954
2955    --  At the current time, the only types that we return False for (i.e.
2956    --  where we decide we know they cannot generate large temps) are ones
2957    --  where we know the size is 128 bits or less at compile time, and we
2958    --  are still not doing a thorough job on arrays and records ???
2959
2960    function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
2961    begin
2962       if not Stack_Checking_Enabled then
2963          return False;
2964
2965       elsif not Size_Known_At_Compile_Time (Typ) then
2966          return False;
2967
2968       elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
2969          return False;
2970
2971       elsif Is_Array_Type (Typ)
2972         and then Present (Packed_Array_Type (Typ))
2973       then
2974          return May_Generate_Large_Temp (Packed_Array_Type (Typ));
2975
2976       --  We could do more here to find other small types ???
2977
2978       else
2979          return True;
2980       end if;
2981    end May_Generate_Large_Temp;
2982
2983    ----------------------------
2984    -- New_Class_Wide_Subtype --
2985    ----------------------------
2986
2987    function New_Class_Wide_Subtype
2988      (CW_Typ : Entity_Id;
2989       N      : Node_Id)
2990       return   Entity_Id
2991    is
2992       Res       : constant Entity_Id := Create_Itype (E_Void, N);
2993       Res_Name  : constant Name_Id   := Chars (Res);
2994       Res_Scope : constant Entity_Id := Scope (Res);
2995
2996    begin
2997       Copy_Node (CW_Typ, Res);
2998       Set_Sloc (Res, Sloc (N));
2999       Set_Is_Itype (Res);
3000       Set_Associated_Node_For_Itype (Res, N);
3001       Set_Is_Public (Res, False);   --  By default, may be changed below.
3002       Set_Public_Status (Res);
3003       Set_Chars (Res, Res_Name);
3004       Set_Scope (Res, Res_Scope);
3005       Set_Ekind (Res, E_Class_Wide_Subtype);
3006       Set_Next_Entity (Res, Empty);
3007       Set_Etype (Res, Base_Type (CW_Typ));
3008
3009       --  For targets where front-end layout is required, reset the Is_Frozen
3010       --  status of the subtype to False (it can be implicitly set to true
3011       --  from the copy of the class-wide type). For other targets, Gigi
3012       --  doesn't want the class-wide subtype to go through the freezing
3013       --  process (though it's unclear why that causes problems and it would
3014       --  be nice to allow freezing to occur normally for all targets ???).
3015
3016       if Frontend_Layout_On_Target then
3017          Set_Is_Frozen (Res, False);
3018       end if;
3019
3020       Set_Freeze_Node (Res, Empty);
3021       return (Res);
3022    end New_Class_Wide_Subtype;
3023
3024    -------------------------
3025    -- Remove_Side_Effects --
3026    -------------------------
3027
3028    procedure Remove_Side_Effects
3029      (Exp          : Node_Id;
3030       Name_Req     : Boolean := False;
3031       Variable_Ref : Boolean := False)
3032    is
3033       Loc          : constant Source_Ptr := Sloc (Exp);
3034       Exp_Type     : constant Entity_Id      := Etype (Exp);
3035       Svg_Suppress : constant Suppress_Array := Scope_Suppress;
3036       Def_Id       : Entity_Id;
3037       Ref_Type     : Entity_Id;
3038       Res          : Node_Id;
3039       Ptr_Typ_Decl : Node_Id;
3040       New_Exp      : Node_Id;
3041       E            : Node_Id;
3042
3043       function Side_Effect_Free (N : Node_Id) return Boolean;
3044       --  Determines if the tree N represents an expession that is known
3045       --  not to have side effects, and for which no processing is required.
3046
3047       function Side_Effect_Free (L : List_Id) return Boolean;
3048       --  Determines if all elements of the list L are side effect free
3049
3050       function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
3051       --  The argument N is a construct where the Prefix is dereferenced
3052       --  if it is a an access type and the result is a variable. The call
3053       --  returns True if the construct is side effect free (not considering
3054       --  side effects in other than the prefix which are to be tested by the
3055       --  caller).
3056
3057       function Within_In_Parameter (N : Node_Id) return Boolean;
3058       --  Determines if N is a subcomponent of a composite in-parameter.
3059       --  If so, N is not side-effect free when the actual is global and
3060       --  modifiable indirectly from within a subprogram, because it may
3061       --  be passed by reference. The front-end must be conservative here
3062       --  and assume that this may happen with any array or record type.
3063       --  On the other hand, we cannot create temporaries for all expressions
3064       --  for which this condition is true, for various reasons that might
3065       --  require clearing up ??? For example, descriminant references that
3066       --  appear out of place, or spurious type errors with class-wide
3067       --  expressions. As a result, we limit the transformation to loop
3068       --  bounds, which is so far the only case that requires it.
3069
3070       -----------------------------
3071       -- Safe_Prefixed_Reference --
3072       -----------------------------
3073
3074       function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
3075       begin
3076          --  If prefix is not side effect free, definitely not safe
3077
3078          if not Side_Effect_Free (Prefix (N)) then
3079             return False;
3080
3081          --  If the prefix is of an access type that is not access-to-constant,
3082          --  then this construct is a variable reference, which means it is to
3083          --  be considered to have side effects if Variable_Ref is set True
3084          --  Exception is an access to an entity that is a constant or an
3085          --  in-parameter which does not come from source, and is the result
3086          --  of a previous removal of side-effects.
3087
3088          elsif Is_Access_Type (Etype (Prefix (N)))
3089            and then not Is_Access_Constant (Etype (Prefix (N)))
3090            and then Variable_Ref
3091          then
3092             if not Is_Entity_Name (Prefix (N)) then
3093                return False;
3094             else
3095                return Ekind (Entity (Prefix (N))) = E_Constant
3096                  or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
3097             end if;
3098
3099          --  The following test is the simplest way of solving a complex
3100          --  problem uncovered by BB08-010: Side effect on loop bound that
3101          --  is a subcomponent of a global variable:
3102          --    If a loop bound is a subcomponent of a global variable, a
3103          --    modification of that variable within the loop may incorrectly
3104          --    affect the execution of the loop.
3105
3106          elsif not
3107            (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
3108               or else not Within_In_Parameter (Prefix (N)))
3109          then
3110             return False;
3111
3112          --  All other cases are side effect free
3113
3114          else
3115             return True;
3116          end if;
3117       end Safe_Prefixed_Reference;
3118
3119       ----------------------
3120       -- Side_Effect_Free --
3121       ----------------------
3122
3123       function Side_Effect_Free (N : Node_Id) return Boolean is
3124       begin
3125          --  Note on checks that could raise Constraint_Error. Strictly, if
3126          --  we take advantage of 11.6, these checks do not count as side
3127          --  effects. However, we would just as soon consider that they are
3128          --  side effects, since the backend CSE does not work very well on
3129          --  expressions which can raise Constraint_Error. On the other
3130          --  hand, if we do not consider them to be side effect free, then
3131          --  we get some awkward expansions in -gnato mode, resulting in
3132          --  code insertions at a point where we do not have a clear model
3133          --  for performing the insertions. See 4908-002/comment for details.
3134
3135          --  Special handling for entity names
3136
3137          if Is_Entity_Name (N) then
3138
3139             --  If the entity is a constant, it is definitely side effect
3140             --  free. Note that the test of Is_Variable (N) below might
3141             --  be expected to catch this case, but it does not, because
3142             --  this test goes to the original tree, and we may have
3143             --  already rewritten a variable node with a constant as
3144             --  a result of an earlier Force_Evaluation call.
3145
3146             if Ekind (Entity (N)) = E_Constant
3147               or else Ekind (Entity (N)) = E_In_Parameter
3148             then
3149                return True;
3150
3151             --  Functions are not side effect free
3152
3153             elsif Ekind (Entity (N)) = E_Function then
3154                return False;
3155
3156             --  Variables are considered to be a side effect if Variable_Ref
3157             --  is set or if we have a volatile variable and Name_Req is off.
3158             --  If Name_Req is True then we can't help returning a name which
3159             --  effectively allows multiple references in any case.
3160
3161             elsif Is_Variable (N) then
3162                return not Variable_Ref
3163                  and then (not Treat_As_Volatile (Entity (N))
3164                              or else Name_Req);
3165
3166             --  Any other entity (e.g. a subtype name) is definitely side
3167             --  effect free.
3168
3169             else
3170                return True;
3171             end if;
3172
3173          --  A value known at compile time is always side effect free
3174
3175          elsif Compile_Time_Known_Value (N) then
3176             return True;
3177          end if;
3178
3179          --  For other than entity names and compile time known values,
3180          --  check the node kind for special processing.
3181
3182          case Nkind (N) is
3183
3184             --  An attribute reference is side effect free if its expressions
3185             --  are side effect free and its prefix is side effect free or
3186             --  is an entity reference.
3187
3188             --  Is this right? what about x'first where x is a variable???
3189
3190             when N_Attribute_Reference =>
3191                return Side_Effect_Free (Expressions (N))
3192                  and then (Is_Entity_Name (Prefix (N))
3193                             or else Side_Effect_Free (Prefix (N)));
3194
3195             --  A binary operator is side effect free if and both operands
3196             --  are side effect free. For this purpose binary operators
3197             --  include membership tests and short circuit forms
3198
3199             when N_Binary_Op |
3200                  N_In        |
3201                  N_Not_In    |
3202                  N_And_Then  |
3203                  N_Or_Else
3204             =>
3205                return Side_Effect_Free (Left_Opnd  (N))
3206                  and then Side_Effect_Free (Right_Opnd (N));
3207
3208             --  An explicit dereference is side effect free only if it is
3209             --  a side effect free prefixed reference.
3210
3211             when N_Explicit_Dereference =>
3212                return Safe_Prefixed_Reference (N);
3213
3214             --  A call to _rep_to_pos is side effect free, since we generate
3215             --  this pure function call ourselves. Moreover it is critically
3216             --  important to make this exception, since otherwise we can
3217             --  have discriminants in array components which don't look
3218             --  side effect free in the case of an array whose index type
3219             --  is an enumeration type with an enumeration rep clause.
3220
3221             --  All other function calls are not side effect free
3222
3223             when N_Function_Call =>
3224                return Nkind (Name (N)) = N_Identifier
3225                  and then Is_TSS (Name (N), TSS_Rep_To_Pos)
3226                  and then
3227                    Side_Effect_Free (First (Parameter_Associations (N)));
3228
3229             --  An indexed component is side effect free if it is a side
3230             --  effect free prefixed reference and all the indexing
3231             --  expressions are side effect free.
3232
3233             when N_Indexed_Component =>
3234                return Side_Effect_Free (Expressions (N))
3235                  and then Safe_Prefixed_Reference (N);
3236
3237             --  A type qualification is side effect free if the expression
3238             --  is side effect free.
3239
3240             when N_Qualified_Expression =>
3241                return Side_Effect_Free (Expression (N));
3242
3243             --  A selected component is side effect free only if it is a
3244             --  side effect free prefixed reference.
3245
3246             when N_Selected_Component =>
3247                return Safe_Prefixed_Reference (N);
3248
3249             --  A range is side effect free if the bounds are side effect free
3250
3251             when N_Range =>
3252                return Side_Effect_Free (Low_Bound (N))
3253                  and then Side_Effect_Free (High_Bound (N));
3254
3255             --  A slice is side effect free if it is a side effect free
3256             --  prefixed reference and the bounds are side effect free.
3257
3258             when N_Slice =>
3259                return Side_Effect_Free (Discrete_Range (N))
3260                  and then Safe_Prefixed_Reference (N);
3261
3262             --  A type conversion is side effect free if the expression
3263             --  to be converted is side effect free.
3264
3265             when N_Type_Conversion =>
3266                return Side_Effect_Free (Expression (N));
3267
3268             --  A unary operator is side effect free if the operand
3269             --  is side effect free.
3270
3271             when N_Unary_Op =>
3272                return Side_Effect_Free (Right_Opnd (N));
3273
3274             --  An unchecked type conversion is side effect free only if it
3275             --  is safe and its argument is side effect free.
3276
3277             when N_Unchecked_Type_Conversion =>
3278                return Safe_Unchecked_Type_Conversion (N)
3279                  and then Side_Effect_Free (Expression (N));
3280
3281             --  An unchecked expression is side effect free if its expression
3282             --  is side effect free.
3283
3284             when N_Unchecked_Expression =>
3285                return Side_Effect_Free (Expression (N));
3286
3287             --  We consider that anything else has side effects. This is a bit
3288             --  crude, but we are pretty close for most common cases, and we
3289             --  are certainly correct (i.e. we never return True when the
3290             --  answer should be False).
3291
3292             when others =>
3293                return False;
3294          end case;
3295       end Side_Effect_Free;
3296
3297       --  A list is side effect free if all elements of the list are
3298       --  side effect free.
3299
3300       function Side_Effect_Free (L : List_Id) return Boolean is
3301          N : Node_Id;
3302
3303       begin
3304          if L = No_List or else L = Error_List then
3305             return True;
3306
3307          else
3308             N := First (L);
3309
3310             while Present (N) loop
3311                if not Side_Effect_Free (N) then
3312                   return False;
3313                else
3314                   Next (N);
3315                end if;
3316             end loop;
3317
3318             return True;
3319          end if;
3320       end Side_Effect_Free;
3321
3322       -------------------------
3323       -- Within_In_Parameter --
3324       -------------------------
3325
3326       function Within_In_Parameter (N : Node_Id) return Boolean is
3327       begin
3328          if not Comes_From_Source (N) then
3329             return False;
3330
3331          elsif Is_Entity_Name (N) then
3332             return
3333               Ekind (Entity (N)) = E_In_Parameter;
3334
3335          elsif Nkind (N) = N_Indexed_Component
3336            or else Nkind (N) = N_Selected_Component
3337          then
3338             return Within_In_Parameter (Prefix (N));
3339          else
3340
3341             return False;
3342          end if;
3343       end Within_In_Parameter;
3344
3345    --  Start of processing for Remove_Side_Effects
3346
3347    begin
3348       --  If we are side effect free already or expansion is disabled,
3349       --  there is nothing to do.
3350
3351       if Side_Effect_Free (Exp) or else not Expander_Active then
3352          return;
3353       end if;
3354
3355       --  All this must not have any checks
3356
3357       Scope_Suppress := (others => True);
3358
3359       --  If the expression has the form v.all then we can just capture
3360       --  the pointer, and then do an explicit dereference on the result.
3361
3362       if Nkind (Exp) = N_Explicit_Dereference then
3363          Def_Id :=
3364            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3365          Res :=
3366            Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
3367
3368          Insert_Action (Exp,
3369            Make_Object_Declaration (Loc,
3370              Defining_Identifier => Def_Id,
3371              Object_Definition   =>
3372                New_Reference_To (Etype (Prefix (Exp)), Loc),
3373              Constant_Present    => True,
3374              Expression          => Relocate_Node (Prefix (Exp))));
3375
3376       --  Similar processing for an unchecked conversion of an expression
3377       --  of the form v.all, where we want the same kind of treatment.
3378
3379       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
3380         and then Nkind (Expression (Exp)) = N_Explicit_Dereference
3381       then
3382          Remove_Side_Effects (Expression (Exp), Variable_Ref);
3383          Scope_Suppress := Svg_Suppress;
3384          return;
3385
3386       --  If this is a type conversion, leave the type conversion and remove
3387       --  the side effects in the expression. This is important in several
3388       --  circumstances: for change of representations, and also when this
3389       --  is a view conversion to a smaller object, where gigi can end up
3390       --  its own temporary of the wrong size.
3391
3392       --  ??? this transformation is inhibited for elementary types that are
3393       --  not involved in a change of representation because it causes
3394       --  regressions that are not fully understood yet.
3395
3396       elsif Nkind (Exp) = N_Type_Conversion
3397         and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
3398                    or else Nkind (Parent (Exp)) = N_Assignment_Statement)
3399       then
3400          Remove_Side_Effects (Expression (Exp), Variable_Ref);
3401          Scope_Suppress := Svg_Suppress;
3402          return;
3403
3404       --  For expressions that denote objects, we can use a renaming scheme.
3405       --  We skip using this if we have a volatile variable and we do not
3406       --  have Nam_Req set true (see comments above for Side_Effect_Free).
3407       --  We also skip this scheme for class-wide expressions in order to
3408       --  avoid recursive expansion (see Expand_N_Object_Renaming_Declaration)
3409       --  If the object is a function call, we need to create a temporary and
3410       --  not a renaming.
3411
3412       --  Note that we could use ordinary object declarations in the case of
3413       --  expressions not appearing as lvalues. That is left as a possible
3414       --  optimization in the future but we prefer to generate renamings
3415       --  right now, since we may indeed be transforming an lvalue.
3416
3417       elsif Is_Object_Reference (Exp)
3418         and then Nkind (Exp) /= N_Function_Call
3419         and then not Variable_Ref
3420         and then (Name_Req
3421                    or else not Is_Entity_Name (Exp)
3422                    or else not Treat_As_Volatile (Entity (Exp)))
3423         and then not Is_Class_Wide_Type (Exp_Type)
3424       then
3425          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3426
3427          if Nkind (Exp) = N_Selected_Component
3428            and then Nkind (Prefix (Exp)) = N_Function_Call
3429            and then Is_Array_Type (Etype (Exp))
3430          then
3431             --  Avoid generating a variable-sized temporary, by generating
3432             --  the renaming declaration just for the function call. The
3433             --  transformation could be refined to apply only when the array
3434             --  component is constrained by a discriminant???
3435
3436             Res :=
3437               Make_Selected_Component (Loc,
3438                 Prefix => New_Occurrence_Of (Def_Id, Loc),
3439                 Selector_Name => Selector_Name (Exp));
3440
3441             Insert_Action (Exp,
3442               Make_Object_Renaming_Declaration (Loc,
3443                 Defining_Identifier => Def_Id,
3444                 Subtype_Mark        =>
3445                   New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
3446                 Name                => Relocate_Node (Prefix (Exp))));
3447
3448             --  The temporary must be elaborated by gigi, and is of course
3449             --  not to be replaced in-line by the expression it renames,
3450             --  which would defeat the purpose of removing the side-effect.
3451
3452             Set_Is_Renaming_Of_Object (Def_Id, False);
3453
3454          else
3455             Res := New_Reference_To (Def_Id, Loc);
3456
3457             Insert_Action (Exp,
3458               Make_Object_Renaming_Declaration (Loc,
3459                 Defining_Identifier => Def_Id,
3460                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
3461                 Name                => Relocate_Node (Exp)));
3462
3463             Set_Is_Renaming_Of_Object (Def_Id, False);
3464          end if;
3465
3466       --  If it is a scalar type, just make a copy.
3467
3468       elsif Is_Elementary_Type (Exp_Type) then
3469          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3470          Set_Etype (Def_Id, Exp_Type);
3471          Res := New_Reference_To (Def_Id, Loc);
3472
3473          E :=
3474            Make_Object_Declaration (Loc,
3475              Defining_Identifier => Def_Id,
3476              Object_Definition   => New_Reference_To (Exp_Type, Loc),
3477              Constant_Present    => True,
3478              Expression          => Relocate_Node (Exp));
3479
3480          Set_Assignment_OK (E);
3481          Insert_Action (Exp, E);
3482
3483       --  Always use a renaming for an unchecked conversion
3484       --  If this is an unchecked conversion that Gigi can't handle, make
3485       --  a copy or a use a renaming to capture the value.
3486
3487       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
3488         and then not Safe_Unchecked_Type_Conversion (Exp)
3489       then
3490          if Controlled_Type (Etype (Exp)) then
3491
3492             --  Use a renaming to capture the expression, rather than create
3493             --  a controlled temporary.
3494
3495             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3496             Res := New_Reference_To (Def_Id, Loc);
3497
3498             Insert_Action (Exp,
3499               Make_Object_Renaming_Declaration (Loc,
3500                 Defining_Identifier => Def_Id,
3501                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
3502                 Name                => Relocate_Node (Exp)));
3503
3504          else
3505             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3506             Set_Etype (Def_Id, Exp_Type);
3507             Res := New_Reference_To (Def_Id, Loc);
3508
3509             E :=
3510               Make_Object_Declaration (Loc,
3511                 Defining_Identifier => Def_Id,
3512                 Object_Definition   => New_Reference_To (Exp_Type, Loc),
3513                 Constant_Present    => not Is_Variable (Exp),
3514                 Expression          => Relocate_Node (Exp));
3515
3516             Set_Assignment_OK (E);
3517             Insert_Action (Exp, E);
3518          end if;
3519
3520       --  Otherwise we generate a reference to the value
3521
3522       else
3523          Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
3524
3525          Ptr_Typ_Decl :=
3526            Make_Full_Type_Declaration (Loc,
3527              Defining_Identifier => Ref_Type,
3528              Type_Definition =>
3529                Make_Access_To_Object_Definition (Loc,
3530                  All_Present => True,
3531                  Subtype_Indication =>
3532                    New_Reference_To (Exp_Type, Loc)));
3533
3534          E := Exp;
3535          Insert_Action (Exp, Ptr_Typ_Decl);
3536
3537          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3538          Set_Etype (Def_Id, Exp_Type);
3539
3540          Res :=
3541            Make_Explicit_Dereference (Loc,
3542              Prefix => New_Reference_To (Def_Id, Loc));
3543
3544          if Nkind (E) = N_Explicit_Dereference then
3545             New_Exp := Relocate_Node (Prefix (E));
3546          else
3547             E := Relocate_Node (E);
3548             New_Exp := Make_Reference (Loc, E);
3549          end if;
3550
3551          if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then
3552             Set_Expansion_Delayed (E, False);
3553             Set_Analyzed (E, False);
3554          end if;
3555
3556          Insert_Action (Exp,
3557            Make_Object_Declaration (Loc,
3558              Defining_Identifier => Def_Id,
3559              Object_Definition   => New_Reference_To (Ref_Type, Loc),
3560              Expression          => New_Exp));
3561       end if;
3562
3563       --  Preserve the Assignment_OK flag in all copies, since at least
3564       --  one copy may be used in a context where this flag must be set
3565       --  (otherwise why would the flag be set in the first place).
3566
3567       Set_Assignment_OK (Res, Assignment_OK (Exp));
3568
3569       --  Finally rewrite the original expression and we are done
3570
3571       Rewrite (Exp, Res);
3572       Analyze_And_Resolve (Exp, Exp_Type);
3573       Scope_Suppress := Svg_Suppress;
3574    end Remove_Side_Effects;
3575
3576    ------------------------------------
3577    -- Safe_Unchecked_Type_Conversion --
3578    ------------------------------------
3579
3580    --  Note: this function knows quite a bit about the exact requirements
3581    --  of Gigi with respect to unchecked type conversions, and its code
3582    --  must be coordinated with any changes in Gigi in this area.
3583
3584    --  The above requirements should be documented in Sinfo ???
3585
3586    function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
3587       Otyp   : Entity_Id;
3588       Ityp   : Entity_Id;
3589       Oalign : Uint;
3590       Ialign : Uint;
3591       Pexp   : constant Node_Id := Parent (Exp);
3592
3593    begin
3594       --  If the expression is the RHS of an assignment or object declaration
3595       --   we are always OK because there will always be a target.
3596
3597       --  Object renaming declarations, (generated for view conversions of
3598       --  actuals in inlined calls), like object declarations, provide an
3599       --  explicit type, and are safe as well.
3600
3601       if (Nkind (Pexp) = N_Assignment_Statement
3602            and then Expression (Pexp) = Exp)
3603         or else Nkind (Pexp) = N_Object_Declaration
3604         or else Nkind (Pexp) = N_Object_Renaming_Declaration
3605       then
3606          return True;
3607
3608       --  If the expression is the prefix of an N_Selected_Component
3609       --  we should also be OK because GCC knows to look inside the
3610       --  conversion except if the type is discriminated. We assume
3611       --  that we are OK anyway if the type is not set yet or if it is
3612       --  controlled since we can't afford to introduce a temporary in
3613       --  this case.
3614
3615       elsif Nkind (Pexp) = N_Selected_Component
3616          and then Prefix (Pexp) = Exp
3617       then
3618          if No (Etype (Pexp)) then
3619             return True;
3620          else
3621             return
3622               not Has_Discriminants (Etype (Pexp))
3623                 or else Is_Constrained (Etype (Pexp));
3624          end if;
3625       end if;
3626
3627       --  Set the output type, this comes from Etype if it is set, otherwise
3628       --  we take it from the subtype mark, which we assume was already
3629       --  fully analyzed.
3630
3631       if Present (Etype (Exp)) then
3632          Otyp := Etype (Exp);
3633       else
3634          Otyp := Entity (Subtype_Mark (Exp));
3635       end if;
3636
3637       --  The input type always comes from the expression, and we assume
3638       --  this is indeed always analyzed, so we can simply get the Etype.
3639
3640       Ityp := Etype (Expression (Exp));
3641
3642       --  Initialize alignments to unknown so far
3643
3644       Oalign := No_Uint;
3645       Ialign := No_Uint;
3646
3647       --  Replace a concurrent type by its corresponding record type
3648       --  and each type by its underlying type and do the tests on those.
3649       --  The original type may be a private type whose completion is a
3650       --  concurrent type, so find the underlying type first.
3651
3652       if Present (Underlying_Type (Otyp)) then
3653          Otyp := Underlying_Type (Otyp);
3654       end if;
3655
3656       if Present (Underlying_Type (Ityp)) then
3657          Ityp := Underlying_Type (Ityp);
3658       end if;
3659
3660       if Is_Concurrent_Type (Otyp) then
3661          Otyp := Corresponding_Record_Type (Otyp);
3662       end if;
3663
3664       if Is_Concurrent_Type (Ityp) then
3665          Ityp := Corresponding_Record_Type (Ityp);
3666       end if;
3667
3668       --  If the base types are the same, we know there is no problem since
3669       --  this conversion will be a noop.
3670
3671       if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
3672          return True;
3673
3674       --  If the size of output type is known at compile time, there is
3675       --  never a problem.  Note that unconstrained records are considered
3676       --  to be of known size, but we can't consider them that way here,
3677       --  because we are talking about the actual size of the object.
3678
3679       --  We also make sure that in addition to the size being known, we do
3680       --  not have a case which might generate an embarrassingly large temp
3681       --  in stack checking mode.
3682
3683       elsif Size_Known_At_Compile_Time (Otyp)
3684         and then not May_Generate_Large_Temp (Otyp)
3685         and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
3686       then
3687          return True;
3688
3689       --  If either type is tagged, then we know the alignment is OK so
3690       --  Gigi will be able to use pointer punning.
3691
3692       elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
3693          return True;
3694
3695       --  If either type is a limited record type, we cannot do a copy, so
3696       --  say safe since there's nothing else we can do.
3697
3698       elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
3699          return True;
3700
3701       --  Conversions to and from packed array types are always ignored and
3702       --  hence are safe.
3703
3704       elsif Is_Packed_Array_Type (Otyp)
3705         or else Is_Packed_Array_Type (Ityp)
3706       then
3707          return True;
3708       end if;
3709
3710       --  The only other cases known to be safe is if the input type's
3711       --  alignment is known to be at least the maximum alignment for the
3712       --  target or if both alignments are known and the output type's
3713       --  alignment is no stricter than the input's.  We can use the alignment
3714       --  of the component type of an array if a type is an unpacked
3715       --  array type.
3716
3717       if Present (Alignment_Clause (Otyp)) then
3718          Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
3719
3720       elsif Is_Array_Type (Otyp)
3721         and then Present (Alignment_Clause (Component_Type (Otyp)))
3722       then
3723          Oalign := Expr_Value (Expression (Alignment_Clause
3724                                            (Component_Type (Otyp))));
3725       end if;
3726
3727       if Present (Alignment_Clause (Ityp)) then
3728          Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
3729
3730       elsif Is_Array_Type (Ityp)
3731         and then Present (Alignment_Clause (Component_Type (Ityp)))
3732       then
3733          Ialign := Expr_Value (Expression (Alignment_Clause
3734                                            (Component_Type (Ityp))));
3735       end if;
3736
3737       if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
3738          return True;
3739
3740       elsif Ialign /= No_Uint and then Oalign /= No_Uint
3741         and then Ialign <= Oalign
3742       then
3743          return True;
3744
3745       --   Otherwise, Gigi cannot handle this and we must make a temporary.
3746
3747       else
3748          return False;
3749       end if;
3750
3751    end Safe_Unchecked_Type_Conversion;
3752
3753    --------------------------
3754    -- Set_Elaboration_Flag --
3755    --------------------------
3756
3757    procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
3758       Loc : constant Source_Ptr := Sloc (N);
3759       Ent : constant Entity_Id  := Elaboration_Entity (Spec_Id);
3760       Asn : Node_Id;
3761
3762    begin
3763       if Present (Ent) then
3764
3765          --  Nothing to do if at the compilation unit level, because in this
3766          --  case the flag is set by the binder generated elaboration routine.
3767
3768          if Nkind (Parent (N)) = N_Compilation_Unit then
3769             null;
3770
3771          --  Here we do need to generate an assignment statement
3772
3773          else
3774             Check_Restriction (No_Elaboration_Code, N);
3775             Asn :=
3776               Make_Assignment_Statement (Loc,
3777                 Name       => New_Occurrence_Of (Ent, Loc),
3778                 Expression => New_Occurrence_Of (Standard_True, Loc));
3779
3780             if Nkind (Parent (N)) = N_Subunit then
3781                Insert_After (Corresponding_Stub (Parent (N)), Asn);
3782             else
3783                Insert_After (N, Asn);
3784             end if;
3785
3786             Analyze (Asn);
3787
3788             --  Kill current value indication. This is necessary because
3789             --  the tests of this flag are inserted out of sequence and must
3790             --  not pick up bogus indications of the wrong constant value.
3791
3792             Set_Current_Value (Ent, Empty);
3793          end if;
3794       end if;
3795    end Set_Elaboration_Flag;
3796
3797    --------------------------
3798    -- Target_Has_Fixed_Ops --
3799    --------------------------
3800
3801    Integer_Sized_Small : Ureal;
3802    --  Set to 2.0 ** -(Integer'Size - 1) the first time that this
3803    --  function is called (we don't want to compute it more than once!)
3804
3805    Long_Integer_Sized_Small : Ureal;
3806    --  Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
3807    --  functoin is called (we don't want to compute it more than once)
3808
3809    First_Time_For_THFO : Boolean := True;
3810    --  Set to False after first call (if Fractional_Fixed_Ops_On_Target)
3811
3812    function Target_Has_Fixed_Ops
3813      (Left_Typ   : Entity_Id;
3814       Right_Typ  : Entity_Id;
3815       Result_Typ : Entity_Id)
3816       return       Boolean
3817    is
3818       function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
3819       --  Return True if the given type is a fixed-point type with a small
3820       --  value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
3821       --  an absolute value less than 1.0. This is currently limited
3822       --  to fixed-point types that map to Integer or Long_Integer.
3823
3824       ------------------------
3825       -- Is_Fractional_Type --
3826       ------------------------
3827
3828       function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
3829       begin
3830          if Esize (Typ) = Standard_Integer_Size then
3831             return Small_Value (Typ) = Integer_Sized_Small;
3832
3833          elsif Esize (Typ) = Standard_Long_Integer_Size then
3834             return Small_Value (Typ) = Long_Integer_Sized_Small;
3835
3836          else
3837             return False;
3838          end if;
3839       end Is_Fractional_Type;
3840
3841    --  Start of processing for Target_Has_Fixed_Ops
3842
3843    begin
3844       --  Return False if Fractional_Fixed_Ops_On_Target is false
3845
3846       if not Fractional_Fixed_Ops_On_Target then
3847          return False;
3848       end if;
3849
3850       --  Here the target has Fractional_Fixed_Ops, if first time, compute
3851       --  standard constants used by Is_Fractional_Type.
3852
3853       if First_Time_For_THFO then
3854          First_Time_For_THFO := False;
3855
3856          Integer_Sized_Small :=
3857            UR_From_Components
3858              (Num   => Uint_1,
3859               Den   => UI_From_Int (Standard_Integer_Size - 1),
3860               Rbase => 2);
3861
3862          Long_Integer_Sized_Small :=
3863            UR_From_Components
3864              (Num   => Uint_1,
3865               Den   => UI_From_Int (Standard_Long_Integer_Size - 1),
3866               Rbase => 2);
3867       end if;
3868
3869       --  Return True if target supports fixed-by-fixed multiply/divide
3870       --  for fractional fixed-point types (see Is_Fractional_Type) and
3871       --  the operand and result types are equivalent fractional types.
3872
3873       return Is_Fractional_Type (Base_Type (Left_Typ))
3874         and then Is_Fractional_Type (Base_Type (Right_Typ))
3875         and then Is_Fractional_Type (Base_Type (Result_Typ))
3876         and then Esize (Left_Typ) = Esize (Right_Typ)
3877         and then Esize (Left_Typ) = Esize (Result_Typ);
3878    end Target_Has_Fixed_Ops;
3879
3880    ----------------------------
3881    -- Wrap_Cleanup_Procedure --
3882    ----------------------------
3883
3884    procedure Wrap_Cleanup_Procedure (N : Node_Id) is
3885       Loc   : constant Source_Ptr := Sloc (N);
3886       Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
3887       Stmts : constant List_Id    := Statements (Stseq);
3888
3889    begin
3890       if Abort_Allowed then
3891          Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
3892          Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
3893       end if;
3894    end Wrap_Cleanup_Procedure;
3895
3896 end Exp_Util;