gcc/ada/exp_util.adb

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