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