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