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