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-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Exp_Aggr; use Exp_Aggr;
  34 with Exp_Ch7;  use Exp_Ch7;
  35 with Inline;   use Inline;
  36 with Itypes;   use Itypes;
  37 with Lib;      use Lib;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Restrict; use Restrict;
  42 with Rident;   use Rident;
  43 with Sem;      use Sem;
  44 with Sem_Ch8;  use Sem_Ch8;
  45 with Sem_Eval; use Sem_Eval;
  46 with Sem_Res;  use Sem_Res;
  47 with Sem_Type; use Sem_Type;
  48 with Sem_Util; use Sem_Util;
  49 with Snames;   use Snames;
  50 with Stand;    use Stand;
  51 with Stringt;  use Stringt;
  52 with Targparm; use Targparm;
  53 with Tbuild;   use Tbuild;
  54 with Ttypes;   use Ttypes;
  55 with Uintp;    use Uintp;
  56 with Urealp;   use Urealp;
  57 with Validsw;  use Validsw;
  58
  59 package body Exp_Util is
  60
  61    -----------------------
  62    -- Local Subprograms --
  63    -----------------------
  64
  65    function Build_Task_Array_Image
  66      (Loc    : Source_Ptr;
  67       Id_Ref : Node_Id;
  68       A_Type : Entity_Id;
  69       Dyn    : Boolean := False) return Node_Id;
  70    --  Build function to generate the image string for a task that is an
  71    --  array component, concatenating the images of each index. To avoid
  72    --  storage leaks, the string is built with successive slice assignments.
  73    --  The flag Dyn indicates whether this is called for the initialization
  74    --  procedure of an array of tasks, or for the name of a dynamically
  75    --  created task that is assigned to an indexed component.
  76
  77    function Build_Task_Image_Function
  78      (Loc   : Source_Ptr;
  79       Decls : List_Id;
  80       Stats : List_Id;
  81       Res   : Entity_Id) return Node_Id;
  82    --  Common processing for Task_Array_Image and Task_Record_Image.
  83    --  Build function body that computes image.
  84
  85    procedure Build_Task_Image_Prefix
  86       (Loc    : Source_Ptr;
  87        Len    : out Entity_Id;
  88        Res    : out Entity_Id;
  89        Pos    : out Entity_Id;
  90        Prefix : Entity_Id;
  91        Sum    : Node_Id;
  92        Decls  : in out List_Id;
  93        Stats  : in out List_Id);
  94    --  Common processing for Task_Array_Image and Task_Record_Image.
  95    --  Create local variables and assign prefix of name to result string.
  96
  97    function Build_Task_Record_Image
  98      (Loc    : Source_Ptr;
  99       Id_Ref : Node_Id;
 100       Dyn    : Boolean := False) return Node_Id;
 101    --  Build function to generate the image string for a task that is a
 102    --  record component. Concatenate name of variable with that of selector.
 103    --  The flag Dyn indicates whether this is called for the initialization
 104    --  procedure of record with task components, or for a dynamically
 105    --  created task that is assigned to a selected component.
 106
 107    function Make_CW_Equivalent_Type
 108      (T : Entity_Id;
 109       E : Node_Id) return Entity_Id;
 110    --  T is a class-wide type entity, E is the initial expression node that
 111    --  constrains T in case such as: " X: T := E" or "new T'(E)"
 112    --  This function returns the entity of the Equivalent type and inserts
 113    --  on the fly the necessary declaration such as:
 114    --
 115    --    type anon is record
 116    --       _parent : Root_Type (T); constrained with E discriminants (if any)
 117    --       Extension : String (1 .. expr to match size of E);
 118    --    end record;
 119    --
 120    --  This record is compatible with any object of the class of T thanks
 121    --  to the first field and has the same size as E thanks to the second.
 122
 123    function Make_Literal_Range
 124      (Loc         : Source_Ptr;
 125       Literal_Typ : Entity_Id) return Node_Id;
 126    --  Produce a Range node whose bounds are:
 127    --    Low_Bound (Literal_Type) ..
 128    --        Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
 129    --  this is used for expanding declarations like X : String := "sdfgdfg";
 130
 131    function New_Class_Wide_Subtype
 132      (CW_Typ : Entity_Id;
 133       N      : Node_Id) return Entity_Id;
 134    --  Create an implicit subtype of CW_Typ attached to node N
 135
 136    ----------------------
 137    -- Adjust_Condition --
 138    ----------------------
 139
 140    procedure Adjust_Condition (N : Node_Id) is
 141    begin
 142       if No (N) then
 143          return;
 144       end if;
 145
 146       declare
 147          Loc : constant Source_Ptr := Sloc (N);
 148          T   : constant Entity_Id  := Etype (N);
 149          Ti  : Entity_Id;
 150
 151       begin
 152          --  For now, we simply ignore a call where the argument has no
 153          --  type (probably case of unanalyzed condition), or has a type
 154          --  that is not Boolean. This is because this is a pretty marginal
 155          --  piece of functionality, and violations of these rules are
 156          --  likely to be truly marginal (how much code uses Fortran Logical
 157          --  as the barrier to a protected entry?) and we do not want to
 158          --  blow up existing programs. We can change this to an assertion
 159          --  after 3.12a is released ???
 160
 161          if No (T) or else not Is_Boolean_Type (T) then
 162             return;
 163          end if;
 164
 165          --  Apply validity checking if needed
 166
 167          if Validity_Checks_On and Validity_Check_Tests then
 168             Ensure_Valid (N);
 169          end if;
 170
 171          --  Immediate return if standard boolean, the most common case,
 172          --  where nothing needs to be done.
 173
 174          if Base_Type (T) = Standard_Boolean then
 175             return;
 176          end if;
 177
 178          --  Case of zero/non-zero semantics or non-standard enumeration
 179          --  representation. In each case, we rewrite the node as:
 180
 181          --      ityp!(N) /= False'Enum_Rep
 182
 183          --  where ityp is an integer type with large enough size to hold
 184          --  any value of type T.
 185
 186          if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
 187             if Esize (T) <= Esize (Standard_Integer) then
 188                Ti := Standard_Integer;
 189             else
 190                Ti := Standard_Long_Long_Integer;
 191             end if;
 192
 193             Rewrite (N,
 194               Make_Op_Ne (Loc,
 195                 Left_Opnd  => Unchecked_Convert_To (Ti, N),
 196                 Right_Opnd =>
 197                   Make_Attribute_Reference (Loc,
 198                     Attribute_Name => Name_Enum_Rep,
 199                     Prefix         =>
 200                       New_Occurrence_Of (First_Literal (T), Loc))));
 201             Analyze_And_Resolve (N, Standard_Boolean);
 202
 203          else
 204             Rewrite (N, Convert_To (Standard_Boolean, N));
 205             Analyze_And_Resolve (N, Standard_Boolean);
 206          end if;
 207       end;
 208    end Adjust_Condition;
 209
 210    ------------------------
 211    -- Adjust_Result_Type --
 212    ------------------------
 213
 214    procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
 215    begin
 216       --  Ignore call if current type is not Standard.Boolean
 217
 218       if Etype (N) /= Standard_Boolean then
 219          return;
 220       end if;
 221
 222       --  If result is already of correct type, nothing to do. Note that
 223       --  this will get the most common case where everything has a type
 224       --  of Standard.Boolean.
 225
 226       if Base_Type (T) = Standard_Boolean then
 227          return;
 228
 229       else
 230          declare
 231             KP : constant Node_Kind := Nkind (Parent (N));
 232
 233          begin
 234             --  If result is to be used as a Condition in the syntax, no need
 235             --  to convert it back, since if it was changed to Standard.Boolean
 236             --  using Adjust_Condition, that is just fine for this usage.
 237
 238             if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
 239                return;
 240
 241             --  If result is an operand of another logical operation, no need
 242             --  to reset its type, since Standard.Boolean is just fine, and
 243             --  such operations always do Adjust_Condition on their operands.
 244
 245             elsif KP in N_Op_Boolean
 246               or else KP = N_And_Then
 247               or else KP = N_Or_Else
 248               or else KP = N_Op_Not
 249             then
 250                return;
 251
 252             --  Otherwise we perform a conversion from the current type,
 253             --  which must be Standard.Boolean, to the desired type.
 254
 255             else
 256                Set_Analyzed (N);
 257                Rewrite (N, Convert_To (T, N));
 258                Analyze_And_Resolve (N, T);
 259             end if;
 260          end;
 261       end if;
 262    end Adjust_Result_Type;
 263
 264    --------------------------
 265    -- Append_Freeze_Action --
 266    --------------------------
 267
 268    procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
 269       Fnode : Node_Id;
 270
 271    begin
 272       Ensure_Freeze_Node (T);
 273       Fnode := Freeze_Node (T);
 274
 275       if No (Actions (Fnode)) then
 276          Set_Actions (Fnode, New_List);
 277       end if;
 278
 279       Append (N, Actions (Fnode));
 280    end Append_Freeze_Action;
 281
 282    ---------------------------
 283    -- Append_Freeze_Actions --
 284    ---------------------------
 285
 286    procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
 287       Fnode : constant Node_Id := Freeze_Node (T);
 288
 289    begin
 290       if No (L) then
 291          return;
 292
 293       else
 294          if No (Actions (Fnode)) then
 295             Set_Actions (Fnode, L);
 296
 297          else
 298             Append_List (L, Actions (Fnode));
 299          end if;
 300
 301       end if;
 302    end Append_Freeze_Actions;
 303
 304    ------------------------
 305    -- Build_Runtime_Call --
 306    ------------------------
 307
 308    function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
 309    begin
 310       --  If entity is not available, we can skip making the call (this avoids
 311       --  junk duplicated error messages in a number of cases).
 312
 313       if not RTE_Available (RE) then
 314          return Make_Null_Statement (Loc);
 315       else
 316          return
 317            Make_Procedure_Call_Statement (Loc,
 318              Name => New_Reference_To (RTE (RE), Loc));
 319       end if;
 320    end Build_Runtime_Call;
 321
 322    ----------------------------
 323    -- Build_Task_Array_Image --
 324    ----------------------------
 325
 326    --  This function generates the body for a function that constructs the
 327    --  image string for a task that is an array component. The function is
 328    --  local to the init proc for the array type, and is called for each one
 329    --  of the components. The constructed image has the form of an indexed
 330    --  component, whose prefix is the outer variable of the array type.
 331    --  The n-dimensional array type has known indices Index, Index2...
 332    --  Id_Ref is an indexed component form created by the enclosing init proc.
 333    --  Its successive indices are Val1, Val2,.. which are the loop variables
 334    --  in the loops that call the individual task init proc on each component.
 335
 336    --  The generated function has the following structure:
 337
 338    --  function F return String is
 339    --     Pref : string renames Task_Name;
 340    --     T1   : String := Index1'Image (Val1);
 341    --     ...
 342    --     Tn   : String := indexn'image (Valn);
 343    --     Len  : Integer := T1'Length + ... + Tn'Length + n + 1;
 344    --     --  Len includes commas and the end parentheses.
 345    --     Res  : String (1..Len);
 346    --     Pos  : Integer := Pref'Length;
 347    --
 348    --  begin
 349    --     Res (1 .. Pos) := Pref;
 350    --     Pos := Pos + 1;
 351    --     Res (Pos)    := '(';
 352    --     Pos := Pos + 1;
 353    --     Res (Pos .. Pos + T1'Length - 1) := T1;
 354    --     Pos := Pos + T1'Length;
 355    --     Res (Pos) := '.';
 356    --     Pos := Pos + 1;
 357    --     ...
 358    --     Res (Pos .. Pos + Tn'Length - 1) := Tn;
 359    --     Res (Len) := ')';
 360    --
 361    --     return Res;
 362    --  end F;
 363    --
 364    --  Needless to say, multidimensional arrays of tasks are rare enough
 365    --  that the bulkiness of this code is not really a concern.
 366
 367    function Build_Task_Array_Image
 368      (Loc    : Source_Ptr;
 369       Id_Ref : Node_Id;
 370       A_Type : Entity_Id;
 371       Dyn    : Boolean := False) return Node_Id
 372    is
 373       Dims : constant Nat := Number_Dimensions (A_Type);
 374       --  Number of dimensions for array of tasks
 375
 376       Temps : array (1 .. Dims) of Entity_Id;
 377       --  Array of temporaries to hold string for each index
 378
 379       Indx : Node_Id;
 380       --  Index expression
 381
 382       Len : Entity_Id;
 383       --  Total length of generated name
 384
 385       Pos : Entity_Id;
 386       --  Running index for substring assignments
 387
 388       Pref : Entity_Id;
 389       --  Name of enclosing variable, prefix of resulting name
 390
 391       Res : Entity_Id;
 392       --  String to hold result
 393
 394       Val : Node_Id;
 395       --  Value of successive indices
 396
 397       Sum : Node_Id;
 398       --  Expression to compute total size of string
 399
 400       T : Entity_Id;
 401       --  Entity for name at one index position
 402
 403       Decls : List_Id := New_List;
 404       Stats : List_Id := New_List;
 405
 406    begin
 407       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 408
 409       --  For a dynamic task, the name comes from the target variable.
 410       --  For a static one it is a formal of the enclosing init proc.
 411
 412       if Dyn then
 413          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 414          Append_To (Decls,
 415            Make_Object_Declaration (Loc,
 416              Defining_Identifier => Pref,
 417              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 418              Expression =>
 419                Make_String_Literal (Loc,
 420                  Strval => String_From_Name_Buffer)));
 421
 422       else
 423          Append_To (Decls,
 424            Make_Object_Renaming_Declaration (Loc,
 425              Defining_Identifier => Pref,
 426              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 427              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 428       end if;
 429
 430       Indx := First_Index (A_Type);
 431       Val  := First (Expressions (Id_Ref));
 432
 433       for J in 1 .. Dims loop
 434          T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
 435          Temps (J) := T;
 436
 437          Append_To (Decls,
 438             Make_Object_Declaration (Loc,
 439                Defining_Identifier => T,
 440                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 441                Expression =>
 442                  Make_Attribute_Reference (Loc,
 443                    Attribute_Name => Name_Image,
 444                    Prefix =>
 445                      New_Occurrence_Of (Etype (Indx), Loc),
 446                    Expressions => New_List (
 447                      New_Copy_Tree (Val)))));
 448
 449          Next_Index (Indx);
 450          Next (Val);
 451       end loop;
 452
 453       Sum := Make_Integer_Literal (Loc, Dims + 1);
 454
 455       Sum :=
 456         Make_Op_Add (Loc,
 457           Left_Opnd => Sum,
 458           Right_Opnd =>
 459            Make_Attribute_Reference (Loc,
 460              Attribute_Name => Name_Length,
 461              Prefix =>
 462                New_Occurrence_Of (Pref, Loc),
 463              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 464
 465       for J in 1 .. Dims loop
 466          Sum :=
 467             Make_Op_Add (Loc,
 468              Left_Opnd => Sum,
 469              Right_Opnd =>
 470               Make_Attribute_Reference (Loc,
 471                 Attribute_Name => Name_Length,
 472                 Prefix =>
 473                   New_Occurrence_Of (Temps (J), Loc),
 474                 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 475       end loop;
 476
 477       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
 478
 479       Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
 480
 481       Append_To (Stats,
 482          Make_Assignment_Statement (Loc,
 483            Name => Make_Indexed_Component (Loc,
 484               Prefix => New_Occurrence_Of (Res, Loc),
 485               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 486            Expression =>
 487              Make_Character_Literal (Loc,
 488                Chars => Name_Find,
 489                Char_Literal_Value =>
 490                  UI_From_Int (Character'Pos ('(')))));
 491
 492       Append_To (Stats,
 493          Make_Assignment_Statement (Loc,
 494             Name => New_Occurrence_Of (Pos, Loc),
 495             Expression =>
 496               Make_Op_Add (Loc,
 497                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
 498                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
 499
 500       for J in 1 .. Dims loop
 501
 502          Append_To (Stats,
 503             Make_Assignment_Statement (Loc,
 504               Name => Make_Slice (Loc,
 505                  Prefix => New_Occurrence_Of (Res, Loc),
 506                  Discrete_Range  =>
 507                    Make_Range (Loc,
 508                       Low_Bound => New_Occurrence_Of  (Pos, Loc),
 509                       High_Bound => Make_Op_Subtract (Loc,
 510                         Left_Opnd =>
 511                           Make_Op_Add (Loc,
 512                             Left_Opnd => New_Occurrence_Of (Pos, Loc),
 513                             Right_Opnd =>
 514                               Make_Attribute_Reference (Loc,
 515                                 Attribute_Name => Name_Length,
 516                                 Prefix =>
 517                                   New_Occurrence_Of (Temps (J), Loc),
 518                                 Expressions =>
 519                                   New_List (Make_Integer_Literal (Loc, 1)))),
 520                          Right_Opnd => Make_Integer_Literal (Loc, 1)))),
 521
 522               Expression => New_Occurrence_Of (Temps (J), Loc)));
 523
 524          if J < Dims then
 525             Append_To (Stats,
 526                Make_Assignment_Statement (Loc,
 527                   Name => New_Occurrence_Of (Pos, Loc),
 528                   Expression =>
 529                     Make_Op_Add (Loc,
 530                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
 531                       Right_Opnd =>
 532                         Make_Attribute_Reference (Loc,
 533                           Attribute_Name => Name_Length,
 534                             Prefix => New_Occurrence_Of (Temps (J), Loc),
 535                             Expressions =>
 536                               New_List (Make_Integer_Literal (Loc, 1))))));
 537
 538             Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
 539
 540             Append_To (Stats,
 541                Make_Assignment_Statement (Loc,
 542                  Name => Make_Indexed_Component (Loc,
 543                     Prefix => New_Occurrence_Of (Res, Loc),
 544                     Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 545                  Expression =>
 546                    Make_Character_Literal (Loc,
 547                      Chars => Name_Find,
 548                      Char_Literal_Value =>
 549                        UI_From_Int (Character'Pos (',')))));
 550
 551             Append_To (Stats,
 552               Make_Assignment_Statement (Loc,
 553                 Name => New_Occurrence_Of (Pos, Loc),
 554                   Expression =>
 555                     Make_Op_Add (Loc,
 556                       Left_Opnd => New_Occurrence_Of (Pos, Loc),
 557                       Right_Opnd => Make_Integer_Literal (Loc, 1))));
 558          end if;
 559       end loop;
 560
 561       Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
 562
 563       Append_To (Stats,
 564          Make_Assignment_Statement (Loc,
 565            Name => Make_Indexed_Component (Loc,
 566               Prefix => New_Occurrence_Of (Res, Loc),
 567               Expressions => New_List (New_Occurrence_Of (Len, Loc))),
 568            Expression =>
 569              Make_Character_Literal (Loc,
 570                Chars => Name_Find,
 571                Char_Literal_Value =>
 572                  UI_From_Int (Character'Pos (')')))));
 573       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
 574    end Build_Task_Array_Image;
 575
 576    ----------------------------
 577    -- Build_Task_Image_Decls --
 578    ----------------------------
 579
 580    function Build_Task_Image_Decls
 581      (Loc          : Source_Ptr;
 582       Id_Ref       : Node_Id;
 583       A_Type       : Entity_Id;
 584       In_Init_Proc : Boolean := False) return List_Id
 585    is
 586       Decls  : constant List_Id   := New_List;
 587       T_Id   : Entity_Id := Empty;
 588       Decl   : Node_Id;
 589       Expr   : Node_Id   := Empty;
 590       Fun    : Node_Id   := Empty;
 591       Is_Dyn : constant Boolean :=
 592                  Nkind (Parent (Id_Ref)) = N_Assignment_Statement
 593                    and then
 594                  Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
 595
 596    begin
 597       --  If Discard_Names or No_Implicit_Heap_Allocations are in effect,
 598       --  generate a dummy declaration only.
 599
 600       if Restriction_Active (No_Implicit_Heap_Allocations)
 601         or else Global_Discard_Names
 602       then
 603          T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
 604          Name_Len := 0;
 605
 606          return
 607            New_List (
 608              Make_Object_Declaration (Loc,
 609                Defining_Identifier => T_Id,
 610                Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 611                Expression =>
 612                  Make_String_Literal (Loc,
 613                    Strval => String_From_Name_Buffer)));
 614
 615       else
 616          if Nkind (Id_Ref) = N_Identifier
 617            or else Nkind (Id_Ref) = N_Defining_Identifier
 618          then
 619             --  For a simple variable, the image of the task is built from
 620             --  the name of the variable. To avoid possible conflict with
 621             --  the anonymous type created for a single protected object,
 622             --  add a numeric suffix.
 623
 624             T_Id :=
 625               Make_Defining_Identifier (Loc,
 626                 New_External_Name (Chars (Id_Ref), 'T', 1));
 627
 628             Get_Name_String (Chars (Id_Ref));
 629
 630             Expr :=
 631               Make_String_Literal (Loc,
 632                 Strval => String_From_Name_Buffer);
 633
 634          elsif Nkind (Id_Ref) = N_Selected_Component then
 635             T_Id :=
 636               Make_Defining_Identifier (Loc,
 637                 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
 638             Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
 639
 640          elsif Nkind (Id_Ref) = N_Indexed_Component then
 641             T_Id :=
 642               Make_Defining_Identifier (Loc,
 643                 New_External_Name (Chars (A_Type), 'N'));
 644
 645             Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
 646          end if;
 647       end if;
 648
 649       if Present (Fun) then
 650          Append (Fun, Decls);
 651          Expr := Make_Function_Call (Loc,
 652            Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
 653
 654          if not In_Init_Proc and then VM_Target = No_VM then
 655             Set_Uses_Sec_Stack (Defining_Entity (Fun));
 656          end if;
 657       end if;
 658
 659       Decl := Make_Object_Declaration (Loc,
 660         Defining_Identifier => T_Id,
 661         Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 662         Constant_Present    => True,
 663         Expression          => Expr);
 664
 665       Append (Decl, Decls);
 666       return Decls;
 667    end Build_Task_Image_Decls;
 668
 669    -------------------------------
 670    -- Build_Task_Image_Function --
 671    -------------------------------
 672
 673    function Build_Task_Image_Function
 674      (Loc   : Source_Ptr;
 675       Decls : List_Id;
 676       Stats : List_Id;
 677       Res   : Entity_Id) return Node_Id
 678    is
 679       Spec : Node_Id;
 680
 681    begin
 682       Append_To (Stats,
 683         Make_Return_Statement (Loc,
 684           Expression => New_Occurrence_Of (Res, Loc)));
 685
 686       Spec := Make_Function_Specification (Loc,
 687         Defining_Unit_Name =>
 688           Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
 689         Result_Definition => New_Occurrence_Of (Standard_String, Loc));
 690
 691       --  Calls to 'Image use the secondary stack, which must be cleaned
 692       --  up after the task name is built.
 693
 694       return Make_Subprogram_Body (Loc,
 695          Specification => Spec,
 696          Declarations => Decls,
 697          Handled_Statement_Sequence =>
 698            Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
 699    end Build_Task_Image_Function;
 700
 701    -----------------------------
 702    -- Build_Task_Image_Prefix --
 703    -----------------------------
 704
 705    procedure Build_Task_Image_Prefix
 706       (Loc    : Source_Ptr;
 707        Len    : out Entity_Id;
 708        Res    : out Entity_Id;
 709        Pos    : out Entity_Id;
 710        Prefix : Entity_Id;
 711        Sum    : Node_Id;
 712        Decls  : in out List_Id;
 713        Stats  : in out List_Id)
 714    is
 715    begin
 716       Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
 717
 718       Append_To (Decls,
 719         Make_Object_Declaration (Loc,
 720           Defining_Identifier => Len,
 721           Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
 722           Expression        => Sum));
 723
 724       Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
 725
 726       Append_To (Decls,
 727          Make_Object_Declaration (Loc,
 728             Defining_Identifier => Res,
 729             Object_Definition =>
 730                Make_Subtype_Indication (Loc,
 731                   Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
 732                Constraint =>
 733                  Make_Index_Or_Discriminant_Constraint (Loc,
 734                    Constraints =>
 735                      New_List (
 736                        Make_Range (Loc,
 737                          Low_Bound => Make_Integer_Literal (Loc, 1),
 738                          High_Bound => New_Occurrence_Of (Len, Loc)))))));
 739
 740       Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 741
 742       Append_To (Decls,
 743          Make_Object_Declaration (Loc,
 744             Defining_Identifier => Pos,
 745             Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
 746
 747       --  Pos := Prefix'Length;
 748
 749       Append_To (Stats,
 750          Make_Assignment_Statement (Loc,
 751             Name => New_Occurrence_Of (Pos, Loc),
 752             Expression =>
 753               Make_Attribute_Reference (Loc,
 754                 Attribute_Name => Name_Length,
 755                 Prefix => New_Occurrence_Of (Prefix, Loc),
 756                 Expressions =>
 757                     New_List (Make_Integer_Literal (Loc, 1)))));
 758
 759       --  Res (1 .. Pos) := Prefix;
 760
 761       Append_To (Stats,
 762          Make_Assignment_Statement (Loc,
 763            Name => Make_Slice (Loc,
 764               Prefix => New_Occurrence_Of (Res, Loc),
 765               Discrete_Range  =>
 766                 Make_Range (Loc,
 767                    Low_Bound => Make_Integer_Literal (Loc, 1),
 768                    High_Bound => New_Occurrence_Of (Pos, Loc))),
 769
 770            Expression => New_Occurrence_Of (Prefix, Loc)));
 771
 772       Append_To (Stats,
 773          Make_Assignment_Statement (Loc,
 774             Name => New_Occurrence_Of (Pos, Loc),
 775             Expression =>
 776               Make_Op_Add (Loc,
 777                 Left_Opnd => New_Occurrence_Of (Pos, Loc),
 778                 Right_Opnd => Make_Integer_Literal (Loc, 1))));
 779    end Build_Task_Image_Prefix;
 780
 781    -----------------------------
 782    -- Build_Task_Record_Image --
 783    -----------------------------
 784
 785    function Build_Task_Record_Image
 786      (Loc    : Source_Ptr;
 787       Id_Ref : Node_Id;
 788       Dyn    : Boolean := False) return Node_Id
 789    is
 790       Len : Entity_Id;
 791       --  Total length of generated name
 792
 793       Pos : Entity_Id;
 794       --  Index into result
 795
 796       Res : Entity_Id;
 797       --  String to hold result
 798
 799       Pref : Entity_Id;
 800       --  Name of enclosing variable, prefix of resulting name
 801
 802       Sum : Node_Id;
 803       --  Expression to compute total size of string
 804
 805       Sel : Entity_Id;
 806       --  Entity for selector name
 807
 808       Decls : List_Id := New_List;
 809       Stats : List_Id := New_List;
 810
 811    begin
 812       Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
 813
 814       --  For a dynamic task, the name comes from the target variable.
 815       --  For a static one it is a formal of the enclosing init proc.
 816
 817       if Dyn then
 818          Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
 819          Append_To (Decls,
 820            Make_Object_Declaration (Loc,
 821              Defining_Identifier => Pref,
 822              Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 823              Expression =>
 824                Make_String_Literal (Loc,
 825                  Strval => String_From_Name_Buffer)));
 826
 827       else
 828          Append_To (Decls,
 829            Make_Object_Renaming_Declaration (Loc,
 830              Defining_Identifier => Pref,
 831              Subtype_Mark        => New_Occurrence_Of (Standard_String, Loc),
 832              Name                => Make_Identifier (Loc, Name_uTask_Name)));
 833       end if;
 834
 835       Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
 836
 837       Get_Name_String (Chars (Selector_Name (Id_Ref)));
 838
 839       Append_To (Decls,
 840          Make_Object_Declaration (Loc,
 841            Defining_Identifier => Sel,
 842            Object_Definition => New_Occurrence_Of (Standard_String, Loc),
 843            Expression =>
 844              Make_String_Literal (Loc,
 845                Strval => String_From_Name_Buffer)));
 846
 847       Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
 848
 849       Sum :=
 850         Make_Op_Add (Loc,
 851           Left_Opnd => Sum,
 852           Right_Opnd =>
 853            Make_Attribute_Reference (Loc,
 854              Attribute_Name => Name_Length,
 855              Prefix =>
 856                New_Occurrence_Of (Pref, Loc),
 857              Expressions => New_List (Make_Integer_Literal (Loc, 1))));
 858
 859       Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
 860
 861       Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
 862
 863       --  Res (Pos) := '.';
 864
 865       Append_To (Stats,
 866          Make_Assignment_Statement (Loc,
 867            Name => Make_Indexed_Component (Loc,
 868               Prefix => New_Occurrence_Of (Res, Loc),
 869               Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
 870            Expression =>
 871              Make_Character_Literal (Loc,
 872                Chars => Name_Find,
 873                Char_Literal_Value =>
 874                  UI_From_Int (Character'Pos ('.')))));
 875
 876       Append_To (Stats,
 877         Make_Assignment_Statement (Loc,
 878           Name => New_Occurrence_Of (Pos, Loc),
 879           Expression =>
 880             Make_Op_Add (Loc,
 881               Left_Opnd => New_Occurrence_Of (Pos, Loc),
 882               Right_Opnd => Make_Integer_Literal (Loc, 1))));
 883
 884       --  Res (Pos .. Len) := Selector;
 885
 886       Append_To (Stats,
 887         Make_Assignment_Statement (Loc,
 888           Name => Make_Slice (Loc,
 889              Prefix => New_Occurrence_Of (Res, Loc),
 890              Discrete_Range  =>
 891                Make_Range (Loc,
 892                  Low_Bound  => New_Occurrence_Of (Pos, Loc),
 893                  High_Bound => New_Occurrence_Of (Len, Loc))),
 894           Expression => New_Occurrence_Of (Sel, Loc)));
 895
 896       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
 897    end Build_Task_Record_Image;
 898
 899    ----------------------------------
 900    -- Component_May_Be_Bit_Aligned --
 901    ----------------------------------
 902
 903    function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
 904    begin
 905       --  If no component clause, then everything is fine, since the
 906       --  back end never bit-misaligns by default, even if there is
 907       --  a pragma Packed for the record.
 908
 909       if No (Component_Clause (Comp)) then
 910          return False;
 911       end if;
 912
 913       --  It is only array and record types that cause trouble
 914
 915       if not Is_Record_Type (Etype (Comp))
 916         and then not Is_Array_Type (Etype (Comp))
 917       then
 918          return False;
 919
 920       --  If we know that we have a small (64 bits or less) record
 921       --  or bit-packed array, then everything is fine, since the
 922       --  back end can handle these cases correctly.
 923
 924       elsif Esize (Comp) <= 64
 925         and then (Is_Record_Type (Etype (Comp))
 926                    or else Is_Bit_Packed_Array (Etype (Comp)))
 927       then
 928          return False;
 929
 930       --  Otherwise if the component is not byte aligned, we
 931       --  know we have the nasty unaligned case.
 932
 933       elsif Normalized_First_Bit (Comp) /= Uint_0
 934         or else Esize (Comp) mod System_Storage_Unit /= Uint_0
 935       then
 936          return True;
 937
 938       --  If we are large and byte aligned, then OK at this level
 939
 940       else
 941          return False;
 942       end if;
 943    end Component_May_Be_Bit_Aligned;
 944
 945    -------------------------------
 946    -- Convert_To_Actual_Subtype --
 947    -------------------------------
 948
 949    procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
 950       Act_ST : Entity_Id;
 951
 952    begin
 953       Act_ST := Get_Actual_Subtype (Exp);
 954
 955       if Act_ST = Etype (Exp) then
 956          return;
 957
 958       else
 959          Rewrite (Exp,
 960            Convert_To (Act_ST, Relocate_Node (Exp)));
 961          Analyze_And_Resolve (Exp, Act_ST);
 962       end if;
 963    end Convert_To_Actual_Subtype;
 964
 965    -----------------------------------
 966    -- Current_Sem_Unit_Declarations --
 967    -----------------------------------
 968
 969    function Current_Sem_Unit_Declarations return List_Id is
 970       U     : Node_Id := Unit (Cunit (Current_Sem_Unit));
 971       Decls : List_Id;
 972
 973    begin
 974       --  If the current unit is a package body, locate the visible
 975       --  declarations of the package spec.
 976
 977       if Nkind (U) = N_Package_Body then
 978          U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
 979       end if;
 980
 981       if Nkind (U) = N_Package_Declaration then
 982          U := Specification (U);
 983          Decls := Visible_Declarations (U);
 984
 985          if No (Decls) then
 986             Decls := New_List;
 987             Set_Visible_Declarations (U, Decls);
 988          end if;
 989
 990       else
 991          Decls := Declarations (U);
 992
 993          if No (Decls) then
 994             Decls := New_List;
 995             Set_Declarations (U, Decls);
 996          end if;
 997       end if;
 998
 999       return Decls;
1000    end Current_Sem_Unit_Declarations;
1001
1002    -----------------------
1003    -- Duplicate_Subexpr --
1004    -----------------------
1005
1006    function Duplicate_Subexpr
1007      (Exp      : Node_Id;
1008       Name_Req : Boolean := False) return Node_Id
1009    is
1010    begin
1011       Remove_Side_Effects (Exp, Name_Req);
1012       return New_Copy_Tree (Exp);
1013    end Duplicate_Subexpr;
1014
1015    ---------------------------------
1016    -- Duplicate_Subexpr_No_Checks --
1017    ---------------------------------
1018
1019    function Duplicate_Subexpr_No_Checks
1020      (Exp      : Node_Id;
1021       Name_Req : Boolean := False) return Node_Id
1022    is
1023       New_Exp : Node_Id;
1024
1025    begin
1026       Remove_Side_Effects (Exp, Name_Req);
1027       New_Exp := New_Copy_Tree (Exp);
1028       Remove_Checks (New_Exp);
1029       return New_Exp;
1030    end Duplicate_Subexpr_No_Checks;
1031
1032    -----------------------------------
1033    -- Duplicate_Subexpr_Move_Checks --
1034    -----------------------------------
1035
1036    function Duplicate_Subexpr_Move_Checks
1037      (Exp      : Node_Id;
1038       Name_Req : Boolean := False) return Node_Id
1039    is
1040       New_Exp : Node_Id;
1041
1042    begin
1043       Remove_Side_Effects (Exp, Name_Req);
1044       New_Exp := New_Copy_Tree (Exp);
1045       Remove_Checks (Exp);
1046       return New_Exp;
1047    end Duplicate_Subexpr_Move_Checks;
1048
1049    --------------------
1050    -- Ensure_Defined --
1051    --------------------
1052
1053    procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1054       IR : Node_Id;
1055       P  : Node_Id;
1056
1057    begin
1058       if Is_Itype (Typ) then
1059          IR := Make_Itype_Reference (Sloc (N));
1060          Set_Itype (IR, Typ);
1061
1062          if not In_Open_Scopes (Scope (Typ))
1063            and then Is_Subprogram (Current_Scope)
1064            and then Scope (Current_Scope) /= Standard_Standard
1065          then
1066             --  Insert node in front of subprogram, to avoid scope anomalies
1067             --  in gigi.
1068
1069             P := Parent (N);
1070             while Present (P)
1071               and then Nkind (P) /= N_Subprogram_Body
1072             loop
1073                P := Parent (P);
1074             end loop;
1075
1076             if Present (P) then
1077                Insert_Action (P, IR);
1078             else
1079                Insert_Action (N, IR);
1080             end if;
1081
1082          else
1083             Insert_Action (N, IR);
1084          end if;
1085       end if;
1086    end Ensure_Defined;
1087
1088    ---------------------
1089    -- Evolve_And_Then --
1090    ---------------------
1091
1092    procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1093    begin
1094       if No (Cond) then
1095          Cond := Cond1;
1096       else
1097          Cond :=
1098            Make_And_Then (Sloc (Cond1),
1099              Left_Opnd  => Cond,
1100              Right_Opnd => Cond1);
1101       end if;
1102    end Evolve_And_Then;
1103
1104    --------------------
1105    -- Evolve_Or_Else --
1106    --------------------
1107
1108    procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1109    begin
1110       if No (Cond) then
1111          Cond := Cond1;
1112       else
1113          Cond :=
1114            Make_Or_Else (Sloc (Cond1),
1115              Left_Opnd  => Cond,
1116              Right_Opnd => Cond1);
1117       end if;
1118    end Evolve_Or_Else;
1119
1120    ------------------------------
1121    -- Expand_Subtype_From_Expr --
1122    ------------------------------
1123
1124    --  This function is applicable for both static and dynamic allocation of
1125    --  objects which are constrained by an initial expression. Basically it
1126    --  transforms an unconstrained subtype indication into a constrained one.
1127    --  The expression may also be transformed in certain cases in order to
1128    --  avoid multiple evaluation. In the static allocation case, the general
1129    --  scheme is:
1130
1131    --     Val : T := Expr;
1132
1133    --        is transformed into
1134
1135    --     Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1136    --
1137    --  Here are the main cases :
1138    --
1139    --  <if Expr is a Slice>
1140    --    Val : T ([Index_Subtype (Expr)]) := Expr;
1141    --
1142    --  <elsif Expr is a String Literal>
1143    --    Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1144    --
1145    --  <elsif Expr is Constrained>
1146    --    subtype T is Type_Of_Expr
1147    --    Val : T := Expr;
1148    --
1149    --  <elsif Expr is an entity_name>
1150    --    Val : T (constraints taken from Expr) := Expr;
1151    --
1152    --  <else>
1153    --    type Axxx is access all T;
1154    --    Rval : Axxx := Expr'ref;
1155    --    Val  : T (constraints taken from Rval) := Rval.all;
1156
1157    --    ??? note: when the Expression is allocated in the secondary stack
1158    --              we could use it directly instead of copying it by declaring
1159    --              Val : T (...) renames Rval.all
1160
1161    procedure Expand_Subtype_From_Expr
1162      (N             : Node_Id;
1163       Unc_Type      : Entity_Id;
1164       Subtype_Indic : Node_Id;
1165       Exp           : Node_Id)
1166    is
1167       Loc     : constant Source_Ptr := Sloc (N);
1168       Exp_Typ : constant Entity_Id  := Etype (Exp);
1169       T       : Entity_Id;
1170
1171    begin
1172       --  In general we cannot build the subtype if expansion is disabled,
1173       --  because internal entities may not have been defined. However, to
1174       --  avoid some cascaded errors, we try to continue when the expression
1175       --  is an array (or string), because it is safe to compute the bounds.
1176       --  It is in fact required to do so even in a generic context, because
1177       --  there may be constants that depend on bounds of string literal.
1178
1179       if not Expander_Active
1180         and then (No (Etype (Exp))
1181                    or else Base_Type (Etype (Exp)) /= Standard_String)
1182       then
1183          return;
1184       end if;
1185
1186       if Nkind (Exp) = N_Slice then
1187          declare
1188             Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1189
1190          begin
1191             Rewrite (Subtype_Indic,
1192               Make_Subtype_Indication (Loc,
1193                 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1194                 Constraint =>
1195                   Make_Index_Or_Discriminant_Constraint (Loc,
1196                     Constraints => New_List
1197                       (New_Reference_To (Slice_Type, Loc)))));
1198
1199             --  This subtype indication may be used later for contraint checks
1200             --  we better make sure that if a variable was used as a bound of
1201             --  of the original slice, its value is frozen.
1202
1203             Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1204             Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1205          end;
1206
1207       elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1208          Rewrite (Subtype_Indic,
1209            Make_Subtype_Indication (Loc,
1210              Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1211              Constraint =>
1212                Make_Index_Or_Discriminant_Constraint (Loc,
1213                  Constraints => New_List (
1214                    Make_Literal_Range (Loc,
1215                      Literal_Typ => Exp_Typ)))));
1216
1217       elsif Is_Constrained (Exp_Typ)
1218         and then not Is_Class_Wide_Type (Unc_Type)
1219       then
1220          if Is_Itype (Exp_Typ) then
1221
1222             --  Within an initialization procedure, a selected component
1223             --  denotes a component of the enclosing record, and it appears
1224             --  as an actual in a call to its own initialization procedure.
1225             --  If this component depends on the outer discriminant, we must
1226             --  generate the proper actual subtype for it.
1227
1228             if Nkind (Exp) = N_Selected_Component
1229               and then Within_Init_Proc
1230             then
1231                declare
1232                   Decl : constant Node_Id :=
1233                            Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
1234                begin
1235                   if Present (Decl) then
1236                      Insert_Action (N, Decl);
1237                      T := Defining_Identifier (Decl);
1238                   else
1239                      T := Exp_Typ;
1240                   end if;
1241                end;
1242
1243             --  No need to generate a new one (new what???)
1244
1245             else
1246                T := Exp_Typ;
1247             end if;
1248
1249          else
1250             T :=
1251               Make_Defining_Identifier (Loc,
1252                 Chars => New_Internal_Name ('T'));
1253
1254             Insert_Action (N,
1255               Make_Subtype_Declaration (Loc,
1256                 Defining_Identifier => T,
1257                 Subtype_Indication  => New_Reference_To (Exp_Typ, Loc)));
1258
1259             --  This type is marked as an itype even though it has an
1260             --  explicit declaration because otherwise it can be marked
1261             --  with Is_Generic_Actual_Type and generate spurious errors.
1262             --  (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1263
1264             Set_Is_Itype (T);
1265             Set_Associated_Node_For_Itype (T, Exp);
1266          end if;
1267
1268          Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1269
1270       --  nothing needs to be done for private types with unknown discriminants
1271       --  if the underlying type is not an unconstrained composite type.
1272
1273       elsif Is_Private_Type (Unc_Type)
1274         and then Has_Unknown_Discriminants (Unc_Type)
1275         and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1276                     or else Is_Constrained (Underlying_Type (Unc_Type)))
1277       then
1278          null;
1279
1280       --  Nothing to be done for derived types with unknown discriminants if
1281       --  the parent type also has unknown discriminants.
1282
1283       elsif Is_Record_Type (Unc_Type)
1284         and then not Is_Class_Wide_Type (Unc_Type)
1285         and then Has_Unknown_Discriminants (Unc_Type)
1286         and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
1287       then
1288          null;
1289
1290       --  In Ada95, Nothing to be done if the type of the expression is
1291       --  limited, because in this case the expression cannot be copied,
1292       --  and its use can only be by reference.
1293
1294       --  In Ada2005, the context can be an object declaration whose expression
1295       --  is a function that returns in place. If the nominal subtype has
1296       --  unknown discriminants, the call still provides constraints on the
1297       --  object, and we have to create an actual subtype from it.
1298
1299       --  If the type is class-wide, the expression is dynamically tagged and
1300       --  we do not create an actual subtype either. Ditto for an interface.
1301
1302       elsif Is_Limited_Type (Exp_Typ)
1303         and then
1304          (Is_Class_Wide_Type (Exp_Typ)
1305            or else Is_Interface (Exp_Typ)
1306            or else not Has_Unknown_Discriminants (Exp_Typ)
1307            or else not Is_Composite_Type (Unc_Type))
1308       then
1309          null;
1310
1311       --  For limited interfaces, nothing to be done
1312
1313       --  This branch may be redundant once the limited interface issue is
1314       --  sorted out???
1315
1316       elsif Is_Interface (Exp_Typ)
1317         and then Is_Limited_Interface (Exp_Typ)
1318       then
1319          null;
1320
1321       else
1322          Remove_Side_Effects (Exp);
1323          Rewrite (Subtype_Indic,
1324            Make_Subtype_From_Expr (Exp, Unc_Type));
1325       end if;
1326    end Expand_Subtype_From_Expr;
1327
1328    ------------------------
1329    -- Find_Interface_ADT --
1330    ------------------------
1331
1332    function Find_Interface_ADT
1333      (T     : Entity_Id;
1334       Iface : Entity_Id) return Entity_Id
1335    is
1336       ADT   : Elmt_Id;
1337       Found : Boolean   := False;
1338       Typ   : Entity_Id := T;
1339
1340       procedure Find_Secondary_Table (Typ : Entity_Id);
1341       --  Internal subprogram used to recursively climb to the ancestors
1342
1343       --------------------------
1344       -- Find_Secondary_Table --
1345       --------------------------
1346
1347       procedure Find_Secondary_Table (Typ : Entity_Id) is
1348          AI_Elmt : Elmt_Id;
1349          AI      : Node_Id;
1350
1351       begin
1352          pragma Assert (Typ /= Iface);
1353
1354          --  Climb to the ancestor (if any) handling synchronized interface
1355          --  derivations and private types
1356
1357          if Is_Concurrent_Record_Type (Typ) then
1358             declare
1359                Iface_List : constant List_Id := Abstract_Interface_List (Typ);
1360
1361             begin
1362                if Is_Non_Empty_List (Iface_List) then
1363                   Find_Secondary_Table (Etype (First (Iface_List)));
1364                end if;
1365             end;
1366
1367          elsif Present (Full_View (Etype (Typ))) then
1368             if Full_View (Etype (Typ)) /= Typ then
1369                Find_Secondary_Table (Full_View (Etype (Typ)));
1370             end if;
1371
1372          elsif Etype (Typ) /= Typ then
1373             Find_Secondary_Table (Etype (Typ));
1374          end if;
1375
1376          --  Traverse the list of interfaces implemented by the type
1377
1378          if not Found
1379            and then Present (Abstract_Interfaces (Typ))
1380            and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
1381          then
1382             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1383             while Present (AI_Elmt) loop
1384                AI := Node (AI_Elmt);
1385
1386                if AI = Iface or else Is_Ancestor (Iface, AI) then
1387                   Found := True;
1388                   return;
1389                end if;
1390
1391                Next_Elmt (ADT);
1392                Next_Elmt (AI_Elmt);
1393             end loop;
1394          end if;
1395       end Find_Secondary_Table;
1396
1397    --  Start of processing for Find_Interface_ADT
1398
1399    begin
1400       pragma Assert (Is_Interface (Iface));
1401
1402       --  Handle private types
1403
1404       if Has_Private_Declaration (Typ)
1405         and then Present (Full_View (Typ))
1406       then
1407          Typ := Full_View (Typ);
1408       end if;
1409
1410       --  Handle access types
1411
1412       if Is_Access_Type (Typ) then
1413          Typ := Directly_Designated_Type (Typ);
1414       end if;
1415
1416       --  Handle task and protected types implementing interfaces
1417
1418       if Is_Concurrent_Type (Typ) then
1419          Typ := Corresponding_Record_Type (Typ);
1420       end if;
1421
1422       pragma Assert
1423         (not Is_Class_Wide_Type (Typ)
1424           and then Ekind (Typ) /= E_Incomplete_Type);
1425
1426       ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
1427       pragma Assert (Present (Node (ADT)));
1428       Find_Secondary_Table (Typ);
1429       pragma Assert (Found);
1430       return Node (ADT);
1431    end Find_Interface_ADT;
1432
1433    ------------------------
1434    -- Find_Interface_Tag --
1435    ------------------------
1436
1437    function Find_Interface_Tag
1438      (T     : Entity_Id;
1439       Iface : Entity_Id) return Entity_Id
1440    is
1441       AI_Tag : Entity_Id;
1442       Found  : Boolean   := False;
1443       Typ    : Entity_Id := T;
1444
1445       Is_Primary_Tag : Boolean := False;
1446
1447       Is_Sync_Typ : Boolean := False;
1448       --  In case of non concurrent-record-types each parent-type has the
1449       --  tags associated with the interface types that are not implemented
1450       --  by the ancestors; concurrent-record-types have their whole list of
1451       --  interface tags (and this case requires some special management).
1452
1453       procedure Find_Tag (Typ : Entity_Id);
1454       --  Internal subprogram used to recursively climb to the ancestors
1455
1456       --------------
1457       -- Find_Tag --
1458       --------------
1459
1460       procedure Find_Tag (Typ : Entity_Id) is
1461          AI_Elmt : Elmt_Id;
1462          AI      : Node_Id;
1463
1464       begin
1465          --  Check if the interface is an immediate ancestor of the type and
1466          --  therefore shares the main tag.
1467
1468          if Typ = Iface then
1469             if Is_Sync_Typ then
1470                Is_Primary_Tag := True;
1471             else
1472                pragma Assert
1473                  (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1474                AI_Tag := First_Tag_Component (Typ);
1475             end if;
1476
1477             Found  := True;
1478             return;
1479          end if;
1480
1481          --  Handle synchronized interface derivations
1482
1483          if Is_Concurrent_Record_Type (Typ) then
1484             declare
1485                Iface_List : constant List_Id := Abstract_Interface_List (Typ);
1486             begin
1487                if Is_Non_Empty_List (Iface_List) then
1488                   Find_Tag (Etype (First (Iface_List)));
1489                end if;
1490             end;
1491
1492          --  Climb to the root type handling private types
1493
1494          elsif Present (Full_View (Etype (Typ))) then
1495             if Full_View (Etype (Typ)) /= Typ then
1496                Find_Tag (Full_View (Etype (Typ)));
1497             end if;
1498
1499          elsif Etype (Typ) /= Typ then
1500             Find_Tag (Etype (Typ));
1501          end if;
1502
1503          --  Traverse the list of interfaces implemented by the type
1504
1505          if not Found
1506            and then Present (Abstract_Interfaces (Typ))
1507            and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
1508          then
1509             --  Skip the tag associated with the primary table
1510
1511             if not Is_Sync_Typ then
1512                pragma Assert
1513                  (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1514                AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1515                pragma Assert (Present (AI_Tag));
1516             end if;
1517
1518             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1519             while Present (AI_Elmt) loop
1520                AI := Node (AI_Elmt);
1521
1522                if AI = Iface or else Is_Ancestor (Iface, AI) then
1523                   Found := True;
1524                   return;
1525                end if;
1526
1527                AI_Tag := Next_Tag_Component (AI_Tag);
1528                Next_Elmt (AI_Elmt);
1529             end loop;
1530          end if;
1531       end Find_Tag;
1532
1533    --  Start of processing for Find_Interface_Tag
1534
1535    begin
1536       pragma Assert (Is_Interface (Iface));
1537
1538       --  Handle private types
1539
1540       if Has_Private_Declaration (Typ)
1541         and then Present (Full_View (Typ))
1542       then
1543          Typ := Full_View (Typ);
1544       end if;
1545
1546       --  Handle access types
1547
1548       if Is_Access_Type (Typ) then
1549          Typ := Directly_Designated_Type (Typ);
1550       end if;
1551
1552       --  Handle task and protected types implementing interfaces
1553
1554       if Is_Concurrent_Type (Typ) then
1555          Typ := Corresponding_Record_Type (Typ);
1556       end if;
1557
1558       if Is_Class_Wide_Type (Typ) then
1559          Typ := Etype (Typ);
1560       end if;
1561
1562       --  Handle entities from the limited view
1563
1564       if Ekind (Typ) = E_Incomplete_Type then
1565          pragma Assert (Present (Non_Limited_View (Typ)));
1566          Typ := Non_Limited_View (Typ);
1567       end if;
1568
1569       if not Is_Concurrent_Record_Type (Typ) then
1570          Find_Tag (Typ);
1571          pragma Assert (Found);
1572          return AI_Tag;
1573
1574       --  Concurrent record types
1575
1576       else
1577          Is_Sync_Typ := True;
1578          AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
1579          Find_Tag (Typ);
1580          pragma Assert (Found);
1581
1582          if Is_Primary_Tag then
1583             return First_Tag_Component (Typ);
1584          else
1585             return AI_Tag;
1586          end if;
1587       end if;
1588    end Find_Interface_Tag;
1589
1590    --------------------
1591    -- Find_Interface --
1592    --------------------
1593
1594    function Find_Interface
1595      (T      : Entity_Id;
1596       Comp   : Entity_Id) return Entity_Id
1597    is
1598       AI_Tag : Entity_Id;
1599       Found  : Boolean := False;
1600       Iface  : Entity_Id;
1601       Typ    : Entity_Id := T;
1602
1603       Is_Sync_Typ : Boolean := False;
1604       --  In case of non concurrent-record-types each parent-type has the
1605       --  tags associated with the interface types that are not implemented
1606       --  by the ancestors; concurrent-record-types have their whole list of
1607       --  interface tags (and this case requires some special management).
1608
1609       procedure Find_Iface (Typ : Entity_Id);
1610       --  Internal subprogram used to recursively climb to the ancestors
1611
1612       ----------------
1613       -- Find_Iface --
1614       ----------------
1615
1616       procedure Find_Iface (Typ : Entity_Id) is
1617          AI_Elmt : Elmt_Id;
1618
1619       begin
1620          --  Climb to the root type
1621
1622          --  Handle sychronized interface derivations
1623
1624          if Is_Concurrent_Record_Type (Typ) then
1625             declare
1626                Iface_List : constant List_Id := Abstract_Interface_List (Typ);
1627             begin
1628                if Is_Non_Empty_List (Iface_List) then
1629                   Find_Iface (Etype (First (Iface_List)));
1630                end if;
1631             end;
1632
1633          --  Handle the common case
1634
1635          elsif Etype (Typ) /= Typ then
1636             pragma Assert (not Present (Full_View (Etype (Typ))));
1637             Find_Iface (Etype (Typ));
1638          end if;
1639
1640          --  Traverse the list of interfaces implemented by the type
1641
1642          if not Found
1643            and then Present (Abstract_Interfaces (Typ))
1644            and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
1645          then
1646             --  Skip the tag associated with the primary table
1647
1648             if not Is_Sync_Typ then
1649                pragma Assert
1650                  (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
1651                AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
1652                pragma Assert (Present (AI_Tag));
1653             end if;
1654
1655             AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
1656             while Present (AI_Elmt) loop
1657                if AI_Tag = Comp then
1658                   Iface := Node (AI_Elmt);
1659                   Found := True;
1660                   return;
1661                end if;
1662
1663                AI_Tag := Next_Tag_Component (AI_Tag);
1664                Next_Elmt (AI_Elmt);
1665             end loop;
1666          end if;
1667       end Find_Iface;
1668
1669    --  Start of processing for Find_Interface
1670
1671    begin
1672       --  Handle private types
1673
1674       if Has_Private_Declaration (Typ)
1675         and then Present (Full_View (Typ))
1676       then
1677          Typ := Full_View (Typ);
1678       end if;
1679
1680       --  Handle access types
1681
1682       if Is_Access_Type (Typ) then
1683          Typ := Directly_Designated_Type (Typ);
1684       end if;
1685
1686       --  Handle task and protected types implementing interfaces
1687
1688       if Is_Concurrent_Type (Typ) then
1689          Typ := Corresponding_Record_Type (Typ);
1690       end if;
1691
1692       if Is_Class_Wide_Type (Typ) then
1693          Typ := Etype (Typ);
1694       end if;
1695
1696       --  Handle entities from the limited view
1697
1698       if Ekind (Typ) = E_Incomplete_Type then
1699          pragma Assert (Present (Non_Limited_View (Typ)));
1700          Typ := Non_Limited_View (Typ);
1701       end if;
1702
1703       if Is_Concurrent_Record_Type (Typ) then
1704          Is_Sync_Typ := True;
1705          AI_Tag      := Next_Tag_Component (First_Tag_Component (Typ));
1706       end if;
1707
1708       Find_Iface (Typ);
1709       pragma Assert (Found);
1710       return Iface;
1711    end Find_Interface;
1712
1713    ------------------
1714    -- Find_Prim_Op --
1715    ------------------
1716
1717    function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1718       Prim : Elmt_Id;
1719       Typ  : Entity_Id := T;
1720       Op   : Entity_Id;
1721
1722    begin
1723       if Is_Class_Wide_Type (Typ) then
1724          Typ := Root_Type (Typ);
1725       end if;
1726
1727       Typ := Underlying_Type (Typ);
1728
1729       --  Loop through primitive operations
1730
1731       Prim := First_Elmt (Primitive_Operations (Typ));
1732       while Present (Prim) loop
1733          Op := Node (Prim);
1734
1735          --  We can retrieve primitive operations by name if it is an internal
1736          --  name. For equality we must check that both of its operands have
1737          --  the same type, to avoid confusion with user-defined equalities
1738          --  than may have a non-symmetric signature.
1739
1740          exit when Chars (Op) = Name
1741            and then
1742              (Name /= Name_Op_Eq
1743                 or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
1744
1745          Next_Elmt (Prim);
1746          pragma Assert (Present (Prim));
1747       end loop;
1748
1749       return Node (Prim);
1750    end Find_Prim_Op;
1751
1752    ------------------
1753    -- Find_Prim_Op --
1754    ------------------
1755
1756    function Find_Prim_Op
1757      (T    : Entity_Id;
1758       Name : TSS_Name_Type) return Entity_Id
1759    is
1760       Prim : Elmt_Id;
1761       Typ  : Entity_Id := T;
1762
1763    begin
1764       if Is_Class_Wide_Type (Typ) then
1765          Typ := Root_Type (Typ);
1766       end if;
1767
1768       Typ := Underlying_Type (Typ);
1769
1770       Prim := First_Elmt (Primitive_Operations (Typ));
1771       while not Is_TSS (Node (Prim), Name) loop
1772          Next_Elmt (Prim);
1773          pragma Assert (Present (Prim));
1774       end loop;
1775
1776       return Node (Prim);
1777    end Find_Prim_Op;
1778
1779    ----------------------
1780    -- Force_Evaluation --
1781    ----------------------
1782
1783    procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1784    begin
1785       Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1786    end Force_Evaluation;
1787
1788    ------------------------
1789    -- Generate_Poll_Call --
1790    ------------------------
1791
1792    procedure Generate_Poll_Call (N : Node_Id) is
1793    begin
1794       --  No poll call if polling not active
1795
1796       if not Polling_Required then
1797          return;
1798
1799       --  Otherwise generate require poll call
1800
1801       else
1802          Insert_Before_And_Analyze (N,
1803            Make_Procedure_Call_Statement (Sloc (N),
1804              Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1805       end if;
1806    end Generate_Poll_Call;
1807
1808    ---------------------------------
1809    -- Get_Current_Value_Condition --
1810    ---------------------------------
1811
1812    --  Note: the implementation of this procedure is very closely tied to the
1813    --  implementation of Set_Current_Value_Condition. In the Get procedure, we
1814    --  interpret Current_Value fields set by the Set procedure, so the two
1815    --  procedures need to be closely coordinated.
1816
1817    procedure Get_Current_Value_Condition
1818      (Var : Node_Id;
1819       Op  : out Node_Kind;
1820       Val : out Node_Id)
1821    is
1822       Loc : constant Source_Ptr := Sloc (Var);
1823       Ent : constant Entity_Id  := Entity (Var);
1824
1825       procedure Process_Current_Value_Condition
1826         (N : Node_Id;
1827          S : Boolean);
1828       --  N is an expression which holds either True (S = True) or False (S =
1829       --  False) in the condition. This procedure digs out the expression and
1830       --  if it refers to Ent, sets Op and Val appropriately.
1831
1832       -------------------------------------
1833       -- Process_Current_Value_Condition --
1834       -------------------------------------
1835
1836       procedure Process_Current_Value_Condition
1837         (N : Node_Id;
1838          S : Boolean)
1839       is
1840          Cond : Node_Id;
1841          Sens : Boolean;
1842
1843       begin
1844          Cond := N;
1845          Sens := S;
1846
1847          --  Deal with NOT operators, inverting sense
1848
1849          while Nkind (Cond) = N_Op_Not loop
1850             Cond := Right_Opnd (Cond);
1851             Sens := not Sens;
1852          end loop;
1853
1854          --  Deal with AND THEN and AND cases
1855
1856          if Nkind (Cond) = N_And_Then
1857            or else Nkind (Cond) = N_Op_And
1858          then
1859             --  Don't ever try to invert a condition that is of the form
1860             --  of an AND or AND THEN (since we are not doing sufficiently
1861             --  general processing to allow this).
1862
1863             if Sens = False then
1864                Op  := N_Empty;
1865                Val := Empty;
1866                return;
1867             end if;
1868
1869             --  Recursively process AND and AND THEN branches
1870
1871             Process_Current_Value_Condition (Left_Opnd (Cond), True);
1872
1873             if Op /= N_Empty then
1874                return;
1875             end if;
1876
1877             Process_Current_Value_Condition (Right_Opnd (Cond), True);
1878             return;
1879
1880          --  Case of relational operator
1881
1882          elsif Nkind (Cond) in N_Op_Compare then
1883             Op := Nkind (Cond);
1884
1885             --  Invert sense of test if inverted test
1886
1887             if Sens = False then
1888                case Op is
1889                   when N_Op_Eq => Op := N_Op_Ne;
1890                   when N_Op_Ne => Op := N_Op_Eq;
1891                   when N_Op_Lt => Op := N_Op_Ge;
1892                   when N_Op_Gt => Op := N_Op_Le;
1893                   when N_Op_Le => Op := N_Op_Gt;
1894                   when N_Op_Ge => Op := N_Op_Lt;
1895                   when others  => raise Program_Error;
1896                end case;
1897             end if;
1898
1899             --  Case of entity op value
1900
1901             if Is_Entity_Name (Left_Opnd (Cond))
1902               and then Ent = Entity (Left_Opnd (Cond))
1903               and then Compile_Time_Known_Value (Right_Opnd (Cond))
1904             then
1905                Val := Right_Opnd (Cond);
1906
1907             --  Case of value op entity
1908
1909             elsif Is_Entity_Name (Right_Opnd (Cond))
1910               and then Ent = Entity (Right_Opnd (Cond))
1911               and then Compile_Time_Known_Value (Left_Opnd (Cond))
1912             then
1913                Val := Left_Opnd (Cond);
1914
1915                --  We are effectively swapping operands
1916
1917                case Op is
1918                   when N_Op_Eq => null;
1919                   when N_Op_Ne => null;
1920                   when N_Op_Lt => Op := N_Op_Gt;
1921                   when N_Op_Gt => Op := N_Op_Lt;
1922                   when N_Op_Le => Op := N_Op_Ge;
1923                   when N_Op_Ge => Op := N_Op_Le;
1924                   when others  => raise Program_Error;
1925                end case;
1926
1927             else
1928                Op := N_Empty;
1929             end if;
1930
1931             return;
1932
1933             --  Case of Boolean variable reference, return as though the
1934             --  reference had said var = True.
1935
1936          else
1937             if Is_Entity_Name (Cond)
1938               and then Ent = Entity (Cond)
1939             then
1940                Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
1941
1942                if Sens = False then
1943                   Op := N_Op_Ne;
1944                else
1945                   Op := N_Op_Eq;
1946                end if;
1947             end if;
1948          end if;
1949       end Process_Current_Value_Condition;
1950
1951    --  Start of processing for Get_Current_Value_Condition
1952
1953    begin
1954       Op  := N_Empty;
1955       Val := Empty;
1956
1957       --  Immediate return, nothing doing, if this is not an object
1958
1959       if Ekind (Ent) not in Object_Kind then
1960          return;
1961       end if;
1962
1963       --  Otherwise examine current value
1964
1965       declare
1966          CV   : constant Node_Id := Current_Value (Ent);
1967          Sens : Boolean;
1968          Stm  : Node_Id;
1969
1970       begin
1971          --  If statement. Condition is known true in THEN section, known False
1972          --  in any ELSIF or ELSE part, and unknown outside the IF statement.
1973
1974          if Nkind (CV) = N_If_Statement then
1975
1976             --  Before start of IF statement
1977
1978             if Loc < Sloc (CV) then
1979                return;
1980
1981                --  After end of IF statement
1982
1983             elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
1984                return;
1985             end if;
1986
1987             --  At this stage we know that we are within the IF statement, but
1988             --  unfortunately, the tree does not record the SLOC of the ELSE so
1989             --  we cannot use a simple SLOC comparison to distinguish between
1990             --  the then/else statements, so we have to climb the tree.
1991
1992             declare
1993                N : Node_Id;
1994
1995             begin
1996                N := Parent (Var);
1997                while Parent (N) /= CV loop
1998                   N := Parent (N);
1999
2000                   --  If we fall off the top of the tree, then that's odd, but
2001                   --  perhaps it could occur in some error situation, and the
2002                   --  safest response is simply to assume that the outcome of
2003                   --  the condition is unknown. No point in bombing during an
2004                   --  attempt to optimize things.
2005
2006                   if No (N) then
2007                      return;
2008                   end if;
2009                end loop;
2010
2011                --  Now we have N pointing to a node whose parent is the IF
2012                --  statement in question, so now we can tell if we are within
2013                --  the THEN statements.
2014
2015                if Is_List_Member (N)
2016                  and then List_Containing (N) = Then_Statements (CV)
2017                then
2018                   Sens := True;
2019
2020                --  If the variable reference does not come from source, we
2021                --  cannot reliably tell whether it appears in the else part.
2022                --  In particular, if if appears in generated code for a node
2023                --  that requires finalization, it may be attached to a list
2024                --  that has not been yet inserted into the code. For now,
2025                --  treat it as unknown.
2026
2027                elsif not Comes_From_Source (N) then
2028                   return;
2029
2030                --  Otherwise we must be in ELSIF or ELSE part
2031
2032                else
2033                   Sens := False;
2034                end if;
2035             end;
2036
2037             --  ELSIF part. Condition is known true within the referenced
2038             --  ELSIF, known False in any subsequent ELSIF or ELSE part, and
2039             --  unknown before the ELSE part or after the IF statement.
2040
2041          elsif Nkind (CV) = N_Elsif_Part then
2042             Stm := Parent (CV);
2043
2044             --  Before start of ELSIF part
2045
2046             if Loc < Sloc (CV) then
2047                return;
2048
2049                --  After end of IF statement
2050
2051             elsif Loc >= Sloc (Stm) +
2052               Text_Ptr (UI_To_Int (End_Span (Stm)))
2053             then
2054                return;
2055             end if;
2056
2057             --  Again we lack the SLOC of the ELSE, so we need to climb the
2058             --  tree to see if we are within the ELSIF part in question.
2059
2060             declare
2061                N : Node_Id;
2062
2063             begin
2064                N := Parent (Var);
2065                while Parent (N) /= Stm loop
2066                   N := Parent (N);
2067
2068                   --  If we fall off the top of the tree, then that's odd, but
2069                   --  perhaps it could occur in some error situation, and the
2070                   --  safest response is simply to assume that the outcome of
2071                   --  the condition is unknown. No point in bombing during an
2072                   --  attempt to optimize things.
2073
2074                   if No (N) then
2075                      return;
2076                   end if;
2077                end loop;
2078
2079                --  Now we have N pointing to a node whose parent is the IF
2080                --  statement in question, so see if is the ELSIF part we want.
2081                --  the THEN statements.
2082
2083                if N = CV then
2084                   Sens := True;
2085
2086                   --  Otherwise we must be in susbequent ELSIF or ELSE part
2087
2088                else
2089                   Sens := False;
2090                end if;
2091             end;
2092
2093          --  Iteration scheme of while loop. The condition is known to be
2094          --  true within the body of the loop.
2095
2096          elsif Nkind (CV) = N_Iteration_Scheme then
2097             declare
2098                Loop_Stmt : constant Node_Id := Parent (CV);
2099
2100             begin
2101                --  Before start of body of loop
2102
2103                if Loc < Sloc (Loop_Stmt) then
2104                   return;
2105
2106                --  After end of LOOP statement
2107
2108                elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2109                   return;
2110
2111                --  We are within the body of the loop
2112
2113                else
2114                   Sens := True;
2115                end if;
2116             end;
2117
2118          --  All other cases of Current_Value settings
2119
2120          else
2121             return;
2122          end if;
2123
2124          --  If we fall through here, then we have a reportable condition, Sens
2125          --  is True if the condition is true and False if it needs inverting.
2126
2127          Process_Current_Value_Condition (Condition (CV), Sens);
2128       end;
2129    end Get_Current_Value_Condition;
2130
2131    ---------------------------------
2132    -- Has_Controlled_Coextensions --
2133    ---------------------------------
2134
2135    function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
2136       D_Typ : Entity_Id;
2137       Discr : Entity_Id;
2138
2139    begin
2140       --  Only consider record types
2141
2142       if Ekind (Typ) /= E_Record_Type
2143         and then Ekind (Typ) /= E_Record_Subtype
2144       then
2145          return False;
2146       end if;
2147
2148       if Has_Discriminants (Typ) then
2149          Discr := First_Discriminant (Typ);
2150          while Present (Discr) loop
2151             D_Typ := Etype (Discr);
2152
2153             if Ekind (D_Typ) = E_Anonymous_Access_Type
2154               and then
2155                 (Is_Controlled (Directly_Designated_Type (D_Typ))
2156                    or else
2157                  Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
2158             then
2159                return True;
2160             end if;
2161
2162             Next_Discriminant (Discr);
2163          end loop;
2164       end if;
2165
2166       return False;
2167    end Has_Controlled_Coextensions;
2168
2169    --------------------
2170    -- Homonym_Number --
2171    --------------------
2172
2173    function Homonym_Number (Subp : Entity_Id) return Nat is
2174       Count : Nat;
2175       Hom   : Entity_Id;
2176
2177    begin
2178       Count := 1;
2179       Hom := Homonym (Subp);
2180       while Present (Hom) loop
2181          if Scope (Hom) = Scope (Subp) then
2182             Count := Count + 1;
2183          end if;
2184
2185          Hom := Homonym (Hom);
2186       end loop;
2187
2188       return Count;
2189    end Homonym_Number;
2190
2191    ------------------------------
2192    -- In_Unconditional_Context --
2193    ------------------------------
2194
2195    function In_Unconditional_Context (Node : Node_Id) return Boolean is
2196       P : Node_Id;
2197
2198    begin
2199       P := Node;
2200       while Present (P) loop
2201          case Nkind (P) is
2202             when N_Subprogram_Body =>
2203                return True;
2204
2205             when N_If_Statement =>
2206                return False;
2207
2208             when N_Loop_Statement =>
2209                return False;
2210
2211             when N_Case_Statement =>
2212                return False;
2213
2214             when others =>
2215                P := Parent (P);
2216          end case;
2217       end loop;
2218
2219       return False;
2220    end In_Unconditional_Context;
2221
2222    -------------------
2223    -- Insert_Action --
2224    -------------------
2225
2226    procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
2227    begin
2228       if Present (Ins_Action) then
2229          Insert_Actions (Assoc_Node, New_List (Ins_Action));
2230       end if;
2231    end Insert_Action;
2232
2233    --  Version with check(s) suppressed
2234
2235    procedure Insert_Action
2236      (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
2237    is
2238    begin
2239       Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
2240    end Insert_Action;
2241
2242    --------------------
2243    -- Insert_Actions --
2244    --------------------
2245
2246    procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
2247       N : Node_Id;
2248       P : Node_Id;
2249
2250       Wrapped_Node : Node_Id := Empty;
2251
2252    begin
2253       if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
2254          return;
2255       end if;
2256
2257       --  Ignore insert of actions from inside default expression in the
2258       --  special preliminary analyze mode. Any insertions at this point
2259       --  have no relevance, since we are only doing the analyze to freeze
2260       --  the types of any static expressions. See section "Handling of
2261       --  Default Expressions" in the spec of package Sem for further details.
2262
2263       if In_Default_Expression then
2264          return;
2265       end if;
2266
2267       --  If the action derives from stuff inside a record, then the actions
2268       --  are attached to the current scope, to be inserted and analyzed on
2269       --  exit from the scope. The reason for this is that we may also
2270       --  be generating freeze actions at the same time, and they must
2271       --  eventually be elaborated in the correct order.
2272
2273       if Is_Record_Type (Current_Scope)
2274         and then not Is_Frozen (Current_Scope)
2275       then
2276          if No (Scope_Stack.Table
2277            (Scope_Stack.Last).Pending_Freeze_Actions)
2278          then
2279             Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
2280               Ins_Actions;
2281          else
2282             Append_List
2283               (Ins_Actions,
2284                Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
2285          end if;
2286
2287          return;
2288       end if;
2289
2290       --  We now intend to climb up the tree to find the right point to
2291       --  insert the actions. We start at Assoc_Node, unless this node is
2292       --  a subexpression in which case we start with its parent. We do this
2293       --  for two reasons. First it speeds things up. Second, if Assoc_Node
2294       --  is itself one of the special nodes like N_And_Then, then we assume
2295       --  that an initial request to insert actions for such a node does not
2296       --  expect the actions to get deposited in the node for later handling
2297       --  when the node is expanded, since clearly the node is being dealt
2298       --  with by the caller. Note that in the subexpression case, N is
2299       --  always the child we came from.
2300
2301       --  N_Raise_xxx_Error is an annoying special case, it is a statement
2302       --  if it has type Standard_Void_Type, and a subexpression otherwise.
2303       --  otherwise. Procedure attribute references are also statements.
2304
2305       if Nkind (Assoc_Node) in N_Subexpr
2306         and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
2307                    or else Etype (Assoc_Node) /= Standard_Void_Type)
2308         and then (Nkind (Assoc_Node) /= N_Attribute_Reference
2309                    or else
2310                      not Is_Procedure_Attribute_Name
2311                            (Attribute_Name (Assoc_Node)))
2312       then
2313          P := Assoc_Node;             -- ??? does not agree with above!
2314          N := Parent (Assoc_Node);
2315
2316       --  Non-subexpression case. Note that N is initially Empty in this
2317       --  case (N is only guaranteed Non-Empty in the subexpr case).
2318
2319       else
2320          P := Assoc_Node;
2321          N := Empty;
2322       end if;
2323
2324       --  Capture root of the transient scope
2325
2326       if Scope_Is_Transient then
2327          Wrapped_Node := Node_To_Be_Wrapped;
2328       end if;
2329
2330       loop
2331          pragma Assert (Present (P));
2332
2333          case Nkind (P) is
2334
2335             --  Case of right operand of AND THEN or OR ELSE. Put the actions
2336             --  in the Actions field of the right operand. They will be moved
2337             --  out further when the AND THEN or OR ELSE operator is expanded.
2338             --  Nothing special needs to be done for the left operand since
2339             --  in that case the actions are executed unconditionally.
2340
2341             when N_And_Then | N_Or_Else =>
2342                if N = Right_Opnd (P) then
2343                   if Present (Actions (P)) then
2344                      Insert_List_After_And_Analyze
2345                       (Last (Actions (P)), Ins_Actions);
2346                   else
2347                      Set_Actions (P, Ins_Actions);
2348                      Analyze_List (Actions (P));
2349                   end if;
2350
2351                   return;
2352                end if;
2353
2354             --  Then or Else operand of conditional expression. Add actions to
2355             --  Then_Actions or Else_Actions field as appropriate. The actions
2356             --  will be moved further out when the conditional is expanded.
2357
2358             when N_Conditional_Expression =>
2359                declare
2360                   ThenX : constant Node_Id := Next (First (Expressions (P)));
2361                   ElseX : constant Node_Id := Next (ThenX);
2362
2363                begin
2364                   --  Actions belong to the then expression, temporarily
2365                   --  place them as Then_Actions of the conditional expr.
2366                   --  They will be moved to the proper place later when
2367                   --  the conditional expression is expanded.
2368
2369                   if N = ThenX then
2370                      if Present (Then_Actions (P)) then
2371                         Insert_List_After_And_Analyze
2372                           (Last (Then_Actions (P)), Ins_Actions);
2373                      else
2374                         Set_Then_Actions (P, Ins_Actions);
2375                         Analyze_List (Then_Actions (P));
2376                      end if;
2377
2378                      return;
2379
2380                   --  Actions belong to the else expression, temporarily
2381                   --  place them as Else_Actions of the conditional expr.
2382                   --  They will be moved to the proper place later when
2383                   --  the conditional expression is expanded.
2384
2385                   elsif N = ElseX then
2386                      if Present (Else_Actions (P)) then
2387                         Insert_List_After_And_Analyze
2388                           (Last (Else_Actions (P)), Ins_Actions);
2389                      else
2390                         Set_Else_Actions (P, Ins_Actions);
2391                         Analyze_List (Else_Actions (P));
2392                      end if;
2393
2394                      return;
2395
2396                   --  Actions belong to the condition. In this case they are
2397                   --  unconditionally executed, and so we can continue the
2398                   --  search for the proper insert point.
2399
2400                   else
2401                      null;
2402                   end if;
2403                end;
2404
2405             --  Case of appearing in the condition of a while expression or
2406             --  elsif. We insert the actions into the Condition_Actions field.
2407             --  They will be moved further out when the while loop or elsif
2408             --  is analyzed.
2409
2410             when N_Iteration_Scheme |
2411                  N_Elsif_Part
2412             =>
2413                if N = Condition (P) then
2414                   if Present (Condition_Actions (P)) then
2415                      Insert_List_After_And_Analyze
2416                        (Last (Condition_Actions (P)), Ins_Actions);
2417                   else
2418                      Set_Condition_Actions (P, Ins_Actions);
2419
2420                      --  Set the parent of the insert actions explicitly.
2421                      --  This is not a syntactic field, but we need the
2422                      --  parent field set, in particular so that freeze
2423                      --  can understand that it is dealing with condition
2424                      --  actions, and properly insert the freezing actions.
2425
2426                      Set_Parent (Ins_Actions, P);
2427                      Analyze_List (Condition_Actions (P));
2428                   end if;
2429
2430                   return;
2431                end if;
2432
2433             --  Statements, declarations, pragmas, representation clauses
2434
2435             when
2436                --  Statements
2437
2438                N_Procedure_Call_Statement               |
2439                N_Statement_Other_Than_Procedure_Call    |
2440
2441                --  Pragmas
2442
2443                N_Pragma                                 |
2444
2445                --  Representation_Clause
2446
2447                N_At_Clause                              |
2448                N_Attribute_Definition_Clause            |
2449                N_Enumeration_Representation_Clause      |
2450                N_Record_Representation_Clause           |
2451
2452                --  Declarations
2453
2454                N_Abstract_Subprogram_Declaration        |
2455                N_Entry_Body                             |
2456                N_Exception_Declaration                  |
2457                N_Exception_Renaming_Declaration         |
2458                N_Formal_Abstract_Subprogram_Declaration |
2459                N_Formal_Concrete_Subprogram_Declaration |
2460                N_Formal_Object_Declaration              |
2461                N_Formal_Type_Declaration                |
2462                N_Full_Type_Declaration                  |
2463                N_Function_Instantiation                 |
2464                N_Generic_Function_Renaming_Declaration  |
2465                N_Generic_Package_Declaration            |
2466                N_Generic_Package_Renaming_Declaration   |
2467                N_Generic_Procedure_Renaming_Declaration |
2468                N_Generic_Subprogram_Declaration         |
2469                N_Implicit_Label_Declaration             |
2470                N_Incomplete_Type_Declaration            |
2471                N_Number_Declaration                     |
2472                N_Object_Declaration                     |
2473                N_Object_Renaming_Declaration            |
2474                N_Package_Body                           |
2475                N_Package_Body_Stub                      |
2476                N_Package_Declaration                    |
2477                N_Package_Instantiation                  |
2478                N_Package_Renaming_Declaration           |
2479                N_Private_Extension_Declaration          |
2480                N_Private_Type_Declaration               |
2481                N_Procedure_Instantiation                |
2482                N_Protected_Body_Stub                    |
2483                N_Protected_Type_Declaration             |
2484                N_Single_Task_Declaration                |
2485                N_Subprogram_Body                        |
2486                N_Subprogram_Body_Stub                   |
2487                N_Subprogram_Declaration                 |
2488                N_Subprogram_Renaming_Declaration        |
2489                N_Subtype_Declaration                    |
2490                N_Task_Body                              |
2491                N_Task_Body_Stub                         |
2492                N_Task_Type_Declaration                  |
2493
2494                --  Freeze entity behaves like a declaration or statement
2495
2496                N_Freeze_Entity
2497             =>
2498                --  Do not insert here if the item is not a list member (this
2499                --  happens for example with a triggering statement, and the
2500                --  proper approach is to insert before the entire select).
2501
2502                if not Is_List_Member (P) then
2503                   null;
2504
2505                --  Do not insert if parent of P is an N_Component_Association
2506                --  node (i.e. we are in the context of an N_Aggregate or
2507                --  N_Extension_Aggregate node. In this case we want to insert
2508                --  before the entire aggregate.
2509
2510                elsif Nkind (Parent (P)) = N_Component_Association then
2511                   null;
2512
2513                --  Do not insert if the parent of P is either an N_Variant
2514                --  node or an N_Record_Definition node, meaning in either
2515                --  case that P is a member of a component list, and that
2516                --  therefore the actions should be inserted outside the
2517                --  complete record declaration.
2518
2519                elsif Nkind (Parent (P)) = N_Variant
2520                  or else Nkind (Parent (P)) = N_Record_Definition
2521                then
2522                   null;
2523
2524                --  Do not insert freeze nodes within the loop generated for
2525                --  an aggregate, because they may be elaborated too late for
2526                --  subsequent use in the back end: within a package spec the
2527                --  loop is part of the elaboration procedure and is only
2528                --  elaborated during the second pass.
2529                --  If the loop comes from source, or the entity is local to
2530                --  the loop itself it must remain within.
2531
2532                elsif Nkind (Parent (P)) = N_Loop_Statement
2533                  and then not Comes_From_Source (Parent (P))
2534                  and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
2535                  and then
2536                    Scope (Entity (First (Ins_Actions))) /= Current_Scope
2537                then
2538                   null;
2539
2540                --  Otherwise we can go ahead and do the insertion
2541
2542                elsif P = Wrapped_Node then
2543                   Store_Before_Actions_In_Scope (Ins_Actions);
2544                   return;
2545
2546                else
2547                   Insert_List_Before_And_Analyze (P, Ins_Actions);
2548                   return;
2549                end if;
2550
2551             --  A special case, N_Raise_xxx_Error can act either as a
2552             --  statement or a subexpression. We tell the difference
2553             --  by looking at the Etype. It is set to Standard_Void_Type
2554             --  in the statement case.
2555
2556             when
2557                N_Raise_xxx_Error =>
2558                   if Etype (P) = Standard_Void_Type then
2559                      if  P = Wrapped_Node then
2560                         Store_Before_Actions_In_Scope (Ins_Actions);
2561                      else
2562                         Insert_List_Before_And_Analyze (P, Ins_Actions);
2563                      end if;
2564
2565                      return;
2566
2567                   --  In the subexpression case, keep climbing
2568
2569                   else
2570                      null;
2571                   end if;
2572
2573             --  If a component association appears within a loop created for
2574             --  an array aggregate, attach the actions to the association so
2575             --  they can be subsequently inserted within the loop. For other
2576             --  component associations insert outside of the aggregate. For
2577             --  an association that will generate a loop, its Loop_Actions
2578             --  attribute is already initialized (see exp_aggr.adb).
2579
2580             --  The list of loop_actions can in turn generate additional ones,
2581             --  that are inserted before the associated node. If the associated
2582             --  node is outside the aggregate, the new actions are collected
2583             --  at the end of the loop actions, to respect the order in which
2584             --  they are to be elaborated.
2585
2586             when
2587                N_Component_Association =>
2588                   if Nkind (Parent (P)) = N_Aggregate
2589                     and then Present (Loop_Actions (P))
2590                   then
2591                      if Is_Empty_List (Loop_Actions (P)) then
2592                         Set_Loop_Actions (P, Ins_Actions);
2593                         Analyze_List (Ins_Actions);
2594
2595                      else
2596                         declare
2597                            Decl : Node_Id;
2598
2599                         begin
2600                            --  Check whether these actions were generated
2601                            --  by a declaration that is part of the loop_
2602                            --  actions for the component_association.
2603
2604                            Decl := Assoc_Node;
2605                            while Present (Decl) loop
2606                               exit when Parent (Decl) = P
2607                                 and then Is_List_Member (Decl)
2608                                 and then
2609                                   List_Containing (Decl) = Loop_Actions (P);
2610                               Decl := Parent (Decl);
2611                            end loop;
2612
2613                            if Present (Decl) then
2614                               Insert_List_Before_And_Analyze
2615                                 (Decl, Ins_Actions);
2616                            else
2617                               Insert_List_After_And_Analyze
2618                                 (Last (Loop_Actions (P)), Ins_Actions);
2619                            end if;
2620                         end;
2621                      end if;
2622
2623                      return;
2624
2625                   else
2626                      null;
2627                   end if;
2628
2629             --  Another special case, an attribute denoting a procedure call
2630
2631             when
2632                N_Attribute_Reference =>
2633                   if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
2634                      if P = Wrapped_Node then
2635                         Store_Before_Actions_In_Scope (Ins_Actions);
2636                      else
2637                         Insert_List_Before_And_Analyze (P, Ins_Actions);
2638                      end if;
2639
2640                      return;
2641
2642                   --  In the subexpression case, keep climbing
2643
2644                   else
2645                      null;
2646                   end if;
2647
2648             --  For all other node types, keep climbing tree
2649
2650             when
2651                N_Abortable_Part                         |
2652                N_Accept_Alternative                     |
2653                N_Access_Definition                      |
2654                N_Access_Function_Definition             |
2655                N_Access_Procedure_Definition            |
2656                N_Access_To_Object_Definition            |
2657                N_Aggregate                              |
2658                N_Allocator                              |
2659                N_Case_Statement_Alternative             |
2660                N_Character_Literal                      |
2661                N_Compilation_Unit                       |
2662                N_Compilation_Unit_Aux                   |
2663                N_Component_Clause                       |
2664                N_Component_Declaration                  |
2665                N_Component_Definition                   |
2666                N_Component_List                         |
2667                N_Constrained_Array_Definition           |
2668                N_Decimal_Fixed_Point_Definition         |
2669                N_Defining_Character_Literal             |
2670                N_Defining_Identifier                    |
2671                N_Defining_Operator_Symbol               |
2672                N_Defining_Program_Unit_Name             |
2673                N_Delay_Alternative                      |
2674                N_Delta_Constraint                       |
2675                N_Derived_Type_Definition                |
2676                N_Designator                             |
2677                N_Digits_Constraint                      |
2678                N_Discriminant_Association               |
2679                N_Discriminant_Specification             |
2680                N_Empty                                  |
2681                N_Entry_Body_Formal_Part                 |
2682                N_Entry_Call_Alternative                 |
2683                N_Entry_Declaration                      |
2684                N_Entry_Index_Specification              |
2685                N_Enumeration_Type_Definition            |
2686                N_Error                                  |
2687                N_Exception_Handler                      |
2688                N_Expanded_Name                          |
2689                N_Explicit_Dereference                   |
2690                N_Extension_Aggregate                    |
2691                N_Floating_Point_Definition              |
2692                N_Formal_Decimal_Fixed_Point_Definition  |
2693                N_Formal_Derived_Type_Definition         |
2694                N_Formal_Discrete_Type_Definition        |
2695                N_Formal_Floating_Point_Definition       |
2696                N_Formal_Modular_Type_Definition         |
2697                N_Formal_Ordinary_Fixed_Point_Definition |
2698                N_Formal_Package_Declaration             |
2699                N_Formal_Private_Type_Definition         |
2700                N_Formal_Signed_Integer_Type_Definition  |
2701                N_Function_Call                          |
2702                N_Function_Specification                 |
2703                N_Generic_Association                    |
2704                N_Handled_Sequence_Of_Statements         |
2705                N_Identifier                             |
2706                N_In                                     |
2707                N_Index_Or_Discriminant_Constraint       |
2708                N_Indexed_Component                      |
2709                N_Integer_Literal                        |
2710                N_Itype_Reference                        |
2711                N_Label                                  |
2712                N_Loop_Parameter_Specification           |
2713                N_Mod_Clause                             |
2714                N_Modular_Type_Definition                |
2715                N_Not_In                                 |
2716                N_Null                                   |
2717                N_Op_Abs                                 |
2718                N_Op_Add                                 |
2719                N_Op_And                                 |
2720                N_Op_Concat                              |
2721                N_Op_Divide                              |
2722                N_Op_Eq                                  |
2723                N_Op_Expon                               |
2724                N_Op_Ge                                  |
2725                N_Op_Gt                                  |
2726                N_Op_Le                                  |
2727                N_Op_Lt                                  |
2728                N_Op_Minus                               |
2729                N_Op_Mod                                 |
2730                N_Op_Multiply                            |
2731                N_Op_Ne                                  |
2732                N_Op_Not                                 |
2733                N_Op_Or                                  |
2734                N_Op_Plus                                |
2735                N_Op_Rem                                 |
2736                N_Op_Rotate_Left                         |
2737                N_Op_Rotate_Right                        |
2738                N_Op_Shift_Left                          |
2739                N_Op_Shift_Right                         |
2740                N_Op_Shift_Right_Arithmetic              |
2741                N_Op_Subtract                            |
2742                N_Op_Xor                                 |
2743                N_Operator_Symbol                        |
2744                N_Ordinary_Fixed_Point_Definition        |
2745                N_Others_Choice                          |
2746                N_Package_Specification                  |
2747                N_Parameter_Association                  |
2748                N_Parameter_Specification                |
2749                N_Pop_Constraint_Error_Label             |
2750                N_Pop_Program_Error_Label                |
2751                N_Pop_Storage_Error_Label                |
2752                N_Pragma_Argument_Association            |
2753                N_Procedure_Specification                |
2754                N_Protected_Body                         |
2755                N_Protected_Definition                   |
2756                N_Push_Constraint_Error_Label            |
2757                N_Push_Program_Error_Label               |
2758                N_Push_Storage_Error_Label               |
2759                N_Qualified_Expression                   |
2760                N_Range                                  |
2761                N_Range_Constraint                       |
2762                N_Real_Literal                           |
2763                N_Real_Range_Specification               |
2764                N_Record_Definition                      |
2765                N_Reference                              |
2766                N_Selected_Component                     |
2767                N_Signed_Integer_Type_Definition         |
2768                N_Single_Protected_Declaration           |
2769                N_Slice                                  |
2770                N_String_Literal                         |
2771                N_Subprogram_Info                        |
2772                N_Subtype_Indication                     |
2773                N_Subunit                                |
2774                N_Task_Definition                        |
2775                N_Terminate_Alternative                  |
2776                N_Triggering_Alternative                 |
2777                N_Type_Conversion                        |
2778                N_Unchecked_Expression                   |
2779                N_Unchecked_Type_Conversion              |
2780                N_Unconstrained_Array_Definition         |
2781                N_Unused_At_End                          |
2782                N_Unused_At_Start                        |
2783                N_Use_Package_Clause                     |
2784                N_Use_Type_Clause                        |
2785                N_Variant                                |
2786                N_Variant_Part                           |
2787                N_Validate_Unchecked_Conversion          |
2788                N_With_Clause
2789             =>
2790                null;
2791
2792          end case;
2793
2794          --  Make sure that inserted actions stay in the transient scope
2795
2796          if P = Wrapped_Node then
2797             Store_Before_Actions_In_Scope (Ins_Actions);
2798             return;
2799          end if;
2800
2801          --  If we fall through above tests, keep climbing tree
2802
2803          N := P;
2804
2805          if Nkind (Parent (N)) = N_Subunit then
2806
2807             --  This is the proper body corresponding to a stub. Insertion
2808             --  must be done at the point of the stub, which is in the decla-
2809             --  tive part of the parent unit.
2810
2811             P := Corresponding_Stub (Parent (N));
2812
2813          else
2814             P := Parent (N);
2815          end if;
2816       end loop;
2817    end Insert_Actions;
2818
2819    --  Version with check(s) suppressed
2820
2821    procedure Insert_Actions
2822      (Assoc_Node  : Node_Id;
2823       Ins_Actions : List_Id;
2824       Suppress    : Check_Id)
2825    is
2826    begin
2827       if Suppress = All_Checks then
2828          declare
2829             Svg : constant Suppress_Array := Scope_Suppress;
2830          begin
2831             Scope_Suppress := (others => True);
2832             Insert_Actions (Assoc_Node, Ins_Actions);
2833             Scope_Suppress := Svg;
2834          end;
2835
2836       else
2837          declare
2838             Svg : constant Boolean := Scope_Suppress (Suppress);
2839          begin
2840             Scope_Suppress (Suppress) := True;
2841             Insert_Actions (Assoc_Node, Ins_Actions);
2842             Scope_Suppress (Suppress) := Svg;
2843          end;
2844       end if;
2845    end Insert_Actions;
2846
2847    --------------------------
2848    -- Insert_Actions_After --
2849    --------------------------
2850
2851    procedure Insert_Actions_After
2852      (Assoc_Node  : Node_Id;
2853       Ins_Actions : List_Id)
2854    is
2855    begin
2856       if Scope_Is_Transient
2857         and then Assoc_Node = Node_To_Be_Wrapped
2858       then
2859          Store_After_Actions_In_Scope (Ins_Actions);
2860       else
2861          Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
2862       end if;
2863    end Insert_Actions_After;
2864
2865    ---------------------------------
2866    -- Insert_Library_Level_Action --
2867    ---------------------------------
2868
2869    procedure Insert_Library_Level_Action (N : Node_Id) is
2870       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2871
2872    begin
2873       Push_Scope (Cunit_Entity (Main_Unit));
2874       --  ??? should this be Current_Sem_Unit instead of Main_Unit?
2875
2876       if No (Actions (Aux)) then
2877          Set_Actions (Aux, New_List (N));
2878       else
2879          Append (N, Actions (Aux));
2880       end if;
2881
2882       Analyze (N);
2883       Pop_Scope;
2884    end Insert_Library_Level_Action;
2885
2886    ----------------------------------
2887    -- Insert_Library_Level_Actions --
2888    ----------------------------------
2889
2890    procedure Insert_Library_Level_Actions (L : List_Id) is
2891       Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
2892
2893    begin
2894       if Is_Non_Empty_List (L) then
2895          Push_Scope (Cunit_Entity (Main_Unit));
2896          --  ??? should this be Current_Sem_Unit instead of Main_Unit?
2897
2898          if No (Actions (Aux)) then
2899             Set_Actions (Aux, L);
2900             Analyze_List (L);
2901          else
2902             Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
2903          end if;
2904
2905          Pop_Scope;
2906       end if;
2907    end Insert_Library_Level_Actions;
2908
2909    ----------------------
2910    -- Inside_Init_Proc --
2911    ----------------------
2912
2913    function Inside_Init_Proc return Boolean is
2914       S : Entity_Id;
2915
2916    begin
2917       S := Current_Scope;
2918       while Present (S)
2919         and then S /= Standard_Standard
2920       loop
2921          if Is_Init_Proc (S) then
2922             return True;
2923          else
2924             S := Scope (S);
2925          end if;
2926       end loop;
2927
2928       return False;
2929    end Inside_Init_Proc;
2930
2931    ----------------------------
2932    -- Is_All_Null_Statements --
2933    ----------------------------
2934
2935    function Is_All_Null_Statements (L : List_Id) return Boolean is
2936       Stm : Node_Id;
2937
2938    begin
2939       Stm := First (L);
2940       while Present (Stm) loop
2941          if Nkind (Stm) /= N_Null_Statement then
2942             return False;
2943          end if;
2944
2945          Next (Stm);
2946       end loop;
2947
2948       return True;
2949    end Is_All_Null_Statements;
2950
2951    -----------------------------------------
2952    -- Is_Predefined_Dispatching_Operation --
2953    -----------------------------------------
2954
2955    function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean
2956    is
2957       TSS_Name : TSS_Name_Type;
2958
2959    begin
2960       if not Is_Dispatching_Operation (E) then
2961          return False;
2962       end if;
2963
2964       Get_Name_String (Chars (E));
2965
2966       if Name_Len > TSS_Name_Type'Last then
2967          TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
2968                                      .. Name_Len));
2969          if Chars (E)        = Name_uSize
2970            or else Chars (E) = Name_uAlignment
2971            or else TSS_Name  = TSS_Stream_Read
2972            or else TSS_Name  = TSS_Stream_Write
2973            or else TSS_Name  = TSS_Stream_Input
2974            or else TSS_Name  = TSS_Stream_Output
2975            or else
2976              (Chars (E) = Name_Op_Eq
2977                 and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
2978            or else Chars (E) = Name_uAssign
2979            or else TSS_Name  = TSS_Deep_Adjust
2980            or else TSS_Name  = TSS_Deep_Finalize
2981            or else (Ada_Version >= Ada_05
2982              and then (Chars (E) = Name_uDisp_Asynchronous_Select
2983                or else Chars (E) = Name_uDisp_Conditional_Select
2984                or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
2985                or else Chars (E) = Name_uDisp_Get_Task_Id
2986                or else Chars (E) = Name_uDisp_Timed_Select))
2987          then
2988             return True;
2989          end if;
2990       end if;
2991
2992       return False;
2993    end Is_Predefined_Dispatching_Operation;
2994
2995    ----------------------------------
2996    -- Is_Possibly_Unaligned_Object --
2997    ----------------------------------
2998
2999    function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
3000       T  : constant Entity_Id := Etype (N);
3001
3002    begin
3003       --  If renamed object, apply test to underlying object
3004
3005       if Is_Entity_Name (N)
3006         and then Is_Object (Entity (N))
3007         and then Present (Renamed_Object (Entity (N)))
3008       then
3009          return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
3010       end if;
3011
3012       --  Tagged and controlled types and aliased types are always aligned,
3013       --  as are concurrent types.
3014
3015       if Is_Aliased (T)
3016         or else Has_Controlled_Component (T)
3017         or else Is_Concurrent_Type (T)
3018         or else Is_Tagged_Type (T)
3019         or else Is_Controlled (T)
3020       then
3021          return False;
3022       end if;
3023
3024       --  If this is an element of a packed array, may be unaligned
3025
3026       if Is_Ref_To_Bit_Packed_Array (N) then
3027          return True;
3028       end if;
3029
3030       --  Case of component reference
3031
3032       if Nkind (N) = N_Selected_Component then
3033          declare
3034             P : constant Node_Id   := Prefix (N);
3035             C : constant Entity_Id := Entity (Selector_Name (N));
3036             M : Nat;
3037             S : Nat;
3038
3039          begin
3040             --  If component reference is for an array with non-static bounds,
3041             --  then it is always aligned: we can only process unaligned
3042             --  arrays with static bounds (more accurately bounds known at
3043             --  compile time).
3044
3045             if Is_Array_Type (T)
3046               and then not Compile_Time_Known_Bounds (T)
3047             then
3048                return False;
3049             end if;
3050
3051             --  If component is aliased, it is definitely properly aligned
3052
3053             if Is_Aliased (C) then
3054                return False;
3055             end if;
3056
3057             --  If component is for a type implemented as a scalar, and the
3058             --  record is packed, and the component is other than the first
3059             --  component of the record, then the component may be unaligned.
3060
3061             if Is_Packed (Etype (P))
3062               and then Represented_As_Scalar (Etype (C))
3063               and then First_Entity (Scope (C)) /= C
3064             then
3065                return True;
3066             end if;
3067
3068             --  Compute maximum possible alignment for T
3069
3070             --  If alignment is known, then that settles things
3071
3072             if Known_Alignment (T) then
3073                M := UI_To_Int (Alignment (T));
3074
3075             --  If alignment is not known, tentatively set max alignment
3076
3077             else
3078                M := Ttypes.Maximum_Alignment;
3079
3080                --  We can reduce this if the Esize is known since the default
3081                --  alignment will never be more than the smallest power of 2
3082                --  that does not exceed this Esize value.
3083
3084                if Known_Esize (T) then
3085                   S := UI_To_Int (Esize (T));
3086
3087                   while (M / 2) >= S loop
3088                      M := M / 2;
3089                   end loop;
3090                end if;
3091             end if;
3092
3093             --  If the component reference is for a record that has a specified
3094             --  alignment, and we either know it is too small, or cannot tell,
3095             --  then the component may be unaligned
3096
3097             if Known_Alignment (Etype (P))
3098               and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
3099               and then M > Alignment (Etype (P))
3100             then
3101                return True;
3102             end if;
3103
3104             --  Case of component clause present which may specify an
3105             --  unaligned position.
3106
3107             if Present (Component_Clause (C)) then
3108
3109                --  Otherwise we can do a test to make sure that the actual
3110                --  start position in the record, and the length, are both
3111                --  consistent with the required alignment. If not, we know
3112                --  that we are unaligned.
3113
3114                declare
3115                   Align_In_Bits : constant Nat := M * System_Storage_Unit;
3116                begin
3117                   if Component_Bit_Offset (C) mod Align_In_Bits /= 0
3118                     or else Esize (C) mod Align_In_Bits /= 0
3119                   then
3120                      return True;
3121                   end if;
3122                end;
3123             end if;
3124
3125             --  Otherwise, for a component reference, test prefix
3126
3127             return Is_Possibly_Unaligned_Object (P);
3128          end;
3129
3130       --  If not a component reference, must be aligned
3131
3132       else
3133          return False;
3134       end if;
3135    end Is_Possibly_Unaligned_Object;
3136
3137    ---------------------------------
3138    -- Is_Possibly_Unaligned_Slice --
3139    ---------------------------------
3140
3141    function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
3142    begin
3143       --  Go to renamed object
3144
3145       if Is_Entity_Name (N)
3146         and then Is_Object (Entity (N))
3147         and then Present (Renamed_Object (Entity (N)))
3148       then
3149          return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
3150       end if;
3151
3152       --  The reference must be a slice
3153
3154       if Nkind (N) /= N_Slice then
3155          return False;
3156       end if;
3157
3158       --  Always assume the worst for a nested record component with a
3159       --  component clause, which gigi/gcc does not appear to handle well.
3160       --  It is not clear why this special test is needed at all ???
3161
3162       if Nkind (Prefix (N)) = N_Selected_Component
3163         and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
3164         and then
3165           Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
3166       then
3167          return True;
3168       end if;
3169
3170       --  We only need to worry if the target has strict alignment
3171
3172       if not Target_Strict_Alignment then
3173          return False;
3174       end if;
3175
3176       --  If it is a slice, then look at the array type being sliced
3177
3178       declare
3179          Sarr : constant Node_Id := Prefix (N);
3180          --  Prefix of the slice, i.e. the array being sliced
3181
3182          Styp : constant Entity_Id := Etype (Prefix (N));
3183          --  Type of the array being sliced
3184
3185          Pref : Node_Id;
3186          Ptyp : Entity_Id;
3187
3188       begin
3189          --  The problems arise if the array object that is being sliced
3190          --  is a component of a record or array, and we cannot guarantee
3191          --  the alignment of the array within its containing object.
3192
3193          --  To investigate this, we look at successive prefixes to see
3194          --  if we have a worrisome indexed or selected component.
3195
3196          Pref := Sarr;
3197          loop
3198             --  Case of array is part of an indexed component reference
3199
3200             if Nkind (Pref) = N_Indexed_Component then
3201                Ptyp := Etype (Prefix (Pref));
3202
3203                --  The only problematic case is when the array is packed,
3204                --  in which case we really know nothing about the alignment
3205                --  of individual components.
3206
3207                if Is_Bit_Packed_Array (Ptyp) then
3208                   return True;
3209                end if;
3210
3211             --  Case of array is part of a selected component reference
3212
3213             elsif Nkind (Pref) = N_Selected_Component then
3214                Ptyp := Etype (Prefix (Pref));
3215
3216                --  We are definitely in trouble if the record in question
3217                --  has an alignment, and either we know this alignment is
3218                --  inconsistent with the alignment of the slice, or we
3219                --  don't know what the alignment of the slice should be.
3220
3221                if Known_Alignment (Ptyp)
3222                  and then (Unknown_Alignment (Styp)
3223                              or else Alignment (Styp) > Alignment (Ptyp))
3224                then
3225                   return True;
3226                end if;
3227
3228                --  We are in potential trouble if the record type is packed.
3229                --  We could special case when we know that the array is the
3230                --  first component, but that's not such a simple case ???
3231
3232                if Is_Packed (Ptyp) then
3233                   return True;
3234                end if;
3235
3236                --  We are in trouble if there is a component clause, and
3237                --  either we do not know the alignment of the slice, or
3238                --  the alignment of the slice is inconsistent with the
3239                --  bit position specified by the component clause.
3240
3241                declare
3242                   Field : constant Entity_Id := Entity (Selector_Name (Pref));
3243                begin
3244                   if Present (Component_Clause (Field))
3245                     and then
3246                       (Unknown_Alignment (Styp)
3247                         or else
3248                          (Component_Bit_Offset (Field) mod
3249                            (System_Storage_Unit * Alignment (Styp))) /= 0)
3250                   then
3251                      return True;
3252                   end if;
3253                end;
3254
3255             --  For cases other than selected or indexed components we
3256             --  know we are OK, since no issues arise over alignment.
3257
3258             else
3259                return False;
3260             end if;
3261
3262             --  We processed an indexed component or selected component
3263             --  reference that looked safe, so keep checking prefixes.
3264
3265             Pref := Prefix (Pref);
3266          end loop;
3267       end;
3268    end Is_Possibly_Unaligned_Slice;
3269
3270    --------------------------------
3271    -- Is_Ref_To_Bit_Packed_Array --
3272    --------------------------------
3273
3274    function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
3275       Result : Boolean;
3276       Expr   : Node_Id;
3277
3278    begin
3279       if Is_Entity_Name (N)
3280         and then Is_Object (Entity (N))
3281         and then Present (Renamed_Object (Entity (N)))
3282       then
3283          return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
3284       end if;
3285
3286       if Nkind (N) = N_Indexed_Component
3287            or else
3288          Nkind (N) = N_Selected_Component
3289       then
3290          if Is_Bit_Packed_Array (Etype (Prefix (N))) then
3291             Result := True;
3292          else
3293             Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
3294          end if;
3295
3296          if Result and then Nkind (N) = N_Indexed_Component then
3297             Expr := First (Expressions (N));
3298             while Present (Expr) loop
3299                Force_Evaluation (Expr);
3300                Next (Expr);
3301             end loop;
3302          end if;
3303
3304          return Result;
3305
3306       else
3307          return False;
3308       end if;
3309    end Is_Ref_To_Bit_Packed_Array;
3310
3311    --------------------------------
3312    -- Is_Ref_To_Bit_Packed_Slice --
3313    --------------------------------
3314
3315    function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
3316    begin
3317       if Nkind (N) = N_Type_Conversion then
3318          return Is_Ref_To_Bit_Packed_Slice (Expression (N));
3319
3320       elsif Is_Entity_Name (N)
3321         and then Is_Object (Entity (N))
3322         and then Present (Renamed_Object (Entity (N)))
3323       then
3324          return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
3325
3326       elsif Nkind (N) = N_Slice
3327         and then Is_Bit_Packed_Array (Etype (Prefix (N)))
3328       then
3329          return True;
3330
3331       elsif Nkind (N) = N_Indexed_Component
3332            or else
3333          Nkind (N) = N_Selected_Component
3334       then
3335          return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
3336
3337       else
3338          return False;
3339       end if;
3340    end Is_Ref_To_Bit_Packed_Slice;
3341
3342    -----------------------
3343    -- Is_Renamed_Object --
3344    -----------------------
3345
3346    function Is_Renamed_Object (N : Node_Id) return Boolean is
3347       Pnod : constant Node_Id   := Parent (N);
3348       Kind : constant Node_Kind := Nkind (Pnod);
3349
3350    begin
3351       if Kind = N_Object_Renaming_Declaration then
3352          return True;
3353
3354       elsif Kind = N_Indexed_Component
3355         or else Kind = N_Selected_Component
3356       then
3357          return Is_Renamed_Object (Pnod);
3358
3359       else
3360          return False;
3361       end if;
3362    end Is_Renamed_Object;
3363
3364    ----------------------------
3365    -- Is_Untagged_Derivation --
3366    ----------------------------
3367
3368    function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
3369    begin
3370       return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
3371                or else
3372              (Is_Private_Type (T) and then Present (Full_View (T))
3373                and then not Is_Tagged_Type (Full_View (T))
3374                and then Is_Derived_Type (Full_View (T))
3375                and then Etype (Full_View (T)) /= T);
3376    end Is_Untagged_Derivation;
3377
3378    --------------------
3379    -- Kill_Dead_Code --
3380    --------------------
3381
3382    procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
3383    begin
3384       if Present (N) then
3385          Remove_Warning_Messages (N);
3386
3387          if Warn then
3388             Error_Msg_F
3389               ("?this code can never be executed and has been deleted", N);
3390          end if;
3391
3392          --  Recurse into block statements and bodies to process declarations
3393          --  and statements
3394
3395          if Nkind (N) = N_Block_Statement
3396            or else Nkind (N) = N_Subprogram_Body
3397            or else Nkind (N) = N_Package_Body
3398          then
3399             Kill_Dead_Code
3400               (Declarations (N), False);
3401             Kill_Dead_Code
3402               (Statements (Handled_Statement_Sequence (N)));
3403
3404             if Nkind (N) = N_Subprogram_Body then
3405                Set_Is_Eliminated (Defining_Entity (N));
3406             end if;
3407
3408          elsif Nkind (N) = N_Package_Declaration then
3409             Kill_Dead_Code (Visible_Declarations (Specification (N)));
3410             Kill_Dead_Code (Private_Declarations (Specification (N)));
3411
3412             declare
3413                E : Entity_Id := First_Entity (Defining_Entity (N));
3414             begin
3415                while Present (E) loop
3416                   if Ekind (E) = E_Operator then
3417                      Set_Is_Eliminated (E);
3418                   end if;
3419
3420                   Next_Entity (E);
3421                end loop;
3422             end;
3423
3424          --  Recurse into composite statement to kill individual statements,
3425          --  in particular instantiations.
3426
3427          elsif Nkind (N) = N_If_Statement then
3428             Kill_Dead_Code (Then_Statements (N));
3429             Kill_Dead_Code (Elsif_Parts (N));
3430             Kill_Dead_Code (Else_Statements (N));
3431
3432          elsif Nkind (N) = N_Loop_Statement then
3433             Kill_Dead_Code (Statements (N));
3434
3435          elsif Nkind (N) = N_Case_Statement then
3436             declare
3437                Alt : Node_Id;
3438             begin
3439                Alt := First (Alternatives (N));
3440                while Present (Alt) loop
3441                   Kill_Dead_Code (Statements (Alt));
3442                   Next (Alt);
3443                end loop;
3444             end;
3445
3446          elsif Nkind (N) = N_Case_Statement_Alternative then
3447             Kill_Dead_Code (Statements (N));
3448
3449          --  Deal with dead instances caused by deleting instantiations
3450
3451          elsif Nkind (N) in N_Generic_Instantiation then
3452             Remove_Dead_Instance (N);
3453          end if;
3454
3455          Delete_Tree (N);
3456       end if;
3457    end Kill_Dead_Code;
3458
3459    --  Case where argument is a list of nodes to be killed
3460
3461    procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
3462       N : Node_Id;
3463       W : Boolean;
3464    begin
3465       W := Warn;
3466       if Is_Non_Empty_List (L) then
3467          loop
3468             N := Remove_Head (L);
3469             exit when No (N);
3470             Kill_Dead_Code (N, W);
3471             W := False;
3472          end loop;
3473       end if;
3474    end Kill_Dead_Code;
3475
3476    ------------------------
3477    -- Known_Non_Negative --
3478    ------------------------
3479
3480    function Known_Non_Negative (Opnd : Node_Id) return Boolean is
3481    begin
3482       if Is_OK_Static_Expression (Opnd)
3483         and then Expr_Value (Opnd) >= 0
3484       then
3485          return True;
3486
3487       else
3488          declare
3489             Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
3490
3491          begin
3492             return
3493               Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
3494          end;
3495       end if;
3496    end Known_Non_Negative;
3497
3498    --------------------
3499    -- Known_Non_Null --
3500    --------------------
3501
3502    function Known_Non_Null (N : Node_Id) return Boolean is
3503    begin
3504       --  Checks for case where N is an entity reference
3505
3506       if Is_Entity_Name (N) and then Present (Entity (N)) then
3507          declare
3508             E   : constant Entity_Id := Entity (N);
3509             Op  : Node_Kind;
3510             Val : Node_Id;
3511
3512          begin
3513             --  First check if we are in decisive conditional
3514
3515             Get_Current_Value_Condition (N, Op, Val);
3516
3517             if Nkind (Val) = N_Null then
3518                if Op = N_Op_Eq then
3519                   return False;
3520                elsif Op = N_Op_Ne then
3521                   return True;
3522                end if;
3523             end if;
3524
3525             --  If OK to do replacement, test Is_Known_Non_Null flag
3526
3527             if OK_To_Do_Constant_Replacement (E) then
3528                return Is_Known_Non_Null (E);
3529
3530             --  Otherwise if not safe to do replacement, then say so
3531
3532             else
3533                return False;
3534             end if;
3535          end;
3536
3537       --  True if access attribute
3538
3539       elsif Nkind (N) = N_Attribute_Reference
3540         and then (Attribute_Name (N) = Name_Access
3541                     or else
3542                   Attribute_Name (N) = Name_Unchecked_Access
3543                     or else
3544                   Attribute_Name (N) = Name_Unrestricted_Access)
3545       then
3546          return True;
3547
3548       --  True if allocator
3549
3550       elsif Nkind (N) = N_Allocator then
3551          return True;
3552
3553       --  For a conversion, true if expression is known non-null
3554
3555       elsif Nkind (N) = N_Type_Conversion then
3556          return Known_Non_Null (Expression (N));
3557
3558       --  Above are all cases where the value could be determined to be
3559       --  non-null. In all other cases, we don't know, so return False.
3560
3561       else
3562          return False;
3563       end if;
3564    end Known_Non_Null;
3565
3566    ----------------
3567    -- Known_Null --
3568    ----------------
3569
3570    function Known_Null (N : Node_Id) return Boolean is
3571    begin
3572       --  Checks for case where N is an entity reference
3573
3574       if Is_Entity_Name (N) and then Present (Entity (N)) then
3575          declare
3576             E   : constant Entity_Id := Entity (N);
3577             Op  : Node_Kind;
3578             Val : Node_Id;
3579
3580          begin
3581             --  First check if we are in decisive conditional
3582
3583             Get_Current_Value_Condition (N, Op, Val);
3584
3585             if Nkind (Val) = N_Null then
3586                if Op = N_Op_Eq then
3587                   return True;
3588                elsif Op = N_Op_Ne then
3589                   return False;
3590                end if;
3591             end if;
3592
3593             --  If OK to do replacement, test Is_Known_Null flag
3594
3595             if OK_To_Do_Constant_Replacement (E) then
3596                return Is_Known_Null (E);
3597
3598             --  Otherwise if not safe to do replacement, then say so
3599
3600             else
3601                return False;
3602             end if;
3603          end;
3604
3605       --  True if explicit reference to null
3606
3607       elsif Nkind (N) = N_Null then
3608          return True;
3609
3610       --  For a conversion, true if expression is known null
3611
3612       elsif Nkind (N) = N_Type_Conversion then
3613          return Known_Null (Expression (N));
3614
3615       --  Above are all cases where the value could be determined to be null.
3616       --  In all other cases, we don't know, so return False.
3617
3618       else
3619          return False;
3620       end if;
3621    end Known_Null;
3622
3623    -----------------------------
3624    -- Make_CW_Equivalent_Type --
3625    -----------------------------
3626
3627    --  Create a record type used as an equivalent of any member
3628    --  of the class which takes its size from exp.
3629
3630    --  Generate the following code:
3631
3632    --   type Equiv_T is record
3633    --     _parent :  T (List of discriminant constaints taken from Exp);
3634    --     Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3635    --   end Equiv_T;
3636    --
3637    --   ??? Note that this type does not guarantee same alignment as all
3638    --   derived types
3639
3640    function Make_CW_Equivalent_Type
3641      (T : Entity_Id;
3642       E : Node_Id) return Entity_Id
3643    is
3644       Loc         : constant Source_Ptr := Sloc (E);
3645       Root_Typ    : constant Entity_Id  := Root_Type (T);
3646       List_Def    : constant List_Id    := Empty_List;
3647       Comp_List   : constant List_Id    := New_List;
3648       Equiv_Type  : Entity_Id;
3649       Range_Type  : Entity_Id;
3650       Str_Type    : Entity_Id;
3651       Constr_Root : Entity_Id;
3652       Sizexpr     : Node_Id;
3653
3654    begin
3655       if not Has_Discriminants (Root_Typ) then
3656          Constr_Root := Root_Typ;
3657       else
3658          Constr_Root :=
3659            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
3660
3661          --  subtype cstr__n is T (List of discr constraints taken from Exp)
3662
3663          Append_To (List_Def,
3664            Make_Subtype_Declaration (Loc,
3665              Defining_Identifier => Constr_Root,
3666                Subtype_Indication =>
3667                  Make_Subtype_From_Expr (E, Root_Typ)));
3668       end if;
3669
3670       --  Generate the range subtype declaration
3671
3672       Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
3673
3674       if not Is_Interface (Root_Typ) then
3675          --  subtype rg__xx is
3676          --    Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3677
3678          Sizexpr :=
3679            Make_Op_Subtract (Loc,
3680              Left_Opnd =>
3681                Make_Attribute_Reference (Loc,
3682                  Prefix =>
3683                    OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3684                  Attribute_Name => Name_Size),
3685              Right_Opnd =>
3686                Make_Attribute_Reference (Loc,
3687                  Prefix => New_Reference_To (Constr_Root, Loc),
3688                  Attribute_Name => Name_Object_Size));
3689       else
3690          --  subtype rg__xx is
3691          --    Storage_Offset range 1 .. Expr'size / Storage_Unit
3692
3693          Sizexpr :=
3694            Make_Attribute_Reference (Loc,
3695              Prefix =>
3696                OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
3697              Attribute_Name => Name_Size);
3698       end if;
3699
3700       Set_Paren_Count (Sizexpr, 1);
3701
3702       Append_To (List_Def,
3703         Make_Subtype_Declaration (Loc,
3704           Defining_Identifier => Range_Type,
3705           Subtype_Indication =>
3706             Make_Subtype_Indication (Loc,
3707               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
3708               Constraint => Make_Range_Constraint (Loc,
3709                 Range_Expression =>
3710                   Make_Range (Loc,
3711                     Low_Bound => Make_Integer_Literal (Loc, 1),
3712                     High_Bound =>
3713                       Make_Op_Divide (Loc,
3714                         Left_Opnd => Sizexpr,
3715                         Right_Opnd => Make_Integer_Literal (Loc,
3716                             Intval => System_Storage_Unit)))))));
3717
3718       --  subtype str__nn is Storage_Array (rg__x);
3719
3720       Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
3721       Append_To (List_Def,
3722         Make_Subtype_Declaration (Loc,
3723           Defining_Identifier => Str_Type,
3724           Subtype_Indication =>
3725             Make_Subtype_Indication (Loc,
3726               Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
3727               Constraint =>
3728                 Make_Index_Or_Discriminant_Constraint (Loc,
3729                   Constraints =>
3730                     New_List (New_Reference_To (Range_Type, Loc))))));
3731
3732       --  type Equiv_T is record
3733       --    [ _parent : Tnn; ]
3734       --    E : Str_Type;
3735       --  end Equiv_T;
3736
3737       Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3738
3739       --  When the target requires front-end layout, it's necessary to allow
3740       --  the equivalent type to be frozen so that layout can occur (when the
3741       --  associated class-wide subtype is frozen, the equivalent type will
3742       --  be frozen, see freeze.adb). For other targets, Gigi wants to have
3743       --  the equivalent type marked as frozen and deals with this type itself.
3744       --  In the Gigi case this will also avoid the generation of an init
3745       --  procedure for the type.
3746
3747       if not Frontend_Layout_On_Target then
3748          Set_Is_Frozen (Equiv_Type);
3749       end if;
3750
3751       Set_Ekind (Equiv_Type, E_Record_Type);
3752       Set_Parent_Subtype (Equiv_Type, Constr_Root);
3753
3754       if not Is_Interface (Root_Typ) then
3755          Append_To (Comp_List,
3756            Make_Component_Declaration (Loc,
3757              Defining_Identifier =>
3758                Make_Defining_Identifier (Loc, Name_uParent),
3759              Component_Definition =>
3760                Make_Component_Definition (Loc,
3761                  Aliased_Present    => False,
3762                  Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
3763       end if;
3764
3765       Append_To (Comp_List,
3766         Make_Component_Declaration (Loc,
3767           Defining_Identifier =>
3768             Make_Defining_Identifier (Loc,
3769               Chars => New_Internal_Name ('C')),
3770           Component_Definition =>
3771             Make_Component_Definition (Loc,
3772               Aliased_Present    => False,
3773               Subtype_Indication => New_Reference_To (Str_Type, Loc))));
3774
3775       Append_To (List_Def,
3776         Make_Full_Type_Declaration (Loc,
3777           Defining_Identifier => Equiv_Type,
3778           Type_Definition =>
3779             Make_Record_Definition (Loc,
3780               Component_List =>
3781                 Make_Component_List (Loc,
3782                   Component_Items => Comp_List,
3783                   Variant_Part    => Empty))));
3784
3785       --  Suppress all checks during the analysis of the expanded code
3786       --  to avoid the generation of spurious warnings under ZFP run-time.
3787
3788       Insert_Actions (E, List_Def, Suppress => All_Checks);
3789       return Equiv_Type;
3790    end Make_CW_Equivalent_Type;
3791
3792    ------------------------
3793    -- Make_Literal_Range --
3794    ------------------------
3795
3796    function Make_Literal_Range
3797      (Loc         : Source_Ptr;
3798       Literal_Typ : Entity_Id) return Node_Id
3799    is
3800       Lo : constant Node_Id :=
3801              New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
3802
3803    begin
3804       Set_Analyzed (Lo, False);
3805
3806          return
3807            Make_Range (Loc,
3808              Low_Bound => Lo,
3809
3810              High_Bound =>
3811                Make_Op_Subtract (Loc,
3812                   Left_Opnd =>
3813                     Make_Op_Add (Loc,
3814                       Left_Opnd  => New_Copy_Tree (Lo),
3815                       Right_Opnd =>
3816                         Make_Integer_Literal (Loc,
3817                           String_Literal_Length (Literal_Typ))),
3818                   Right_Opnd => Make_Integer_Literal (Loc, 1)));
3819    end Make_Literal_Range;
3820
3821    ----------------------------
3822    -- Make_Subtype_From_Expr --
3823    ----------------------------
3824
3825    --  1. If Expr is an uncontrained array expression, creates
3826    --    Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
3827
3828    --  2. If Expr is a unconstrained discriminated type expression, creates
3829    --    Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3830
3831    --  3. If Expr is class-wide, creates an implicit class wide subtype
3832
3833    function Make_Subtype_From_Expr
3834      (E       : Node_Id;
3835       Unc_Typ : Entity_Id) return Node_Id
3836    is
3837       Loc         : constant Source_Ptr := Sloc (E);
3838       List_Constr : constant List_Id    := New_List;
3839       D           : Entity_Id;
3840
3841       Full_Subtyp  : Entity_Id;
3842       Priv_Subtyp  : Entity_Id;
3843       Utyp         : Entity_Id;
3844       Full_Exp     : Node_Id;
3845
3846    begin
3847       if Is_Private_Type (Unc_Typ)
3848         and then Has_Unknown_Discriminants (Unc_Typ)
3849       then
3850          --  Prepare the subtype completion, Go to base type to
3851          --  find underlying type, because the type may be a generic
3852          --  actual or an explicit subtype.
3853
3854          Utyp        := Underlying_Type (Base_Type (Unc_Typ));
3855          Full_Subtyp := Make_Defining_Identifier (Loc,
3856                           New_Internal_Name ('C'));
3857          Full_Exp    :=
3858            Unchecked_Convert_To
3859              (Utyp, Duplicate_Subexpr_No_Checks (E));
3860          Set_Parent (Full_Exp, Parent (E));
3861
3862          Priv_Subtyp :=
3863            Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
3864
3865          Insert_Action (E,
3866            Make_Subtype_Declaration (Loc,
3867              Defining_Identifier => Full_Subtyp,
3868              Subtype_Indication  => Make_Subtype_From_Expr (Full_Exp, Utyp)));
3869
3870          --  Define the dummy private subtype
3871
3872          Set_Ekind          (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
3873          Set_Etype          (Priv_Subtyp, Base_Type (Unc_Typ));
3874          Set_Scope          (Priv_Subtyp, Full_Subtyp);
3875          Set_Is_Constrained (Priv_Subtyp);
3876          Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
3877          Set_Is_Itype       (Priv_Subtyp);
3878          Set_Associated_Node_For_Itype (Priv_Subtyp, E);
3879
3880          if Is_Tagged_Type  (Priv_Subtyp) then
3881             Set_Class_Wide_Type
3882               (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
3883             Set_Primitive_Operations (Priv_Subtyp,
3884               Primitive_Operations (Unc_Typ));
3885          end if;
3886
3887          Set_Full_View (Priv_Subtyp, Full_Subtyp);
3888
3889          return New_Reference_To (Priv_Subtyp, Loc);
3890
3891       elsif Is_Array_Type (Unc_Typ) then
3892          for J in 1 .. Number_Dimensions (Unc_Typ) loop
3893             Append_To (List_Constr,
3894               Make_Range (Loc,
3895                 Low_Bound =>
3896                   Make_Attribute_Reference (Loc,
3897                     Prefix => Duplicate_Subexpr_No_Checks (E),
3898                     Attribute_Name => Name_First,
3899                     Expressions => New_List (
3900                       Make_Integer_Literal (Loc, J))),
3901
3902                 High_Bound =>
3903                   Make_Attribute_Reference (Loc,
3904                     Prefix         => Duplicate_Subexpr_No_Checks (E),
3905                     Attribute_Name => Name_Last,
3906                     Expressions    => New_List (
3907                       Make_Integer_Literal (Loc, J)))));
3908          end loop;
3909
3910       elsif Is_Class_Wide_Type (Unc_Typ) then
3911          declare
3912             CW_Subtype : Entity_Id;
3913             EQ_Typ     : Entity_Id := Empty;
3914
3915          begin
3916             --  A class-wide equivalent type is not needed when VM_Target
3917             --  because the VM back-ends handle the class-wide object
3918             --  initialization itself (and doesn't need or want the
3919             --  additional intermediate type to handle the assignment).
3920
3921             if Expander_Active and then VM_Target = No_VM then
3922                EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
3923             end if;
3924
3925             CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
3926             Set_Equivalent_Type (CW_Subtype, EQ_Typ);
3927
3928             if Present (EQ_Typ) then
3929                Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
3930             end if;
3931
3932             Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
3933
3934             return New_Occurrence_Of (CW_Subtype, Loc);
3935          end;
3936
3937       --  Indefinite record type with discriminants
3938
3939       else
3940          D := First_Discriminant (Unc_Typ);
3941          while Present (D) loop
3942             Append_To (List_Constr,
3943               Make_Selected_Component (Loc,
3944                 Prefix        => Duplicate_Subexpr_No_Checks (E),
3945                 Selector_Name => New_Reference_To (D, Loc)));
3946
3947             Next_Discriminant (D);
3948          end loop;
3949       end if;
3950
3951       return
3952         Make_Subtype_Indication (Loc,
3953           Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
3954           Constraint   =>
3955             Make_Index_Or_Discriminant_Constraint (Loc,
3956               Constraints => List_Constr));
3957    end Make_Subtype_From_Expr;
3958
3959    -----------------------------
3960    -- May_Generate_Large_Temp --
3961    -----------------------------
3962
3963    --  At the current time, the only types that we return False for (i.e.
3964    --  where we decide we know they cannot generate large temps) are ones
3965    --  where we know the size is 256 bits or less at compile time, and we
3966    --  are still not doing a thorough job on arrays and records ???
3967
3968    function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
3969    begin
3970       if not Size_Known_At_Compile_Time (Typ) then
3971          return False;
3972
3973       elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
3974          return False;
3975
3976       elsif Is_Array_Type (Typ)
3977         and then Present (Packed_Array_Type (Typ))
3978       then
3979          return May_Generate_Large_Temp (Packed_Array_Type (Typ));
3980
3981       --  We could do more here to find other small types ???
3982
3983       else
3984          return True;
3985       end if;
3986    end May_Generate_Large_Temp;
3987
3988    ----------------------------
3989    -- New_Class_Wide_Subtype --
3990    ----------------------------
3991
3992    function New_Class_Wide_Subtype
3993      (CW_Typ : Entity_Id;
3994       N      : Node_Id) return Entity_Id
3995    is
3996       Res       : constant Entity_Id := Create_Itype (E_Void, N);
3997       Res_Name  : constant Name_Id   := Chars (Res);
3998       Res_Scope : constant Entity_Id := Scope (Res);
3999
4000    begin
4001       Copy_Node (CW_Typ, Res);
4002       Set_Comes_From_Source (Res, False);
4003       Set_Sloc (Res, Sloc (N));
4004       Set_Is_Itype (Res);
4005       Set_Associated_Node_For_Itype (Res, N);
4006       Set_Is_Public (Res, False);   --  By default, may be changed below.
4007       Set_Public_Status (Res);
4008       Set_Chars (Res, Res_Name);
4009       Set_Scope (Res, Res_Scope);
4010       Set_Ekind (Res, E_Class_Wide_Subtype);
4011       Set_Next_Entity (Res, Empty);
4012       Set_Etype (Res, Base_Type (CW_Typ));
4013
4014       --  For targets where front-end layout is required, reset the Is_Frozen
4015       --  status of the subtype to False (it can be implicitly set to true
4016       --  from the copy of the class-wide type). For other targets, Gigi
4017       --  doesn't want the class-wide subtype to go through the freezing
4018       --  process (though it's unclear why that causes problems and it would
4019       --  be nice to allow freezing to occur normally for all targets ???).
4020
4021       if Frontend_Layout_On_Target then
4022          Set_Is_Frozen (Res, False);
4023       end if;
4024
4025       Set_Freeze_Node (Res, Empty);
4026       return (Res);
4027    end New_Class_Wide_Subtype;
4028
4029    --------------------------------
4030    -- Non_Limited_Designated_Type --
4031    ---------------------------------
4032
4033    function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
4034       Desig : constant Entity_Id := Designated_Type (T);
4035    begin
4036       if Ekind (Desig) = E_Incomplete_Type
4037         and then Present (Non_Limited_View (Desig))
4038       then
4039          return Non_Limited_View (Desig);
4040       else
4041          return Desig;
4042       end if;
4043    end Non_Limited_Designated_Type;
4044
4045    -----------------------------------
4046    -- OK_To_Do_Constant_Replacement --
4047    -----------------------------------
4048
4049    function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
4050       ES : constant Entity_Id := Scope (E);
4051       CS : Entity_Id;
4052
4053    begin
4054       --  Do not replace statically allocated objects, because they may be
4055       --  modified outside the current scope.
4056
4057       if Is_Statically_Allocated (E) then
4058          return False;
4059
4060       --  Do not replace aliased or volatile objects, since we don't know what
4061       --  else might change the value.
4062
4063       elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
4064          return False;
4065
4066       --  Debug flag -gnatdM disconnects this optimization
4067
4068       elsif Debug_Flag_MM then
4069          return False;
4070
4071       --  Otherwise check scopes
4072
4073       else
4074          CS := Current_Scope;
4075
4076          loop
4077             --  If we are in right scope, replacement is safe
4078
4079             if CS = ES then
4080                return True;
4081
4082             --  Packages do not affect the determination of safety
4083
4084             elsif Ekind (CS) = E_Package then
4085                exit when CS = Standard_Standard;
4086                CS := Scope (CS);
4087
4088             --  Blocks do not affect the determination of safety
4089
4090             elsif Ekind (CS) = E_Block then
4091                CS := Scope (CS);
4092
4093             --  Loops do not affect the determination of safety. Note that we
4094             --  kill all current values on entry to a loop, so we are just
4095             --  talking about processing within a loop here.
4096
4097             elsif Ekind (CS) = E_Loop then
4098                CS := Scope (CS);
4099
4100             --  Otherwise, the reference is dubious, and we cannot be sure that
4101             --  it is safe to do the replacement.
4102
4103             else
4104                exit;
4105             end if;
4106          end loop;
4107
4108          return False;
4109       end if;
4110    end OK_To_Do_Constant_Replacement;
4111
4112    ------------------------------------
4113    -- Possible_Bit_Aligned_Component --
4114    ------------------------------------
4115
4116    function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
4117    begin
4118       case Nkind (N) is
4119
4120          --  Case of indexed component
4121
4122          when N_Indexed_Component =>
4123             declare
4124                P    : constant Node_Id   := Prefix (N);
4125                Ptyp : constant Entity_Id := Etype (P);
4126
4127             begin
4128                --  If we know the component size and it is less than 64, then
4129                --  we are definitely OK. The back end always does assignment
4130                --  of misaligned small objects correctly.
4131
4132                if Known_Static_Component_Size (Ptyp)
4133                  and then Component_Size (Ptyp) <= 64
4134                then
4135                   return False;
4136
4137                --  Otherwise, we need to test the prefix, to see if we are
4138                --  indexing from a possibly unaligned component.
4139
4140                else
4141                   return Possible_Bit_Aligned_Component (P);
4142                end if;
4143             end;
4144
4145          --  Case of selected component
4146
4147          when N_Selected_Component =>
4148             declare
4149                P    : constant Node_Id   := Prefix (N);
4150                Comp : constant Entity_Id := Entity (Selector_Name (N));
4151
4152             begin
4153                --  If there is no component clause, then we are in the clear
4154                --  since the back end will never misalign a large component
4155                --  unless it is forced to do so. In the clear means we need
4156                --  only the recursive test on the prefix.
4157
4158                if Component_May_Be_Bit_Aligned (Comp) then
4159                   return True;
4160                else
4161                   return Possible_Bit_Aligned_Component (P);
4162                end if;
4163             end;
4164
4165          --  If we have neither a record nor array component, it means that we
4166          --  have fallen off the top testing prefixes recursively, and we now
4167          --  have a stand alone object, where we don't have a problem.
4168
4169          when others =>
4170             return False;
4171
4172       end case;
4173    end Possible_Bit_Aligned_Component;
4174
4175    -------------------------
4176    -- Remove_Side_Effects --
4177    -------------------------
4178
4179    procedure Remove_Side_Effects
4180      (Exp          : Node_Id;
4181       Name_Req     : Boolean := False;
4182       Variable_Ref : Boolean := False)
4183    is
4184       Loc          : constant Source_Ptr     := Sloc (Exp);
4185       Exp_Type     : constant Entity_Id      := Etype (Exp);
4186       Svg_Suppress : constant Suppress_Array := Scope_Suppress;
4187       Def_Id       : Entity_Id;
4188       Ref_Type     : Entity_Id;
4189       Res          : Node_Id;
4190       Ptr_Typ_Decl : Node_Id;
4191       New_Exp      : Node_Id;
4192       E            : Node_Id;
4193
4194       function Side_Effect_Free (N : Node_Id) return Boolean;
4195       --  Determines if the tree N represents an expression that is known not
4196       --  to have side effects, and for which no processing is required.
4197
4198       function Side_Effect_Free (L : List_Id) return Boolean;
4199       --  Determines if all elements of the list L are side effect free
4200
4201       function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
4202       --  The argument N is a construct where the Prefix is dereferenced if it
4203       --  is an access type and the result is a variable. The call returns True
4204       --  if the construct is side effect free (not considering side effects in
4205       --  other than the prefix which are to be tested by the caller).
4206
4207       function Within_In_Parameter (N : Node_Id) return Boolean;
4208       --  Determines if N is a subcomponent of a composite in-parameter. If so,
4209       --  N is not side-effect free when the actual is global and modifiable
4210       --  indirectly from within a subprogram, because it may be passed by
4211       --  reference. The front-end must be conservative here and assume that
4212       --  this may happen with any array or record type. On the other hand, we
4213       --  cannot create temporaries for all expressions for which this
4214       --  condition is true, for various reasons that might require clearing up
4215       --  ??? For example, descriminant references that appear out of place, or
4216       --  spurious type errors with class-wide expressions. As a result, we
4217       --  limit the transformation to loop bounds, which is so far the only
4218       --  case that requires it.
4219
4220       -----------------------------
4221       -- Safe_Prefixed_Reference --
4222       -----------------------------
4223
4224       function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
4225       begin
4226          --  If prefix is not side effect free, definitely not safe
4227
4228          if not Side_Effect_Free (Prefix (N)) then
4229             return False;
4230
4231          --  If the prefix is of an access type that is not access-to-constant,
4232          --  then this construct is a variable reference, which means it is to
4233          --  be considered to have side effects if Variable_Ref is set True
4234          --  Exception is an access to an entity that is a constant or an
4235          --  in-parameter which does not come from source, and is the result
4236          --  of a previous removal of side-effects.
4237
4238          elsif Is_Access_Type (Etype (Prefix (N)))
4239            and then not Is_Access_Constant (Etype (Prefix (N)))
4240            and then Variable_Ref
4241          then
4242             if not Is_Entity_Name (Prefix (N)) then
4243                return False;
4244             else
4245                return Ekind (Entity (Prefix (N))) = E_Constant
4246                  or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
4247             end if;
4248
4249          --  The following test is the simplest way of solving a complex
4250          --  problem uncovered by BB08-010: Side effect on loop bound that
4251          --  is a subcomponent of a global variable:
4252          --    If a loop bound is a subcomponent of a global variable, a
4253          --    modification of that variable within the loop may incorrectly
4254          --    affect the execution of the loop.
4255
4256          elsif not
4257            (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
4258               or else not Within_In_Parameter (Prefix (N)))
4259          then
4260             return False;
4261
4262          --  All other cases are side effect free
4263
4264          else
4265             return True;
4266          end if;
4267       end Safe_Prefixed_Reference;
4268
4269       ----------------------
4270       -- Side_Effect_Free --
4271       ----------------------
4272
4273       function Side_Effect_Free (N : Node_Id) return Boolean is
4274       begin
4275          --  Note on checks that could raise Constraint_Error. Strictly, if
4276          --  we take advantage of 11.6, these checks do not count as side
4277          --  effects. However, we would just as soon consider that they are
4278          --  side effects, since the backend CSE does not work very well on
4279          --  expressions which can raise Constraint_Error. On the other
4280          --  hand, if we do not consider them to be side effect free, then
4281          --  we get some awkward expansions in -gnato mode, resulting in
4282          --  code insertions at a point where we do not have a clear model
4283          --  for performing the insertions. See 4908-002/comment for details.
4284
4285          --  Special handling for entity names
4286
4287          if Is_Entity_Name (N) then
4288
4289             --  If the entity is a constant, it is definitely side effect
4290             --  free. Note that the test of Is_Variable (N) below might
4291             --  be expected to catch this case, but it does not, because
4292             --  this test goes to the original tree, and we may have
4293             --  already rewritten a variable node with a constant as
4294             --  a result of an earlier Force_Evaluation call.
4295
4296             if Ekind (Entity (N)) = E_Constant
4297               or else Ekind (Entity (N)) = E_In_Parameter
4298             then
4299                return True;
4300
4301             --  Functions are not side effect free
4302
4303             elsif Ekind (Entity (N)) = E_Function then
4304                return False;
4305
4306             --  Variables are considered to be a side effect if Variable_Ref
4307             --  is set or if we have a volatile variable and Name_Req is off.
4308             --  If Name_Req is True then we can't help returning a name which
4309             --  effectively allows multiple references in any case.
4310
4311             elsif Is_Variable (N) then
4312                return not Variable_Ref
4313                  and then (not Treat_As_Volatile (Entity (N))
4314                              or else Name_Req);
4315
4316             --  Any other entity (e.g. a subtype name) is definitely side
4317             --  effect free.
4318
4319             else
4320                return True;
4321             end if;
4322
4323          --  A value known at compile time is always side effect free
4324
4325          elsif Compile_Time_Known_Value (N) then
4326             return True;
4327
4328          --  A variable renaming is not side-effet free, because the
4329          --  renaming will function like a macro in the front-end in
4330          --  some cases, and an assignment can modify the the component
4331          --  designated by N, so we need to create a temporary for it.
4332
4333          elsif Is_Entity_Name (Original_Node (N))
4334            and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
4335            and then Ekind (Entity (Original_Node (N))) /= E_Constant
4336          then
4337             return False;
4338          end if;
4339
4340          --  For other than entity names and compile time known values,
4341          --  check the node kind for special processing.
4342
4343          case Nkind (N) is
4344
4345             --  An attribute reference is side effect free if its expressions
4346             --  are side effect free and its prefix is side effect free or
4347             --  is an entity reference.
4348
4349             --  Is this right? what about x'first where x is a variable???
4350
4351             when N_Attribute_Reference =>
4352                return Side_Effect_Free (Expressions (N))
4353                  and then Attribute_Name (N) /= Name_Input
4354                  and then (Is_Entity_Name (Prefix (N))
4355                             or else Side_Effect_Free (Prefix (N)));
4356
4357             --  A binary operator is side effect free if and both operands
4358             --  are side effect free. For this purpose binary operators
4359             --  include membership tests and short circuit forms
4360
4361             when N_Binary_Op       |
4362                  N_Membership_Test |
4363                  N_And_Then        |
4364                  N_Or_Else         =>
4365                return Side_Effect_Free (Left_Opnd  (N))
4366                  and then Side_Effect_Free (Right_Opnd (N));
4367
4368             --  An explicit dereference is side effect free only if it is
4369             --  a side effect free prefixed reference.
4370
4371             when N_Explicit_Dereference =>
4372                return Safe_Prefixed_Reference (N);
4373
4374             --  A call to _rep_to_pos is side effect free, since we generate
4375             --  this pure function call ourselves. Moreover it is critically
4376             --  important to make this exception, since otherwise we can
4377             --  have discriminants in array components which don't look
4378             --  side effect free in the case of an array whose index type
4379             --  is an enumeration type with an enumeration rep clause.
4380
4381             --  All other function calls are not side effect free
4382
4383             when N_Function_Call =>
4384                return Nkind (Name (N)) = N_Identifier
4385                  and then Is_TSS (Name (N), TSS_Rep_To_Pos)
4386                  and then
4387                    Side_Effect_Free (First (Parameter_Associations (N)));
4388
4389             --  An indexed component is side effect free if it is a side
4390             --  effect free prefixed reference and all the indexing
4391             --  expressions are side effect free.
4392
4393             when N_Indexed_Component =>
4394                return Side_Effect_Free (Expressions (N))
4395                  and then Safe_Prefixed_Reference (N);
4396
4397             --  A type qualification is side effect free if the expression
4398             --  is side effect free.
4399
4400             when N_Qualified_Expression =>
4401                return Side_Effect_Free (Expression (N));
4402
4403             --  A selected component is side effect free only if it is a
4404             --  side effect free prefixed reference.
4405
4406             when N_Selected_Component =>
4407                return Safe_Prefixed_Reference (N);
4408
4409             --  A range is side effect free if the bounds are side effect free
4410
4411             when N_Range =>
4412                return Side_Effect_Free (Low_Bound (N))
4413                  and then Side_Effect_Free (High_Bound (N));
4414
4415             --  A slice is side effect free if it is a side effect free
4416             --  prefixed reference and the bounds are side effect free.
4417
4418             when N_Slice =>
4419                return Side_Effect_Free (Discrete_Range (N))
4420                  and then Safe_Prefixed_Reference (N);
4421
4422             --  A type conversion is side effect free if the expression
4423             --  to be converted is side effect free.
4424
4425             when N_Type_Conversion =>
4426                return Side_Effect_Free (Expression (N));
4427
4428             --  A unary operator is side effect free if the operand
4429             --  is side effect free.
4430
4431             when N_Unary_Op =>
4432                return Side_Effect_Free (Right_Opnd (N));
4433
4434             --  An unchecked type conversion is side effect free only if it
4435             --  is safe and its argument is side effect free.
4436
4437             when N_Unchecked_Type_Conversion =>
4438                return Safe_Unchecked_Type_Conversion (N)
4439                  and then Side_Effect_Free (Expression (N));
4440
4441             --  An unchecked expression is side effect free if its expression
4442             --  is side effect free.
4443
4444             when N_Unchecked_Expression =>
4445                return Side_Effect_Free (Expression (N));
4446
4447             --  A literal is side effect free
4448
4449             when N_Character_Literal    |
4450                  N_Integer_Literal      |
4451                  N_Real_Literal         |
4452                  N_String_Literal       =>
4453                return True;
4454
4455             --  We consider that anything else has side effects. This is a bit
4456             --  crude, but we are pretty close for most common cases, and we
4457             --  are certainly correct (i.e. we never return True when the
4458             --  answer should be False).
4459
4460             when others =>
4461                return False;
4462          end case;
4463       end Side_Effect_Free;
4464
4465       --  A list is side effect free if all elements of the list are
4466       --  side effect free.
4467
4468       function Side_Effect_Free (L : List_Id) return Boolean is
4469          N : Node_Id;
4470
4471       begin
4472          if L = No_List or else L = Error_List then
4473             return True;
4474
4475          else
4476             N := First (L);
4477             while Present (N) loop
4478                if not Side_Effect_Free (N) then
4479                   return False;
4480                else
4481                   Next (N);
4482                end if;
4483             end loop;
4484
4485             return True;
4486          end if;
4487       end Side_Effect_Free;
4488
4489       -------------------------
4490       -- Within_In_Parameter --
4491       -------------------------
4492
4493       function Within_In_Parameter (N : Node_Id) return Boolean is
4494       begin
4495          if not Comes_From_Source (N) then
4496             return False;
4497
4498          elsif Is_Entity_Name (N) then
4499             return
4500               Ekind (Entity (N)) = E_In_Parameter;
4501
4502          elsif Nkind (N) = N_Indexed_Component
4503            or else Nkind (N) = N_Selected_Component
4504          then
4505             return Within_In_Parameter (Prefix (N));
4506          else
4507
4508             return False;
4509          end if;
4510       end Within_In_Parameter;
4511
4512    --  Start of processing for Remove_Side_Effects
4513
4514    begin
4515       --  If we are side effect free already or expansion is disabled,
4516       --  there is nothing to do.
4517
4518       if Side_Effect_Free (Exp) or else not Expander_Active then
4519          return;
4520       end if;
4521
4522       --  All this must not have any checks
4523
4524       Scope_Suppress := (others => True);
4525
4526       --  If it is a scalar type and we need to capture the value, just
4527       --  make a copy.  Likewise for a function call.  And if we have a
4528       --  volatile variable and Nam_Req is not set (see comments above
4529       --  for Side_Effect_Free).
4530
4531       if Is_Elementary_Type (Exp_Type)
4532         and then (Variable_Ref
4533                    or else Nkind (Exp) = N_Function_Call
4534                    or else (not Name_Req
4535                              and then Is_Entity_Name (Exp)
4536                              and then Treat_As_Volatile (Entity (Exp))))
4537       then
4538
4539          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4540          Set_Etype (Def_Id, Exp_Type);
4541          Res := New_Reference_To (Def_Id, Loc);
4542
4543          E :=
4544            Make_Object_Declaration (Loc,
4545              Defining_Identifier => Def_Id,
4546              Object_Definition   => New_Reference_To (Exp_Type, Loc),
4547              Constant_Present    => True,
4548              Expression          => Relocate_Node (Exp));
4549
4550          Set_Assignment_OK (E);
4551          Insert_Action (Exp, E);
4552
4553       --  If the expression has the form v.all then we can just capture
4554       --  the pointer, and then do an explicit dereference on the result.
4555
4556       elsif Nkind (Exp) = N_Explicit_Dereference then
4557          Def_Id :=
4558            Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4559          Res :=
4560            Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
4561
4562          Insert_Action (Exp,
4563            Make_Object_Declaration (Loc,
4564              Defining_Identifier => Def_Id,
4565              Object_Definition   =>
4566                New_Reference_To (Etype (Prefix (Exp)), Loc),
4567              Constant_Present    => True,
4568              Expression          => Relocate_Node (Prefix (Exp))));
4569
4570       --  Similar processing for an unchecked conversion of an expression
4571       --  of the form v.all, where we want the same kind of treatment.
4572
4573       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4574         and then Nkind (Expression (Exp)) = N_Explicit_Dereference
4575       then
4576          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
4577          Scope_Suppress := Svg_Suppress;
4578          return;
4579
4580       --  If this is a type conversion, leave the type conversion and remove
4581       --  the side effects in the expression. This is important in several
4582       --  circumstances: for change of representations, and also when this
4583       --  is a view conversion to a smaller object, where gigi can end up
4584       --  creating its own temporary of the wrong size.
4585
4586       elsif Nkind (Exp) = N_Type_Conversion then
4587          Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
4588          Scope_Suppress := Svg_Suppress;
4589          return;
4590
4591       --  If this is an unchecked conversion that Gigi can't handle, make
4592       --  a copy or a use a renaming to capture the value.
4593
4594       elsif Nkind (Exp) = N_Unchecked_Type_Conversion
4595         and then not Safe_Unchecked_Type_Conversion (Exp)
4596       then
4597          if CW_Or_Controlled_Type (Exp_Type) then
4598
4599             --  Use a renaming to capture the expression, rather than create
4600             --  a controlled temporary.
4601
4602             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4603             Res := New_Reference_To (Def_Id, Loc);
4604
4605             Insert_Action (Exp,
4606               Make_Object_Renaming_Declaration (Loc,
4607                 Defining_Identifier => Def_Id,
4608                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
4609                 Name                => Relocate_Node (Exp)));
4610
4611          else
4612             Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4613             Set_Etype (Def_Id, Exp_Type);
4614             Res := New_Reference_To (Def_Id, Loc);
4615
4616             E :=
4617               Make_Object_Declaration (Loc,
4618                 Defining_Identifier => Def_Id,
4619                 Object_Definition   => New_Reference_To (Exp_Type, Loc),
4620                 Constant_Present    => not Is_Variable (Exp),
4621                 Expression          => Relocate_Node (Exp));
4622
4623             Set_Assignment_OK (E);
4624             Insert_Action (Exp, E);
4625          end if;
4626
4627       --  For expressions that denote objects, we can use a renaming scheme.
4628       --  We skip using this if we have a volatile variable and we do not
4629       --  have Nam_Req set true (see comments above for Side_Effect_Free).
4630
4631       elsif Is_Object_Reference (Exp)
4632         and then Nkind (Exp) /= N_Function_Call
4633         and then (Name_Req
4634                    or else not Is_Entity_Name (Exp)
4635                    or else not Treat_As_Volatile (Entity (Exp)))
4636       then
4637          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4638
4639          if Nkind (Exp) = N_Selected_Component
4640            and then Nkind (Prefix (Exp)) = N_Function_Call
4641            and then Is_Array_Type (Exp_Type)
4642          then
4643             --  Avoid generating a variable-sized temporary, by generating
4644             --  the renaming declaration just for the function call. The
4645             --  transformation could be refined to apply only when the array
4646             --  component is constrained by a discriminant???
4647
4648             Res :=
4649               Make_Selected_Component (Loc,
4650                 Prefix => New_Occurrence_Of (Def_Id, Loc),
4651                 Selector_Name => Selector_Name (Exp));
4652
4653             Insert_Action (Exp,
4654               Make_Object_Renaming_Declaration (Loc,
4655                 Defining_Identifier => Def_Id,
4656                 Subtype_Mark        =>
4657                   New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
4658                 Name                => Relocate_Node (Prefix (Exp))));
4659
4660          else
4661             Res := New_Reference_To (Def_Id, Loc);
4662
4663             Insert_Action (Exp,
4664               Make_Object_Renaming_Declaration (Loc,
4665                 Defining_Identifier => Def_Id,
4666                 Subtype_Mark        => New_Reference_To (Exp_Type, Loc),
4667                 Name                => Relocate_Node (Exp)));
4668
4669          end if;
4670
4671          --  If this is a packed reference, or a selected component with a
4672          --  non-standard representation, a reference to the temporary will
4673          --  be replaced by a copy of the original expression (see
4674          --  exp_ch2.Expand_Renaming). Otherwise the temporary must be
4675          --  elaborated by gigi, and is of course not to be replaced in-line
4676          --  by the expression it renames, which would defeat the purpose of
4677          --  removing the side-effect.
4678
4679          if (Nkind (Exp) = N_Selected_Component
4680               or else Nkind (Exp) = N_Indexed_Component)
4681            and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
4682          then
4683             null;
4684          else
4685             Set_Is_Renaming_Of_Object (Def_Id, False);
4686          end if;
4687
4688       --  Otherwise we generate a reference to the value
4689
4690       else
4691          Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
4692
4693          Ptr_Typ_Decl :=
4694            Make_Full_Type_Declaration (Loc,
4695              Defining_Identifier => Ref_Type,
4696              Type_Definition =>
4697                Make_Access_To_Object_Definition (Loc,
4698                  All_Present => True,
4699                  Subtype_Indication =>
4700                    New_Reference_To (Exp_Type, Loc)));
4701
4702          E := Exp;
4703          Insert_Action (Exp, Ptr_Typ_Decl);
4704
4705          Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
4706          Set_Etype (Def_Id, Exp_Type);
4707
4708          Res :=
4709            Make_Explicit_Dereference (Loc,
4710              Prefix => New_Reference_To (Def_Id, Loc));
4711
4712          if Nkind (E) = N_Explicit_Dereference then
4713             New_Exp := Relocate_Node (Prefix (E));
4714          else
4715             E := Relocate_Node (E);
4716             New_Exp := Make_Reference (Loc, E);
4717          end if;
4718
4719          if Is_Delayed_Aggregate (E) then
4720
4721             --  The expansion of nested aggregates is delayed until the
4722             --  enclosing aggregate is expanded. As aggregates are often
4723             --  qualified, the predicate applies to qualified expressions
4724             --  as well, indicating that the enclosing aggregate has not
4725             --  been expanded yet. At this point the aggregate is part of
4726             --  a stand-alone declaration, and must be fully expanded.
4727
4728             if Nkind (E) = N_Qualified_Expression then
4729                Set_Expansion_Delayed (Expression (E), False);
4730                Set_Analyzed (Expression (E), False);
4731             else
4732                Set_Expansion_Delayed (E, False);
4733             end if;
4734
4735             Set_Analyzed (E, False);
4736          end if;
4737
4738          Insert_Action (Exp,
4739            Make_Object_Declaration (Loc,
4740              Defining_Identifier => Def_Id,
4741              Object_Definition   => New_Reference_To (Ref_Type, Loc),
4742              Expression          => New_Exp));
4743       end if;
4744
4745       --  Preserve the Assignment_OK flag in all copies, since at least
4746       --  one copy may be used in a context where this flag must be set
4747       --  (otherwise why would the flag be set in the first place).
4748
4749       Set_Assignment_OK (Res, Assignment_OK (Exp));
4750
4751       --  Finally rewrite the original expression and we are done
4752
4753       Rewrite (Exp, Res);
4754       Analyze_And_Resolve (Exp, Exp_Type);
4755       Scope_Suppress := Svg_Suppress;
4756    end Remove_Side_Effects;
4757
4758    ---------------------------
4759    -- Represented_As_Scalar --
4760    ---------------------------
4761
4762    function Represented_As_Scalar (T : Entity_Id) return Boolean is
4763       UT : constant Entity_Id := Underlying_Type (T);
4764    begin
4765       return Is_Scalar_Type (UT)
4766         or else (Is_Bit_Packed_Array (UT)
4767                    and then Is_Scalar_Type (Packed_Array_Type (UT)));
4768    end Represented_As_Scalar;
4769
4770    ------------------------------------
4771    -- Safe_Unchecked_Type_Conversion --
4772    ------------------------------------
4773
4774    --  Note: this function knows quite a bit about the exact requirements
4775    --  of Gigi with respect to unchecked type conversions, and its code
4776    --  must be coordinated with any changes in Gigi in this area.
4777
4778    --  The above requirements should be documented in Sinfo ???
4779
4780    function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
4781       Otyp   : Entity_Id;
4782       Ityp   : Entity_Id;
4783       Oalign : Uint;
4784       Ialign : Uint;
4785       Pexp   : constant Node_Id := Parent (Exp);
4786
4787    begin
4788       --  If the expression is the RHS of an assignment or object declaration
4789       --   we are always OK because there will always be a target.
4790
4791       --  Object renaming declarations, (generated for view conversions of
4792       --  actuals in inlined calls), like object declarations, provide an
4793       --  explicit type, and are safe as well.
4794
4795       if (Nkind (Pexp) = N_Assignment_Statement
4796            and then Expression (Pexp) = Exp)
4797         or else Nkind (Pexp) = N_Object_Declaration
4798         or else Nkind (Pexp) = N_Object_Renaming_Declaration
4799       then
4800          return True;
4801
4802       --  If the expression is the prefix of an N_Selected_Component
4803       --  we should also be OK because GCC knows to look inside the
4804       --  conversion except if the type is discriminated. We assume
4805       --  that we are OK anyway if the type is not set yet or if it is
4806       --  controlled since we can't afford to introduce a temporary in
4807       --  this case.
4808
4809       elsif Nkind (Pexp) = N_Selected_Component
4810          and then Prefix (Pexp) = Exp
4811       then
4812          if No (Etype (Pexp)) then
4813             return True;
4814          else
4815             return
4816               not Has_Discriminants (Etype (Pexp))
4817                 or else Is_Constrained (Etype (Pexp));
4818          end if;
4819       end if;
4820
4821       --  Set the output type, this comes from Etype if it is set, otherwise
4822       --  we take it from the subtype mark, which we assume was already
4823       --  fully analyzed.
4824
4825       if Present (Etype (Exp)) then
4826          Otyp := Etype (Exp);
4827       else
4828          Otyp := Entity (Subtype_Mark (Exp));
4829       end if;
4830
4831       --  The input type always comes from the expression, and we assume
4832       --  this is indeed always analyzed, so we can simply get the Etype.
4833
4834       Ityp := Etype (Expression (Exp));
4835
4836       --  Initialize alignments to unknown so far
4837
4838       Oalign := No_Uint;
4839       Ialign := No_Uint;
4840
4841       --  Replace a concurrent type by its corresponding record type
4842       --  and each type by its underlying type and do the tests on those.
4843       --  The original type may be a private type whose completion is a
4844       --  concurrent type, so find the underlying type first.
4845
4846       if Present (Underlying_Type (Otyp)) then
4847          Otyp := Underlying_Type (Otyp);
4848       end if;
4849
4850       if Present (Underlying_Type (Ityp)) then
4851          Ityp := Underlying_Type (Ityp);
4852       end if;
4853
4854       if Is_Concurrent_Type (Otyp) then
4855          Otyp := Corresponding_Record_Type (Otyp);
4856       end if;
4857
4858       if Is_Concurrent_Type (Ityp) then
4859          Ityp := Corresponding_Record_Type (Ityp);
4860       end if;
4861
4862       --  If the base types are the same, we know there is no problem since
4863       --  this conversion will be a noop.
4864
4865       if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
4866          return True;
4867
4868       --  Same if this is an upwards conversion of an untagged type, and there
4869       --  are no constraints involved (could be more general???)
4870
4871       elsif Etype (Ityp) = Otyp
4872         and then not Is_Tagged_Type (Ityp)
4873         and then not Has_Discriminants (Ityp)
4874         and then No (First_Rep_Item (Base_Type (Ityp)))
4875       then
4876          return True;
4877
4878       --  If the size of output type is known at compile time, there is
4879       --  never a problem.  Note that unconstrained records are considered
4880       --  to be of known size, but we can't consider them that way here,
4881       --  because we are talking about the actual size of the object.
4882
4883       --  We also make sure that in addition to the size being known, we do
4884       --  not have a case which might generate an embarrassingly large temp
4885       --  in stack checking mode.
4886
4887       elsif Size_Known_At_Compile_Time (Otyp)
4888         and then
4889           (not Stack_Checking_Enabled
4890              or else not May_Generate_Large_Temp (Otyp))
4891         and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
4892       then
4893          return True;
4894
4895       --  If either type is tagged, then we know the alignment is OK so
4896       --  Gigi will be able to use pointer punning.
4897
4898       elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
4899          return True;
4900
4901       --  If either type is a limited record type, we cannot do a copy, so
4902       --  say safe since there's nothing else we can do.
4903
4904       elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
4905          return True;
4906
4907       --  Conversions to and from packed array types are always ignored and
4908       --  hence are safe.
4909
4910       elsif Is_Packed_Array_Type (Otyp)
4911         or else Is_Packed_Array_Type (Ityp)
4912       then
4913          return True;
4914       end if;
4915
4916       --  The only other cases known to be safe is if the input type's
4917       --  alignment is known to be at least the maximum alignment for the
4918       --  target or if both alignments are known and the output type's
4919       --  alignment is no stricter than the input's.  We can use the alignment
4920       --  of the component type of an array if a type is an unpacked
4921       --  array type.
4922
4923       if Present (Alignment_Clause (Otyp)) then
4924          Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
4925
4926       elsif Is_Array_Type (Otyp)
4927         and then Present (Alignment_Clause (Component_Type (Otyp)))
4928       then
4929          Oalign := Expr_Value (Expression (Alignment_Clause
4930                                            (Component_Type (Otyp))));
4931       end if;
4932
4933       if Present (Alignment_Clause (Ityp)) then
4934          Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
4935
4936       elsif Is_Array_Type (Ityp)
4937         and then Present (Alignment_Clause (Component_Type (Ityp)))
4938       then
4939          Ialign := Expr_Value (Expression (Alignment_Clause
4940                                            (Component_Type (Ityp))));
4941       end if;
4942
4943       if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
4944          return True;
4945
4946       elsif Ialign /= No_Uint and then Oalign /= No_Uint
4947         and then Ialign <= Oalign
4948       then
4949          return True;
4950
4951       --   Otherwise, Gigi cannot handle this and we must make a temporary
4952
4953       else
4954          return False;
4955       end if;
4956    end Safe_Unchecked_Type_Conversion;
4957
4958    ---------------------------------
4959    -- Set_Current_Value_Condition --
4960    ---------------------------------
4961
4962    --  Note: the implementation of this procedure is very closely tied to the
4963    --  implementation of Get_Current_Value_Condition. Here we set required
4964    --  Current_Value fields, and in Get_Current_Value_Condition, we interpret
4965    --  them, so they must have a consistent view.
4966
4967    procedure Set_Current_Value_Condition (Cnode : Node_Id) is
4968
4969       procedure Set_Entity_Current_Value (N : Node_Id);
4970       --  If N is an entity reference, where the entity is of an appropriate
4971       --  kind, then set the current value of this entity to Cnode, unless
4972       --  there is already a definite value set there.
4973
4974       procedure Set_Expression_Current_Value (N : Node_Id);
4975       --  If N is of an appropriate form, sets an appropriate entry in current
4976       --  value fields of relevant entities. Multiple entities can be affected
4977       --  in the case of an AND or AND THEN.
4978
4979       ------------------------------
4980       -- Set_Entity_Current_Value --
4981       ------------------------------
4982
4983       procedure Set_Entity_Current_Value (N : Node_Id) is
4984       begin
4985          if Is_Entity_Name (N) then
4986             declare
4987                Ent : constant Entity_Id := Entity (N);
4988
4989             begin
4990                --  Don't capture if not safe to do so
4991
4992                if not Safe_To_Capture_Value (N, Ent, Cond => True) then
4993                   return;
4994                end if;
4995
4996                --  Here we have a case where the Current_Value field may
4997                --  need to be set. We set it if it is not already set to a
4998                --  compile time expression value.
4999
5000                --  Note that this represents a decision that one condition
5001                --  blots out another previous one. That's certainly right
5002                --  if they occur at the same level. If the second one is
5003                --  nested, then the decision is neither right nor wrong (it
5004                --  would be equally OK to leave the outer one in place, or
5005                --  take the new inner one. Really we should record both, but
5006                --  our data structures are not that elaborate.
5007
5008                if Nkind (Current_Value (Ent)) not in N_Subexpr then
5009                   Set_Current_Value (Ent, Cnode);
5010                end if;
5011             end;
5012          end if;
5013       end Set_Entity_Current_Value;
5014
5015       ----------------------------------
5016       -- Set_Expression_Current_Value --
5017       ----------------------------------
5018
5019       procedure Set_Expression_Current_Value (N : Node_Id) is
5020          Cond : Node_Id;
5021
5022       begin
5023          Cond := N;
5024
5025          --  Loop to deal with (ignore for now) any NOT operators present. The
5026          --  presence of NOT operators will be handled properly when we call
5027          --  Get_Current_Value_Condition.
5028
5029          while Nkind (Cond) = N_Op_Not loop
5030             Cond := Right_Opnd (Cond);
5031          end loop;
5032
5033          --  For an AND or AND THEN, recursively process operands
5034
5035          if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
5036             Set_Expression_Current_Value (Left_Opnd (Cond));
5037             Set_Expression_Current_Value (Right_Opnd (Cond));
5038             return;
5039          end if;
5040
5041          --  Check possible relational operator
5042
5043          if Nkind (Cond) in N_Op_Compare then
5044             if Compile_Time_Known_Value (Right_Opnd (Cond)) then
5045                Set_Entity_Current_Value (Left_Opnd (Cond));
5046             elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
5047                Set_Entity_Current_Value (Right_Opnd (Cond));
5048             end if;
5049
5050             --  Check possible boolean variable reference
5051
5052          else
5053             Set_Entity_Current_Value (Cond);
5054          end if;
5055       end Set_Expression_Current_Value;
5056
5057    --  Start of processing for Set_Current_Value_Condition
5058
5059    begin
5060       Set_Expression_Current_Value (Condition (Cnode));
5061    end Set_Current_Value_Condition;
5062
5063    --------------------------
5064    -- Set_Elaboration_Flag --
5065    --------------------------
5066
5067    procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
5068       Loc : constant Source_Ptr := Sloc (N);
5069       Ent : constant Entity_Id  := Elaboration_Entity (Spec_Id);
5070       Asn : Node_Id;
5071
5072    begin
5073       if Present (Ent) then
5074
5075          --  Nothing to do if at the compilation unit level, because in this
5076          --  case the flag is set by the binder generated elaboration routine.
5077
5078          if Nkind (Parent (N)) = N_Compilation_Unit then
5079             null;
5080
5081          --  Here we do need to generate an assignment statement
5082
5083          else
5084             Check_Restriction (No_Elaboration_Code, N);
5085             Asn :=
5086               Make_Assignment_Statement (Loc,
5087                 Name       => New_Occurrence_Of (Ent, Loc),
5088                 Expression => New_Occurrence_Of (Standard_True, Loc));
5089
5090             if Nkind (Parent (N)) = N_Subunit then
5091                Insert_After (Corresponding_Stub (Parent (N)), Asn);
5092             else
5093                Insert_After (N, Asn);
5094             end if;
5095
5096             Analyze (Asn);
5097
5098             --  Kill current value indication. This is necessary because
5099             --  the tests of this flag are inserted out of sequence and must
5100             --  not pick up bogus indications of the wrong constant value.
5101
5102             Set_Current_Value (Ent, Empty);
5103          end if;
5104       end if;
5105    end Set_Elaboration_Flag;
5106
5107    ----------------------------
5108    -- Set_Renamed_Subprogram --
5109    ----------------------------
5110
5111    procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
5112    begin
5113       --  If input node is an identifier, we can just reset it
5114
5115       if Nkind (N) = N_Identifier then
5116          Set_Chars  (N, Chars (E));
5117          Set_Entity (N, E);
5118
5119          --  Otherwise we have to do a rewrite, preserving Comes_From_Source
5120
5121       else
5122          declare
5123             CS : constant Boolean := Comes_From_Source (N);
5124          begin
5125             Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
5126             Set_Entity (N, E);
5127             Set_Comes_From_Source (N, CS);
5128             Set_Analyzed (N, True);
5129          end;
5130       end if;
5131    end Set_Renamed_Subprogram;
5132
5133    --------------------------
5134    -- Target_Has_Fixed_Ops --
5135    --------------------------
5136
5137    Integer_Sized_Small : Ureal;
5138    --  Set to 2.0 ** -(Integer'Size - 1) the first time that this
5139    --  function is called (we don't want to compute it more than once!)
5140
5141    Long_Integer_Sized_Small : Ureal;
5142    --  Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
5143    --  functoin is called (we don't want to compute it more than once)
5144
5145    First_Time_For_THFO : Boolean := True;
5146    --  Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5147
5148    function Target_Has_Fixed_Ops
5149      (Left_Typ   : Entity_Id;
5150       Right_Typ  : Entity_Id;
5151       Result_Typ : Entity_Id) return Boolean
5152    is
5153       function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
5154       --  Return True if the given type is a fixed-point type with a small
5155       --  value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5156       --  an absolute value less than 1.0. This is currently limited
5157       --  to fixed-point types that map to Integer or Long_Integer.
5158
5159       ------------------------
5160       -- Is_Fractional_Type --
5161       ------------------------
5162
5163       function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
5164       begin
5165          if Esize (Typ) = Standard_Integer_Size then
5166             return Small_Value (Typ) = Integer_Sized_Small;
5167
5168          elsif Esize (Typ) = Standard_Long_Integer_Size then
5169             return Small_Value (Typ) = Long_Integer_Sized_Small;
5170
5171          else
5172             return False;
5173          end if;
5174       end Is_Fractional_Type;
5175
5176    --  Start of processing for Target_Has_Fixed_Ops
5177
5178    begin
5179       --  Return False if Fractional_Fixed_Ops_On_Target is false
5180
5181       if not Fractional_Fixed_Ops_On_Target then
5182          return False;
5183       end if;
5184
5185       --  Here the target has Fractional_Fixed_Ops, if first time, compute
5186       --  standard constants used by Is_Fractional_Type.
5187
5188       if First_Time_For_THFO then
5189          First_Time_For_THFO := False;
5190
5191          Integer_Sized_Small :=
5192            UR_From_Components
5193              (Num   => Uint_1,
5194               Den   => UI_From_Int (Standard_Integer_Size - 1),
5195               Rbase => 2);
5196
5197          Long_Integer_Sized_Small :=
5198            UR_From_Components
5199              (Num   => Uint_1,
5200               Den   => UI_From_Int (Standard_Long_Integer_Size - 1),
5201               Rbase => 2);
5202       end if;
5203
5204       --  Return True if target supports fixed-by-fixed multiply/divide
5205       --  for fractional fixed-point types (see Is_Fractional_Type) and
5206       --  the operand and result types are equivalent fractional types.
5207
5208       return Is_Fractional_Type (Base_Type (Left_Typ))
5209         and then Is_Fractional_Type (Base_Type (Right_Typ))
5210         and then Is_Fractional_Type (Base_Type (Result_Typ))
5211         and then Esize (Left_Typ) = Esize (Right_Typ)
5212         and then Esize (Left_Typ) = Esize (Result_Typ);
5213    end Target_Has_Fixed_Ops;
5214
5215    ------------------------------------------
5216    -- Type_May_Have_Bit_Aligned_Components --
5217    ------------------------------------------
5218
5219    function Type_May_Have_Bit_Aligned_Components
5220      (Typ : Entity_Id) return Boolean
5221    is
5222    begin
5223       --  Array type, check component type
5224
5225       if Is_Array_Type (Typ) then
5226          return
5227            Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
5228
5229       --  Record type, check components
5230
5231       elsif Is_Record_Type (Typ) then
5232          declare
5233             E : Entity_Id;
5234
5235          begin
5236             E := First_Component_Or_Discriminant (Typ);
5237             while Present (E) loop
5238                if Component_May_Be_Bit_Aligned (E)
5239                  or else Type_May_Have_Bit_Aligned_Components (Etype (E))
5240                then
5241                   return True;
5242                end if;
5243
5244                Next_Component_Or_Discriminant (E);
5245             end loop;
5246
5247             return False;
5248          end;
5249
5250       --  Type other than array or record is always OK
5251
5252       else
5253          return False;
5254       end if;
5255    end Type_May_Have_Bit_Aligned_Components;
5256
5257    ----------------------------
5258    -- Wrap_Cleanup_Procedure --
5259    ----------------------------
5260
5261    procedure Wrap_Cleanup_Procedure (N : Node_Id) is
5262       Loc   : constant Source_Ptr := Sloc (N);
5263       Stseq : constant Node_Id    := Handled_Statement_Sequence (N);
5264       Stmts : constant List_Id    := Statements (Stseq);
5265
5266    begin
5267       if Abort_Allowed then
5268          Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
5269          Append_To  (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
5270       end if;
5271    end Wrap_Cleanup_Procedure;
5272
5273 end Exp_Util;