gcc/ada/sem_util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ U T I L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2013, 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 Casing;   use Casing;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Errout;   use Errout;
  31 with Elists;   use Elists;
  32 with Exp_Ch11; use Exp_Ch11;
  33 with Exp_Disp; use Exp_Disp;
  34 with Exp_Util; use Exp_Util;
  35 with Fname;    use Fname;
  36 with Freeze;   use Freeze;
  37 with Lib;      use Lib;
  38 with Lib.Xref; use Lib.Xref;
  39 with Namet.Sp; use Namet.Sp;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Output;   use Output;
  43 with Opt;      use Opt;
  44 with Restrict; use Restrict;
  45 with Rident;   use Rident;
  46 with Rtsfind;  use Rtsfind;
  47 with Sem;      use Sem;
  48 with Sem_Aux;  use Sem_Aux;
  49 with Sem_Attr; use Sem_Attr;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Disp; use Sem_Disp;
  52 with Sem_Eval; use Sem_Eval;
  53 with Sem_Res;  use Sem_Res;
  54 with Sem_Type; use Sem_Type;
  55 with Sinfo;    use Sinfo;
  56 with Sinput;   use Sinput;
  57 with Stand;    use Stand;
  58 with Style;
  59 with Stringt;  use Stringt;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Ttypes;   use Ttypes;
  63 with Uname;    use Uname;
  64
  65 with GNAT.HTable; use GNAT.HTable;
  66
  67 package body Sem_Util is
  68
  69    ----------------------------------------
  70    -- Global_Variables for New_Copy_Tree --
  71    ----------------------------------------
  72
  73    --  These global variables are used by New_Copy_Tree. See description
  74    --  of the body of this subprogram for details. Global variables can be
  75    --  safely used by New_Copy_Tree, since there is no case of a recursive
  76    --  call from the processing inside New_Copy_Tree.
  77
  78    NCT_Hash_Threshold : constant := 20;
  79    --  If there are more than this number of pairs of entries in the
  80    --  map, then Hash_Tables_Used will be set, and the hash tables will
  81    --  be initialized and used for the searches.
  82
  83    NCT_Hash_Tables_Used : Boolean := False;
  84    --  Set to True if hash tables are in use
  85
  86    NCT_Table_Entries : Nat := 0;
  87    --  Count entries in table to see if threshold is reached
  88
  89    NCT_Hash_Table_Setup : Boolean := False;
  90    --  Set to True if hash table contains data. We set this True if we
  91    --  setup the hash table with data, and leave it set permanently
  92    --  from then on, this is a signal that second and subsequent users
  93    --  of the hash table must clear the old entries before reuse.
  94
  95    subtype NCT_Header_Num is Int range 0 .. 511;
  96    --  Defines range of headers in hash tables (512 headers)
  97
  98    -----------------------
  99    -- Local Subprograms --
 100    -----------------------
 101
 102    function Build_Component_Subtype
 103      (C   : List_Id;
 104       Loc : Source_Ptr;
 105       T   : Entity_Id) return Node_Id;
 106    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
 107    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
 108    --  Loc is the source location, T is the original subtype.
 109
 110    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
 111    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
 112    --  with discriminants whose default values are static, examine only the
 113    --  components in the selected variant to determine whether all of them
 114    --  have a default.
 115
 116    function Has_Null_Extension (T : Entity_Id) return Boolean;
 117    --  T is a derived tagged type. Check whether the type extension is null.
 118    --  If the parent type is fully initialized, T can be treated as such.
 119
 120    ------------------------------
 121    --  Abstract_Interface_List --
 122    ------------------------------
 123
 124    function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
 125       Nod : Node_Id;
 126
 127    begin
 128       if Is_Concurrent_Type (Typ) then
 129
 130          --  If we are dealing with a synchronized subtype, go to the base
 131          --  type, whose declaration has the interface list.
 132
 133          --  Shouldn't this be Declaration_Node???
 134
 135          Nod := Parent (Base_Type (Typ));
 136
 137          if Nkind (Nod) = N_Full_Type_Declaration then
 138             return Empty_List;
 139          end if;
 140
 141       elsif Ekind (Typ) = E_Record_Type_With_Private then
 142          if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
 143             Nod := Type_Definition (Parent (Typ));
 144
 145          elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
 146             if Present (Full_View (Typ))
 147               and then Nkind (Parent (Full_View (Typ)))
 148                          = N_Full_Type_Declaration
 149             then
 150                Nod := Type_Definition (Parent (Full_View (Typ)));
 151
 152             --  If the full-view is not available we cannot do anything else
 153             --  here (the source has errors).
 154
 155             else
 156                return Empty_List;
 157             end if;
 158
 159          --  Support for generic formals with interfaces is still missing ???
 160
 161          elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 162             return Empty_List;
 163
 164          else
 165             pragma Assert
 166               (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
 167             Nod := Parent (Typ);
 168          end if;
 169
 170       elsif Ekind (Typ) = E_Record_Subtype then
 171          Nod := Type_Definition (Parent (Etype (Typ)));
 172
 173       elsif Ekind (Typ) = E_Record_Subtype_With_Private then
 174
 175          --  Recurse, because parent may still be a private extension. Also
 176          --  note that the full view of the subtype or the full view of its
 177          --  base type may (both) be unavailable.
 178
 179          return Abstract_Interface_List (Etype (Typ));
 180
 181       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
 182          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 183             Nod := Formal_Type_Definition (Parent (Typ));
 184          else
 185             Nod := Type_Definition (Parent (Typ));
 186          end if;
 187       end if;
 188
 189       return Interface_List (Nod);
 190    end Abstract_Interface_List;
 191
 192    --------------------------------
 193    -- Add_Access_Type_To_Process --
 194    --------------------------------
 195
 196    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
 197       L : Elist_Id;
 198
 199    begin
 200       Ensure_Freeze_Node (E);
 201       L := Access_Types_To_Process (Freeze_Node (E));
 202
 203       if No (L) then
 204          L := New_Elmt_List;
 205          Set_Access_Types_To_Process (Freeze_Node (E), L);
 206       end if;
 207
 208       Append_Elmt (A, L);
 209    end Add_Access_Type_To_Process;
 210
 211    -----------------------
 212    -- Add_Contract_Item --
 213    -----------------------
 214
 215    procedure Add_Contract_Item (Prag : Node_Id; Subp_Id : Entity_Id) is
 216       Items : constant Node_Id := Contract (Subp_Id);
 217       Nam   : Name_Id;
 218
 219    begin
 220       --  The related subprogram [body] must have a contract and the item to be
 221       --  added must be a pragma.
 222
 223       pragma Assert (Present (Items));
 224       pragma Assert (Nkind (Prag) = N_Pragma);
 225
 226       Nam := Pragma_Name (Prag);
 227
 228       --  Contract items related to subprogram bodies
 229
 230       if Ekind (Subp_Id) = E_Subprogram_Body then
 231          if Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then
 232             Set_Next_Pragma (Prag, Classifications (Items));
 233             Set_Classifications (Items, Prag);
 234
 235          --  The pragma is not a proper contract item
 236
 237          else
 238             raise Program_Error;
 239          end if;
 240
 241       --  Contract items related to subprogram declarations
 242
 243       else
 244          if Nam_In (Nam, Name_Precondition, Name_Postcondition) then
 245             Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
 246             Set_Pre_Post_Conditions (Items, Prag);
 247
 248          elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
 249             Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
 250             Set_Contract_Test_Cases (Items, Prag);
 251
 252          elsif Nam_In (Nam, Name_Depends, Name_Global) then
 253             Set_Next_Pragma (Prag, Classifications (Items));
 254             Set_Classifications (Items, Prag);
 255
 256          --  The pragma is not a proper contract item
 257
 258          else
 259             raise Program_Error;
 260          end if;
 261       end if;
 262    end Add_Contract_Item;
 263
 264    ----------------------------
 265    -- Add_Global_Declaration --
 266    ----------------------------
 267
 268    procedure Add_Global_Declaration (N : Node_Id) is
 269       Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
 270
 271    begin
 272       if No (Declarations (Aux_Node)) then
 273          Set_Declarations (Aux_Node, New_List);
 274       end if;
 275
 276       Append_To (Declarations (Aux_Node), N);
 277       Analyze (N);
 278    end Add_Global_Declaration;
 279
 280    -----------------
 281    -- Addressable --
 282    -----------------
 283
 284    --  For now, just 8/16/32/64. but analyze later if AAMP is special???
 285
 286    function Addressable (V : Uint) return Boolean is
 287    begin
 288       return V = Uint_8  or else
 289              V = Uint_16 or else
 290              V = Uint_32 or else
 291              V = Uint_64;
 292    end Addressable;
 293
 294    function Addressable (V : Int) return Boolean is
 295    begin
 296       return V = 8  or else
 297              V = 16 or else
 298              V = 32 or else
 299              V = 64;
 300    end Addressable;
 301
 302    -----------------------
 303    -- Alignment_In_Bits --
 304    -----------------------
 305
 306    function Alignment_In_Bits (E : Entity_Id) return Uint is
 307    begin
 308       return Alignment (E) * System_Storage_Unit;
 309    end Alignment_In_Bits;
 310
 311    ---------------------------------
 312    -- Append_Inherited_Subprogram --
 313    ---------------------------------
 314
 315    procedure Append_Inherited_Subprogram (S : Entity_Id) is
 316       Par : constant Entity_Id := Alias (S);
 317       --  The parent subprogram
 318
 319       Scop : constant Entity_Id := Scope (Par);
 320       --  The scope of definition of the parent subprogram
 321
 322       Typ : constant Entity_Id := Defining_Entity (Parent (S));
 323       --  The derived type of which S is a primitive operation
 324
 325       Decl   : Node_Id;
 326       Next_E : Entity_Id;
 327
 328    begin
 329       if Ekind (Current_Scope) = E_Package
 330         and then In_Private_Part (Current_Scope)
 331         and then Has_Private_Declaration (Typ)
 332         and then Is_Tagged_Type (Typ)
 333         and then Scop = Current_Scope
 334       then
 335          --  The inherited operation is available at the earliest place after
 336          --  the derived type declaration ( RM 7.3.1 (6/1)). This is only
 337          --  relevant for type extensions. If the parent operation appears
 338          --  after the type extension, the operation is not visible.
 339
 340          Decl := First
 341                    (Visible_Declarations
 342                      (Specification (Unit_Declaration_Node (Current_Scope))));
 343          while Present (Decl) loop
 344             if Nkind (Decl) = N_Private_Extension_Declaration
 345               and then Defining_Entity (Decl) = Typ
 346             then
 347                if Sloc (Decl) > Sloc (Par) then
 348                   Next_E := Next_Entity (Par);
 349                   Set_Next_Entity (Par, S);
 350                   Set_Next_Entity (S, Next_E);
 351                   return;
 352
 353                else
 354                   exit;
 355                end if;
 356             end if;
 357
 358             Next (Decl);
 359          end loop;
 360       end if;
 361
 362       --  If partial view is not a type extension, or it appears before the
 363       --  subprogram declaration, insert normally at end of entity list.
 364
 365       Append_Entity (S, Current_Scope);
 366    end Append_Inherited_Subprogram;
 367
 368    -----------------------------------------
 369    -- Apply_Compile_Time_Constraint_Error --
 370    -----------------------------------------
 371
 372    procedure Apply_Compile_Time_Constraint_Error
 373      (N      : Node_Id;
 374       Msg    : String;
 375       Reason : RT_Exception_Code;
 376       Ent    : Entity_Id  := Empty;
 377       Typ    : Entity_Id  := Empty;
 378       Loc    : Source_Ptr := No_Location;
 379       Rep    : Boolean    := True;
 380       Warn   : Boolean    := False)
 381    is
 382       Stat   : constant Boolean := Is_Static_Expression (N);
 383       R_Stat : constant Node_Id :=
 384                  Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
 385       Rtyp   : Entity_Id;
 386
 387    begin
 388       if No (Typ) then
 389          Rtyp := Etype (N);
 390       else
 391          Rtyp := Typ;
 392       end if;
 393
 394       Discard_Node
 395         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 396
 397       if not Rep then
 398          return;
 399       end if;
 400
 401       --  Now we replace the node by an N_Raise_Constraint_Error node
 402       --  This does not need reanalyzing, so set it as analyzed now.
 403
 404       Rewrite (N, R_Stat);
 405       Set_Analyzed (N, True);
 406
 407       Set_Etype (N, Rtyp);
 408       Set_Raises_Constraint_Error (N);
 409
 410       --  Now deal with possible local raise handling
 411
 412       Possible_Local_Raise (N, Standard_Constraint_Error);
 413
 414       --  If the original expression was marked as static, the result is
 415       --  still marked as static, but the Raises_Constraint_Error flag is
 416       --  always set so that further static evaluation is not attempted.
 417
 418       if Stat then
 419          Set_Is_Static_Expression (N);
 420       end if;
 421    end Apply_Compile_Time_Constraint_Error;
 422
 423    --------------------------------------
 424    -- Available_Full_View_Of_Component --
 425    --------------------------------------
 426
 427    function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
 428       ST  : constant Entity_Id := Scope (T);
 429       SCT : constant Entity_Id := Scope (Component_Type (T));
 430    begin
 431       return In_Open_Scopes (ST)
 432         and then In_Open_Scopes (SCT)
 433         and then Scope_Depth (ST) >= Scope_Depth (SCT);
 434    end Available_Full_View_Of_Component;
 435
 436    -------------------
 437    -- Bad_Attribute --
 438    -------------------
 439
 440    procedure Bad_Attribute
 441      (N    : Node_Id;
 442       Nam  : Name_Id;
 443       Warn : Boolean := False)
 444    is
 445    begin
 446       Error_Msg_Warn := Warn;
 447       Error_Msg_N ("unrecognized attribute&<", N);
 448
 449       --  Check for possible misspelling
 450
 451       Error_Msg_Name_1 := First_Attribute_Name;
 452       while Error_Msg_Name_1 <= Last_Attribute_Name loop
 453          if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
 454             Error_Msg_N -- CODEFIX
 455               ("\possible misspelling of %<", N);
 456             exit;
 457          end if;
 458
 459          Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
 460       end loop;
 461    end Bad_Attribute;
 462
 463    --------------------------------
 464    -- Bad_Predicated_Subtype_Use --
 465    --------------------------------
 466
 467    procedure Bad_Predicated_Subtype_Use
 468      (Msg            : String;
 469       N              : Node_Id;
 470       Typ            : Entity_Id;
 471       Suggest_Static : Boolean := False)
 472    is
 473    begin
 474       if Has_Predicates (Typ) then
 475          if Is_Generic_Actual_Type (Typ) then
 476             Error_Msg_FE (Msg & "??", N, Typ);
 477             Error_Msg_F ("\Program_Error will be raised at run time??", N);
 478             Insert_Action (N,
 479               Make_Raise_Program_Error (Sloc (N),
 480                 Reason => PE_Bad_Predicated_Generic_Type));
 481
 482          else
 483             Error_Msg_FE (Msg, N, Typ);
 484          end if;
 485
 486          --  Emit an optional suggestion on how to remedy the error if the
 487          --  context warrants it.
 488
 489          if Suggest_Static and then Present (Static_Predicate (Typ)) then
 490             Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
 491          end if;
 492       end if;
 493    end Bad_Predicated_Subtype_Use;
 494
 495    --------------------------
 496    -- Build_Actual_Subtype --
 497    --------------------------
 498
 499    function Build_Actual_Subtype
 500      (T : Entity_Id;
 501       N : Node_Or_Entity_Id) return Node_Id
 502    is
 503       Loc : Source_Ptr;
 504       --  Normally Sloc (N), but may point to corresponding body in some cases
 505
 506       Constraints : List_Id;
 507       Decl        : Node_Id;
 508       Discr       : Entity_Id;
 509       Hi          : Node_Id;
 510       Lo          : Node_Id;
 511       Subt        : Entity_Id;
 512       Disc_Type   : Entity_Id;
 513       Obj         : Node_Id;
 514
 515    begin
 516       Loc := Sloc (N);
 517
 518       if Nkind (N) = N_Defining_Identifier then
 519          Obj := New_Reference_To (N, Loc);
 520
 521          --  If this is a formal parameter of a subprogram declaration, and
 522          --  we are compiling the body, we want the declaration for the
 523          --  actual subtype to carry the source position of the body, to
 524          --  prevent anomalies in gdb when stepping through the code.
 525
 526          if Is_Formal (N) then
 527             declare
 528                Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
 529             begin
 530                if Nkind (Decl) = N_Subprogram_Declaration
 531                  and then Present (Corresponding_Body (Decl))
 532                then
 533                   Loc := Sloc (Corresponding_Body (Decl));
 534                end if;
 535             end;
 536          end if;
 537
 538       else
 539          Obj := N;
 540       end if;
 541
 542       if Is_Array_Type (T) then
 543          Constraints := New_List;
 544          for J in 1 .. Number_Dimensions (T) loop
 545
 546             --  Build an array subtype declaration with the nominal subtype and
 547             --  the bounds of the actual. Add the declaration in front of the
 548             --  local declarations for the subprogram, for analysis before any
 549             --  reference to the formal in the body.
 550
 551             Lo :=
 552               Make_Attribute_Reference (Loc,
 553                 Prefix         =>
 554                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 555                 Attribute_Name => Name_First,
 556                 Expressions    => New_List (
 557                   Make_Integer_Literal (Loc, J)));
 558
 559             Hi :=
 560               Make_Attribute_Reference (Loc,
 561                 Prefix         =>
 562                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 563                 Attribute_Name => Name_Last,
 564                 Expressions    => New_List (
 565                   Make_Integer_Literal (Loc, J)));
 566
 567             Append (Make_Range (Loc, Lo, Hi), Constraints);
 568          end loop;
 569
 570       --  If the type has unknown discriminants there is no constrained
 571       --  subtype to build. This is never called for a formal or for a
 572       --  lhs, so returning the type is ok ???
 573
 574       elsif Has_Unknown_Discriminants (T) then
 575          return T;
 576
 577       else
 578          Constraints := New_List;
 579
 580          --  Type T is a generic derived type, inherit the discriminants from
 581          --  the parent type.
 582
 583          if Is_Private_Type (T)
 584            and then No (Full_View (T))
 585
 586             --  T was flagged as an error if it was declared as a formal
 587             --  derived type with known discriminants. In this case there
 588             --  is no need to look at the parent type since T already carries
 589             --  its own discriminants.
 590
 591            and then not Error_Posted (T)
 592          then
 593             Disc_Type := Etype (Base_Type (T));
 594          else
 595             Disc_Type := T;
 596          end if;
 597
 598          Discr := First_Discriminant (Disc_Type);
 599          while Present (Discr) loop
 600             Append_To (Constraints,
 601               Make_Selected_Component (Loc,
 602                 Prefix =>
 603                   Duplicate_Subexpr_No_Checks (Obj),
 604                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 605             Next_Discriminant (Discr);
 606          end loop;
 607       end if;
 608
 609       Subt := Make_Temporary (Loc, 'S', Related_Node => N);
 610       Set_Is_Internal (Subt);
 611
 612       Decl :=
 613         Make_Subtype_Declaration (Loc,
 614           Defining_Identifier => Subt,
 615           Subtype_Indication =>
 616             Make_Subtype_Indication (Loc,
 617               Subtype_Mark => New_Reference_To (T,  Loc),
 618               Constraint  =>
 619                 Make_Index_Or_Discriminant_Constraint (Loc,
 620                   Constraints => Constraints)));
 621
 622       Mark_Rewrite_Insertion (Decl);
 623       return Decl;
 624    end Build_Actual_Subtype;
 625
 626    ---------------------------------------
 627    -- Build_Actual_Subtype_Of_Component --
 628    ---------------------------------------
 629
 630    function Build_Actual_Subtype_Of_Component
 631      (T : Entity_Id;
 632       N : Node_Id) return Node_Id
 633    is
 634       Loc       : constant Source_Ptr := Sloc (N);
 635       P         : constant Node_Id    := Prefix (N);
 636       D         : Elmt_Id;
 637       Id        : Node_Id;
 638       Index_Typ : Entity_Id;
 639
 640       Desig_Typ : Entity_Id;
 641       --  This is either a copy of T, or if T is an access type, then it is
 642       --  the directly designated type of this access type.
 643
 644       function Build_Actual_Array_Constraint return List_Id;
 645       --  If one or more of the bounds of the component depends on
 646       --  discriminants, build  actual constraint using the discriminants
 647       --  of the prefix.
 648
 649       function Build_Actual_Record_Constraint return List_Id;
 650       --  Similar to previous one, for discriminated components constrained
 651       --  by the discriminant of the enclosing object.
 652
 653       -----------------------------------
 654       -- Build_Actual_Array_Constraint --
 655       -----------------------------------
 656
 657       function Build_Actual_Array_Constraint return List_Id is
 658          Constraints : constant List_Id := New_List;
 659          Indx        : Node_Id;
 660          Hi          : Node_Id;
 661          Lo          : Node_Id;
 662          Old_Hi      : Node_Id;
 663          Old_Lo      : Node_Id;
 664
 665       begin
 666          Indx := First_Index (Desig_Typ);
 667          while Present (Indx) loop
 668             Old_Lo := Type_Low_Bound  (Etype (Indx));
 669             Old_Hi := Type_High_Bound (Etype (Indx));
 670
 671             if Denotes_Discriminant (Old_Lo) then
 672                Lo :=
 673                  Make_Selected_Component (Loc,
 674                    Prefix => New_Copy_Tree (P),
 675                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 676
 677             else
 678                Lo := New_Copy_Tree (Old_Lo);
 679
 680                --  The new bound will be reanalyzed in the enclosing
 681                --  declaration. For literal bounds that come from a type
 682                --  declaration, the type of the context must be imposed, so
 683                --  insure that analysis will take place. For non-universal
 684                --  types this is not strictly necessary.
 685
 686                Set_Analyzed (Lo, False);
 687             end if;
 688
 689             if Denotes_Discriminant (Old_Hi) then
 690                Hi :=
 691                  Make_Selected_Component (Loc,
 692                    Prefix => New_Copy_Tree (P),
 693                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 694
 695             else
 696                Hi := New_Copy_Tree (Old_Hi);
 697                Set_Analyzed (Hi, False);
 698             end if;
 699
 700             Append (Make_Range (Loc, Lo, Hi), Constraints);
 701             Next_Index (Indx);
 702          end loop;
 703
 704          return Constraints;
 705       end Build_Actual_Array_Constraint;
 706
 707       ------------------------------------
 708       -- Build_Actual_Record_Constraint --
 709       ------------------------------------
 710
 711       function Build_Actual_Record_Constraint return List_Id is
 712          Constraints : constant List_Id := New_List;
 713          D           : Elmt_Id;
 714          D_Val       : Node_Id;
 715
 716       begin
 717          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 718          while Present (D) loop
 719             if Denotes_Discriminant (Node (D)) then
 720                D_Val :=  Make_Selected_Component (Loc,
 721                  Prefix => New_Copy_Tree (P),
 722                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 723
 724             else
 725                D_Val := New_Copy_Tree (Node (D));
 726             end if;
 727
 728             Append (D_Val, Constraints);
 729             Next_Elmt (D);
 730          end loop;
 731
 732          return Constraints;
 733       end Build_Actual_Record_Constraint;
 734
 735    --  Start of processing for Build_Actual_Subtype_Of_Component
 736
 737    begin
 738       --  Why the test for Spec_Expression mode here???
 739
 740       if In_Spec_Expression then
 741          return Empty;
 742
 743       --  More comments for the rest of this body would be good ???
 744
 745       elsif Nkind (N) = N_Explicit_Dereference then
 746          if Is_Composite_Type (T)
 747            and then not Is_Constrained (T)
 748            and then not (Is_Class_Wide_Type (T)
 749                           and then Is_Constrained (Root_Type (T)))
 750            and then not Has_Unknown_Discriminants (T)
 751          then
 752             --  If the type of the dereference is already constrained, it is an
 753             --  actual subtype.
 754
 755             if Is_Array_Type (Etype (N))
 756               and then Is_Constrained (Etype (N))
 757             then
 758                return Empty;
 759             else
 760                Remove_Side_Effects (P);
 761                return Build_Actual_Subtype (T, N);
 762             end if;
 763          else
 764             return Empty;
 765          end if;
 766       end if;
 767
 768       if Ekind (T) = E_Access_Subtype then
 769          Desig_Typ := Designated_Type (T);
 770       else
 771          Desig_Typ := T;
 772       end if;
 773
 774       if Ekind (Desig_Typ) = E_Array_Subtype then
 775          Id := First_Index (Desig_Typ);
 776          while Present (Id) loop
 777             Index_Typ := Underlying_Type (Etype (Id));
 778
 779             if Denotes_Discriminant (Type_Low_Bound  (Index_Typ))
 780                  or else
 781                Denotes_Discriminant (Type_High_Bound (Index_Typ))
 782             then
 783                Remove_Side_Effects (P);
 784                return
 785                  Build_Component_Subtype
 786                    (Build_Actual_Array_Constraint, Loc, Base_Type (T));
 787             end if;
 788
 789             Next_Index (Id);
 790          end loop;
 791
 792       elsif Is_Composite_Type (Desig_Typ)
 793         and then Has_Discriminants (Desig_Typ)
 794         and then not Has_Unknown_Discriminants (Desig_Typ)
 795       then
 796          if Is_Private_Type (Desig_Typ)
 797            and then No (Discriminant_Constraint (Desig_Typ))
 798          then
 799             Desig_Typ := Full_View (Desig_Typ);
 800          end if;
 801
 802          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 803          while Present (D) loop
 804             if Denotes_Discriminant (Node (D)) then
 805                Remove_Side_Effects (P);
 806                return
 807                  Build_Component_Subtype (
 808                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
 809             end if;
 810
 811             Next_Elmt (D);
 812          end loop;
 813       end if;
 814
 815       --  If none of the above, the actual and nominal subtypes are the same
 816
 817       return Empty;
 818    end Build_Actual_Subtype_Of_Component;
 819
 820    -----------------------------
 821    -- Build_Component_Subtype --
 822    -----------------------------
 823
 824    function Build_Component_Subtype
 825      (C   : List_Id;
 826       Loc : Source_Ptr;
 827       T   : Entity_Id) return Node_Id
 828    is
 829       Subt : Entity_Id;
 830       Decl : Node_Id;
 831
 832    begin
 833       --  Unchecked_Union components do not require component subtypes
 834
 835       if Is_Unchecked_Union (T) then
 836          return Empty;
 837       end if;
 838
 839       Subt := Make_Temporary (Loc, 'S');
 840       Set_Is_Internal (Subt);
 841
 842       Decl :=
 843         Make_Subtype_Declaration (Loc,
 844           Defining_Identifier => Subt,
 845           Subtype_Indication =>
 846             Make_Subtype_Indication (Loc,
 847               Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
 848               Constraint  =>
 849                 Make_Index_Or_Discriminant_Constraint (Loc,
 850                   Constraints => C)));
 851
 852       Mark_Rewrite_Insertion (Decl);
 853       return Decl;
 854    end Build_Component_Subtype;
 855
 856    ---------------------------
 857    -- Build_Default_Subtype --
 858    ---------------------------
 859
 860    function Build_Default_Subtype
 861      (T : Entity_Id;
 862       N : Node_Id) return Entity_Id
 863    is
 864       Loc  : constant Source_Ptr := Sloc (N);
 865       Disc : Entity_Id;
 866
 867       Bas : Entity_Id;
 868       --  The base type that is to be constrained by the defaults
 869
 870    begin
 871       if not Has_Discriminants (T) or else Is_Constrained (T) then
 872          return T;
 873       end if;
 874
 875       Bas := Base_Type (T);
 876
 877       --  If T is non-private but its base type is private, this is the
 878       --  completion of a subtype declaration whose parent type is private
 879       --  (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
 880       --  are to be found in the full view of the base.
 881
 882       if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
 883          Bas := Full_View (Bas);
 884       end if;
 885
 886       Disc := First_Discriminant (T);
 887
 888       if No (Discriminant_Default_Value (Disc)) then
 889          return T;
 890       end if;
 891
 892       declare
 893          Act         : constant Entity_Id := Make_Temporary (Loc, 'S');
 894          Constraints : constant List_Id := New_List;
 895          Decl        : Node_Id;
 896
 897       begin
 898          while Present (Disc) loop
 899             Append_To (Constraints,
 900               New_Copy_Tree (Discriminant_Default_Value (Disc)));
 901             Next_Discriminant (Disc);
 902          end loop;
 903
 904          Decl :=
 905            Make_Subtype_Declaration (Loc,
 906              Defining_Identifier => Act,
 907              Subtype_Indication  =>
 908                Make_Subtype_Indication (Loc,
 909                  Subtype_Mark => New_Occurrence_Of (Bas, Loc),
 910                  Constraint   =>
 911                    Make_Index_Or_Discriminant_Constraint (Loc,
 912                      Constraints => Constraints)));
 913
 914          Insert_Action (N, Decl);
 915          Analyze (Decl);
 916          return Act;
 917       end;
 918    end Build_Default_Subtype;
 919
 920    --------------------------------------------
 921    -- Build_Discriminal_Subtype_Of_Component --
 922    --------------------------------------------
 923
 924    function Build_Discriminal_Subtype_Of_Component
 925      (T : Entity_Id) return Node_Id
 926    is
 927       Loc : constant Source_Ptr := Sloc (T);
 928       D   : Elmt_Id;
 929       Id  : Node_Id;
 930
 931       function Build_Discriminal_Array_Constraint return List_Id;
 932       --  If one or more of the bounds of the component depends on
 933       --  discriminants, build  actual constraint using the discriminants
 934       --  of the prefix.
 935
 936       function Build_Discriminal_Record_Constraint return List_Id;
 937       --  Similar to previous one, for discriminated components constrained by
 938       --  the discriminant of the enclosing object.
 939
 940       ----------------------------------------
 941       -- Build_Discriminal_Array_Constraint --
 942       ----------------------------------------
 943
 944       function Build_Discriminal_Array_Constraint return List_Id is
 945          Constraints : constant List_Id := New_List;
 946          Indx        : Node_Id;
 947          Hi          : Node_Id;
 948          Lo          : Node_Id;
 949          Old_Hi      : Node_Id;
 950          Old_Lo      : Node_Id;
 951
 952       begin
 953          Indx := First_Index (T);
 954          while Present (Indx) loop
 955             Old_Lo := Type_Low_Bound  (Etype (Indx));
 956             Old_Hi := Type_High_Bound (Etype (Indx));
 957
 958             if Denotes_Discriminant (Old_Lo) then
 959                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
 960
 961             else
 962                Lo := New_Copy_Tree (Old_Lo);
 963             end if;
 964
 965             if Denotes_Discriminant (Old_Hi) then
 966                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
 967
 968             else
 969                Hi := New_Copy_Tree (Old_Hi);
 970             end if;
 971
 972             Append (Make_Range (Loc, Lo, Hi), Constraints);
 973             Next_Index (Indx);
 974          end loop;
 975
 976          return Constraints;
 977       end Build_Discriminal_Array_Constraint;
 978
 979       -----------------------------------------
 980       -- Build_Discriminal_Record_Constraint --
 981       -----------------------------------------
 982
 983       function Build_Discriminal_Record_Constraint return List_Id is
 984          Constraints : constant List_Id := New_List;
 985          D           : Elmt_Id;
 986          D_Val       : Node_Id;
 987
 988       begin
 989          D := First_Elmt (Discriminant_Constraint (T));
 990          while Present (D) loop
 991             if Denotes_Discriminant (Node (D)) then
 992                D_Val :=
 993                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
 994
 995             else
 996                D_Val := New_Copy_Tree (Node (D));
 997             end if;
 998
 999             Append (D_Val, Constraints);
1000             Next_Elmt (D);
1001          end loop;
1002
1003          return Constraints;
1004       end Build_Discriminal_Record_Constraint;
1005
1006    --  Start of processing for Build_Discriminal_Subtype_Of_Component
1007
1008    begin
1009       if Ekind (T) = E_Array_Subtype then
1010          Id := First_Index (T);
1011          while Present (Id) loop
1012             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
1013                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1014             then
1015                return Build_Component_Subtype
1016                  (Build_Discriminal_Array_Constraint, Loc, T);
1017             end if;
1018
1019             Next_Index (Id);
1020          end loop;
1021
1022       elsif Ekind (T) = E_Record_Subtype
1023         and then Has_Discriminants (T)
1024         and then not Has_Unknown_Discriminants (T)
1025       then
1026          D := First_Elmt (Discriminant_Constraint (T));
1027          while Present (D) loop
1028             if Denotes_Discriminant (Node (D)) then
1029                return Build_Component_Subtype
1030                  (Build_Discriminal_Record_Constraint, Loc, T);
1031             end if;
1032
1033             Next_Elmt (D);
1034          end loop;
1035       end if;
1036
1037       --  If none of the above, the actual and nominal subtypes are the same
1038
1039       return Empty;
1040    end Build_Discriminal_Subtype_Of_Component;
1041
1042    ------------------------------
1043    -- Build_Elaboration_Entity --
1044    ------------------------------
1045
1046    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1047       Loc      : constant Source_Ptr := Sloc (N);
1048       Decl     : Node_Id;
1049       Elab_Ent : Entity_Id;
1050
1051       procedure Set_Package_Name (Ent : Entity_Id);
1052       --  Given an entity, sets the fully qualified name of the entity in
1053       --  Name_Buffer, with components separated by double underscores. This
1054       --  is a recursive routine that climbs the scope chain to Standard.
1055
1056       ----------------------
1057       -- Set_Package_Name --
1058       ----------------------
1059
1060       procedure Set_Package_Name (Ent : Entity_Id) is
1061       begin
1062          if Scope (Ent) /= Standard_Standard then
1063             Set_Package_Name (Scope (Ent));
1064
1065             declare
1066                Nam : constant String := Get_Name_String (Chars (Ent));
1067             begin
1068                Name_Buffer (Name_Len + 1) := '_';
1069                Name_Buffer (Name_Len + 2) := '_';
1070                Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1071                Name_Len := Name_Len + Nam'Length + 2;
1072             end;
1073
1074          else
1075             Get_Name_String (Chars (Ent));
1076          end if;
1077       end Set_Package_Name;
1078
1079    --  Start of processing for Build_Elaboration_Entity
1080
1081    begin
1082       --  Ignore if already constructed
1083
1084       if Present (Elaboration_Entity (Spec_Id)) then
1085          return;
1086       end if;
1087
1088       --  Construct name of elaboration entity as xxx_E, where xxx is the unit
1089       --  name with dots replaced by double underscore. We have to manually
1090       --  construct this name, since it will be elaborated in the outer scope,
1091       --  and thus will not have the unit name automatically prepended.
1092
1093       Set_Package_Name (Spec_Id);
1094       Add_Str_To_Name_Buffer ("_E");
1095
1096       --  Create elaboration counter
1097
1098       Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1099       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1100
1101       Decl :=
1102         Make_Object_Declaration (Loc,
1103           Defining_Identifier => Elab_Ent,
1104           Object_Definition   =>
1105             New_Occurrence_Of (Standard_Short_Integer, Loc),
1106           Expression          => Make_Integer_Literal (Loc, Uint_0));
1107
1108       Push_Scope (Standard_Standard);
1109       Add_Global_Declaration (Decl);
1110       Pop_Scope;
1111
1112       --  Reset True_Constant indication, since we will indeed assign a value
1113       --  to the variable in the binder main. We also kill the Current_Value
1114       --  and Last_Assignment fields for the same reason.
1115
1116       Set_Is_True_Constant (Elab_Ent, False);
1117       Set_Current_Value    (Elab_Ent, Empty);
1118       Set_Last_Assignment  (Elab_Ent, Empty);
1119
1120       --  We do not want any further qualification of the name (if we did not
1121       --  do this, we would pick up the name of the generic package in the case
1122       --  of a library level generic instantiation).
1123
1124       Set_Has_Qualified_Name       (Elab_Ent);
1125       Set_Has_Fully_Qualified_Name (Elab_Ent);
1126    end Build_Elaboration_Entity;
1127
1128    --------------------------------
1129    -- Build_Explicit_Dereference --
1130    --------------------------------
1131
1132    procedure Build_Explicit_Dereference
1133      (Expr : Node_Id;
1134       Disc : Entity_Id)
1135    is
1136       Loc : constant Source_Ptr := Sloc (Expr);
1137    begin
1138
1139       --  An entity of a type with a reference aspect is overloaded with
1140       --  both interpretations: with and without the dereference. Now that
1141       --  the dereference is made explicit, set the type of the node properly,
1142       --  to prevent anomalies in the backend. Same if the expression is an
1143       --  overloaded function call whose return type has a reference aspect.
1144
1145       if Is_Entity_Name (Expr) then
1146          Set_Etype (Expr, Etype (Entity (Expr)));
1147
1148       elsif Nkind (Expr) = N_Function_Call then
1149          Set_Etype (Expr, Etype (Name (Expr)));
1150       end if;
1151
1152       Set_Is_Overloaded (Expr, False);
1153       Rewrite (Expr,
1154         Make_Explicit_Dereference (Loc,
1155           Prefix =>
1156             Make_Selected_Component (Loc,
1157               Prefix        => Relocate_Node (Expr),
1158               Selector_Name => New_Occurrence_Of (Disc, Loc))));
1159       Set_Etype (Prefix (Expr), Etype (Disc));
1160       Set_Etype (Expr, Designated_Type (Etype (Disc)));
1161    end Build_Explicit_Dereference;
1162
1163    -----------------------------------
1164    -- Cannot_Raise_Constraint_Error --
1165    -----------------------------------
1166
1167    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1168    begin
1169       if Compile_Time_Known_Value (Expr) then
1170          return True;
1171
1172       elsif Do_Range_Check (Expr) then
1173          return False;
1174
1175       elsif Raises_Constraint_Error (Expr) then
1176          return False;
1177
1178       else
1179          case Nkind (Expr) is
1180             when N_Identifier =>
1181                return True;
1182
1183             when N_Expanded_Name =>
1184                return True;
1185
1186             when N_Selected_Component =>
1187                return not Do_Discriminant_Check (Expr);
1188
1189             when N_Attribute_Reference =>
1190                if Do_Overflow_Check (Expr) then
1191                   return False;
1192
1193                elsif No (Expressions (Expr)) then
1194                   return True;
1195
1196                else
1197                   declare
1198                      N : Node_Id;
1199
1200                   begin
1201                      N := First (Expressions (Expr));
1202                      while Present (N) loop
1203                         if Cannot_Raise_Constraint_Error (N) then
1204                            Next (N);
1205                         else
1206                            return False;
1207                         end if;
1208                      end loop;
1209
1210                      return True;
1211                   end;
1212                end if;
1213
1214             when N_Type_Conversion =>
1215                if Do_Overflow_Check (Expr)
1216                  or else Do_Length_Check (Expr)
1217                  or else Do_Tag_Check (Expr)
1218                then
1219                   return False;
1220                else
1221                   return Cannot_Raise_Constraint_Error (Expression (Expr));
1222                end if;
1223
1224             when N_Unchecked_Type_Conversion =>
1225                return Cannot_Raise_Constraint_Error (Expression (Expr));
1226
1227             when N_Unary_Op =>
1228                if Do_Overflow_Check (Expr) then
1229                   return False;
1230                else
1231                   return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1232                end if;
1233
1234             when N_Op_Divide |
1235                  N_Op_Mod    |
1236                  N_Op_Rem
1237             =>
1238                if Do_Division_Check (Expr)
1239                  or else Do_Overflow_Check (Expr)
1240                then
1241                   return False;
1242                else
1243                   return
1244                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1245                       and then
1246                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1247                end if;
1248
1249             when N_Op_Add                    |
1250                  N_Op_And                    |
1251                  N_Op_Concat                 |
1252                  N_Op_Eq                     |
1253                  N_Op_Expon                  |
1254                  N_Op_Ge                     |
1255                  N_Op_Gt                     |
1256                  N_Op_Le                     |
1257                  N_Op_Lt                     |
1258                  N_Op_Multiply               |
1259                  N_Op_Ne                     |
1260                  N_Op_Or                     |
1261                  N_Op_Rotate_Left            |
1262                  N_Op_Rotate_Right           |
1263                  N_Op_Shift_Left             |
1264                  N_Op_Shift_Right            |
1265                  N_Op_Shift_Right_Arithmetic |
1266                  N_Op_Subtract               |
1267                  N_Op_Xor
1268             =>
1269                if Do_Overflow_Check (Expr) then
1270                   return False;
1271                else
1272                   return
1273                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1274                       and then
1275                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1276                end if;
1277
1278             when others =>
1279                return False;
1280          end case;
1281       end if;
1282    end Cannot_Raise_Constraint_Error;
1283
1284    -----------------------------------------
1285    -- Check_Dynamically_Tagged_Expression --
1286    -----------------------------------------
1287
1288    procedure Check_Dynamically_Tagged_Expression
1289      (Expr        : Node_Id;
1290       Typ         : Entity_Id;
1291       Related_Nod : Node_Id)
1292    is
1293    begin
1294       pragma Assert (Is_Tagged_Type (Typ));
1295
1296       --  In order to avoid spurious errors when analyzing the expanded code,
1297       --  this check is done only for nodes that come from source and for
1298       --  actuals of generic instantiations.
1299
1300       if (Comes_From_Source (Related_Nod)
1301            or else In_Generic_Actual (Expr))
1302         and then (Is_Class_Wide_Type (Etype (Expr))
1303                    or else Is_Dynamically_Tagged (Expr))
1304         and then Is_Tagged_Type (Typ)
1305         and then not Is_Class_Wide_Type (Typ)
1306       then
1307          Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1308       end if;
1309    end Check_Dynamically_Tagged_Expression;
1310
1311    -----------------------------------------------
1312    -- Check_Expression_Against_Static_Predicate --
1313    -----------------------------------------------
1314
1315    procedure Check_Expression_Against_Static_Predicate
1316      (Expr : Node_Id;
1317       Typ  : Entity_Id)
1318    is
1319    begin
1320       --  When the predicate is static and the value of the expression is known
1321       --  at compile time, evaluate the predicate check. A type is non-static
1322       --  when it has aspect Dynamic_Predicate.
1323
1324       if Compile_Time_Known_Value (Expr)
1325         and then Has_Predicates (Typ)
1326         and then Present (Static_Predicate (Typ))
1327         and then not Has_Dynamic_Predicate_Aspect (Typ)
1328       then
1329          --  Either -gnatc is enabled or the expression is ok
1330
1331          if Operating_Mode < Generate_Code
1332            or else Eval_Static_Predicate_Check (Expr, Typ)
1333          then
1334             null;
1335
1336          --  The expression is prohibited by the static predicate
1337
1338          else
1339             Error_Msg_NE
1340               ("?static expression fails static predicate check on &",
1341                Expr, Typ);
1342          end if;
1343       end if;
1344    end Check_Expression_Against_Static_Predicate;
1345
1346    --------------------------
1347    -- Check_Fully_Declared --
1348    --------------------------
1349
1350    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1351    begin
1352       if Ekind (T) = E_Incomplete_Type then
1353
1354          --  Ada 2005 (AI-50217): If the type is available through a limited
1355          --  with_clause, verify that its full view has been analyzed.
1356
1357          if From_With_Type (T)
1358            and then Present (Non_Limited_View (T))
1359            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1360          then
1361             --  The non-limited view is fully declared
1362             null;
1363
1364          else
1365             Error_Msg_NE
1366               ("premature usage of incomplete}", N, First_Subtype (T));
1367          end if;
1368
1369       --  Need comments for these tests ???
1370
1371       elsif Has_Private_Component (T)
1372         and then not Is_Generic_Type (Root_Type (T))
1373         and then not In_Spec_Expression
1374       then
1375          --  Special case: if T is the anonymous type created for a single
1376          --  task or protected object, use the name of the source object.
1377
1378          if Is_Concurrent_Type (T)
1379            and then not Comes_From_Source (T)
1380            and then Nkind (N) = N_Object_Declaration
1381          then
1382             Error_Msg_NE ("type of& has incomplete component", N,
1383               Defining_Identifier (N));
1384
1385          else
1386             Error_Msg_NE
1387               ("premature usage of incomplete}", N, First_Subtype (T));
1388          end if;
1389       end if;
1390    end Check_Fully_Declared;
1391
1392    -------------------------------------
1393    -- Check_Function_Writable_Actuals --
1394    -------------------------------------
1395
1396    procedure Check_Function_Writable_Actuals (N : Node_Id) is
1397       Writable_Actuals_List : Elist_Id := No_Elist;
1398       Identifiers_List      : Elist_Id := No_Elist;
1399       Error_Node            : Node_Id  := Empty;
1400
1401       procedure Collect_Identifiers (N : Node_Id);
1402       --  In a single traversal of subtree N collect in Writable_Actuals_List
1403       --  all the actuals of functions with writable actuals, and in the list
1404       --  Identifiers_List collect all the identifiers that are not actuals of
1405       --  functions with writable actuals. If a writable actual is referenced
1406       --  twice as writable actual then Error_Node is set to reference its
1407       --  second occurrence, the error is reported, and the tree traversal
1408       --  is abandoned.
1409
1410       function Get_Function_Id (Call : Node_Id) return Entity_Id;
1411       --  Return the entity associated with the function call
1412
1413       procedure Preanalyze_Without_Errors (N : Node_Id);
1414       --  Preanalyze N without reporting errors. Very dubious, you can't just
1415       --  go analyzing things more than once???
1416
1417       -------------------------
1418       -- Collect_Identifiers --
1419       -------------------------
1420
1421       procedure Collect_Identifiers (N : Node_Id) is
1422
1423          function Check_Node (N : Node_Id) return Traverse_Result;
1424          --  Process a single node during the tree traversal to collect the
1425          --  writable actuals of functions and all the identifiers which are
1426          --  not writable actuals of functions.
1427
1428          function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1429          --  Returns True if List has a node whose Entity is Entity (N)
1430
1431          -------------------------
1432          -- Check_Function_Call --
1433          -------------------------
1434
1435          function Check_Node (N : Node_Id) return Traverse_Result is
1436             Is_Writable_Actual : Boolean := False;
1437
1438          begin
1439             if Nkind (N) = N_Identifier then
1440
1441                --  No analysis possible if the entity is not decorated
1442
1443                if No (Entity (N)) then
1444                   return Skip;
1445
1446                --  Don't collect identifiers of packages, called functions, etc
1447
1448                elsif Ekind_In (Entity (N), E_Package,
1449                                            E_Function,
1450                                            E_Procedure,
1451                                            E_Entry)
1452                then
1453                   return Skip;
1454
1455                --  Analyze if N is a writable actual of a function
1456
1457                elsif Nkind (Parent (N)) = N_Function_Call then
1458                   declare
1459                      Call   : constant Node_Id   := Parent (N);
1460                      Id     : constant Entity_Id := Get_Function_Id (Call);
1461                      Actual : Node_Id;
1462                      Formal : Node_Id;
1463
1464                   begin
1465                      Formal := First_Formal (Id);
1466                      Actual := First_Actual (Call);
1467                      while Present (Actual) and then Present (Formal) loop
1468                         if Actual = N then
1469                            if Ekind_In (Formal, E_Out_Parameter,
1470                                                 E_In_Out_Parameter)
1471                            then
1472                               Is_Writable_Actual := True;
1473                            end if;
1474
1475                            exit;
1476                         end if;
1477
1478                         Next_Formal (Formal);
1479                         Next_Actual (Actual);
1480                      end loop;
1481                   end;
1482                end if;
1483
1484                if Is_Writable_Actual then
1485                   if Contains (Writable_Actuals_List, N) then
1486                      Error_Msg_N
1487                        ("conflict of writable function parameter in "
1488                         & "construct with arbitrary order of evaluation", N);
1489                      Error_Node := N;
1490                      return Abandon;
1491                   end if;
1492
1493                   if Writable_Actuals_List = No_Elist then
1494                      Writable_Actuals_List := New_Elmt_List;
1495                   end if;
1496
1497                   Append_Elmt (N, Writable_Actuals_List);
1498                else
1499                   if Identifiers_List = No_Elist then
1500                      Identifiers_List := New_Elmt_List;
1501                   end if;
1502
1503                   Append_Unique_Elmt (N, Identifiers_List);
1504                end if;
1505             end if;
1506
1507             return OK;
1508          end Check_Node;
1509
1510          --------------
1511          -- Contains --
1512          --------------
1513
1514          function Contains
1515            (List : Elist_Id;
1516             N    : Node_Id) return Boolean
1517          is
1518             pragma Assert (Nkind (N) in N_Has_Entity);
1519
1520             Elmt : Elmt_Id;
1521
1522          begin
1523             if List = No_Elist then
1524                return False;
1525             end if;
1526
1527             Elmt := First_Elmt (List);
1528             while Present (Elmt) loop
1529                if Entity (Node (Elmt)) = Entity (N) then
1530                   return True;
1531                else
1532                   Next_Elmt (Elmt);
1533                end if;
1534             end loop;
1535
1536             return False;
1537          end Contains;
1538
1539          ------------------
1540          -- Do_Traversal --
1541          ------------------
1542
1543          procedure Do_Traversal is new Traverse_Proc (Check_Node);
1544          --  The traversal procedure
1545
1546       --  Start of processing for Collect_Identifiers
1547
1548       begin
1549          if Present (Error_Node) then
1550             return;
1551          end if;
1552
1553          if Nkind (N) in N_Subexpr
1554            and then Is_Static_Expression (N)
1555          then
1556             return;
1557          end if;
1558
1559          Do_Traversal (N);
1560       end Collect_Identifiers;
1561
1562       ---------------------
1563       -- Get_Function_Id --
1564       ---------------------
1565
1566       function Get_Function_Id (Call : Node_Id) return Entity_Id is
1567          Nam : constant Node_Id := Name (Call);
1568          Id  : Entity_Id;
1569
1570       begin
1571          if Nkind (Nam) = N_Explicit_Dereference then
1572             Id := Etype (Nam);
1573             pragma Assert (Ekind (Id) = E_Subprogram_Type);
1574
1575          elsif Nkind (Nam) = N_Selected_Component then
1576             Id := Entity (Selector_Name (Nam));
1577
1578          elsif Nkind (Nam) = N_Indexed_Component then
1579             Id := Entity (Selector_Name (Prefix (Nam)));
1580
1581          else
1582             Id := Entity (Nam);
1583          end if;
1584
1585          return Id;
1586       end Get_Function_Id;
1587
1588       ---------------------------
1589       -- Preanalyze_Expression --
1590       ---------------------------
1591
1592       procedure Preanalyze_Without_Errors (N : Node_Id) is
1593          Status : constant Boolean := Get_Ignore_Errors;
1594       begin
1595          Set_Ignore_Errors (True);
1596          Preanalyze (N);
1597          Set_Ignore_Errors (Status);
1598       end Preanalyze_Without_Errors;
1599
1600    --  Start of processing for Check_Function_Writable_Actuals
1601
1602    begin
1603       if Ada_Version < Ada_2012
1604         or else (not (Nkind (N) in N_Op)
1605                   and then not (Nkind (N) in N_Membership_Test)
1606                   and then not Nkind_In (N, N_Range,
1607                                             N_Aggregate,
1608                                             N_Extension_Aggregate,
1609                                             N_Full_Type_Declaration,
1610                                             N_Function_Call,
1611                                             N_Procedure_Call_Statement,
1612                                             N_Entry_Call_Statement))
1613         or else (Nkind (N) = N_Full_Type_Declaration
1614                    and then not Is_Record_Type (Defining_Identifier (N)))
1615       then
1616          return;
1617       end if;
1618
1619       --  If a construct C has two or more direct constituents that are names
1620       --  or expressions whose evaluation may occur in an arbitrary order, at
1621       --  least one of which contains a function call with an in out or out
1622       --  parameter, then the construct is legal only if: for each name N that
1623       --  is passed as a parameter of mode in out or out to some inner function
1624       --  call C2 (not including the construct C itself), there is no other
1625       --  name anywhere within a direct constituent of the construct C other
1626       --  than the one containing C2, that is known to refer to the same
1627       --  object (RM 6.4.1(6.17/3)).
1628
1629       case Nkind (N) is
1630          when N_Range =>
1631             Collect_Identifiers (Low_Bound (N));
1632             Collect_Identifiers (High_Bound (N));
1633
1634          when N_Op | N_Membership_Test =>
1635             declare
1636                Expr : Node_Id;
1637             begin
1638                Collect_Identifiers (Left_Opnd (N));
1639
1640                if Present (Right_Opnd (N)) then
1641                   Collect_Identifiers (Right_Opnd (N));
1642                end if;
1643
1644                if Nkind_In (N, N_In, N_Not_In)
1645                  and then Present (Alternatives (N))
1646                then
1647                   Expr := First (Alternatives (N));
1648                   while Present (Expr) loop
1649                      Collect_Identifiers (Expr);
1650
1651                      Next (Expr);
1652                   end loop;
1653                end if;
1654             end;
1655
1656          when N_Full_Type_Declaration =>
1657             declare
1658                function Get_Record_Part (N : Node_Id) return Node_Id;
1659                --  Return the record part of this record type definition
1660
1661                function Get_Record_Part (N : Node_Id) return Node_Id is
1662                   Type_Def : constant Node_Id := Type_Definition (N);
1663                begin
1664                   if Nkind (Type_Def) = N_Derived_Type_Definition then
1665                      return Record_Extension_Part (Type_Def);
1666                   else
1667                      return Type_Def;
1668                   end if;
1669                end Get_Record_Part;
1670
1671                Comp   : Node_Id;
1672                Def_Id : Entity_Id := Defining_Identifier (N);
1673                Rec    : Node_Id   := Get_Record_Part (N);
1674
1675             begin
1676                --  No need to perform any analysis if the record has no
1677                --  components
1678
1679                if No (Rec) or else No (Component_List (Rec)) then
1680                   return;
1681                end if;
1682
1683                --  Collect the identifiers starting from the deepest
1684                --  derivation. Done to report the error in the deepest
1685                --  derivation.
1686
1687                loop
1688                   if Present (Component_List (Rec)) then
1689                      Comp := First (Component_Items (Component_List (Rec)));
1690                      while Present (Comp) loop
1691                         if Nkind (Comp) = N_Component_Declaration
1692                           and then Present (Expression (Comp))
1693                         then
1694                            Collect_Identifiers (Expression (Comp));
1695                         end if;
1696
1697                         Next (Comp);
1698                      end loop;
1699                   end if;
1700
1701                   exit when No (Underlying_Type (Etype (Def_Id)))
1702                     or else Base_Type (Underlying_Type (Etype (Def_Id)))
1703                               = Def_Id;
1704
1705                   Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
1706                   Rec := Get_Record_Part (Parent (Def_Id));
1707                end loop;
1708             end;
1709
1710          when N_Subprogram_Call      |
1711               N_Entry_Call_Statement =>
1712             declare
1713                Id     : constant Entity_Id := Get_Function_Id (N);
1714                Formal : Node_Id;
1715                Actual : Node_Id;
1716
1717             begin
1718                Formal := First_Formal (Id);
1719                Actual := First_Actual (N);
1720                while Present (Actual) and then Present (Formal) loop
1721                   if Ekind_In (Formal, E_Out_Parameter,
1722                                        E_In_Out_Parameter)
1723                   then
1724                      Collect_Identifiers (Actual);
1725                   end if;
1726
1727                   Next_Formal (Formal);
1728                   Next_Actual (Actual);
1729                end loop;
1730             end;
1731
1732          when N_Aggregate           |
1733               N_Extension_Aggregate =>
1734             declare
1735                Assoc     : Node_Id;
1736                Choice    : Node_Id;
1737                Comp_Expr : Node_Id;
1738
1739             begin
1740                --  Handle the N_Others_Choice of array aggregates with static
1741                --  bounds. There is no need to perform this analysis in
1742                --  aggregates without static bounds since we cannot evaluate
1743                --  if the N_Others_Choice covers several elements. There is
1744                --  no need to handle the N_Others choice of record aggregates
1745                --  since at this stage it has been already expanded by
1746                --  Resolve_Record_Aggregate.
1747
1748                if Is_Array_Type (Etype (N))
1749                  and then Nkind (N) = N_Aggregate
1750                  and then Present (Aggregate_Bounds (N))
1751                  and then Compile_Time_Known_Bounds (Etype (N))
1752                  and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
1753                             > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
1754                then
1755                   declare
1756                      Count_Components   : Uint := Uint_0;
1757                      Num_Components     : Uint;
1758                      Others_Assoc       : Node_Id;
1759                      Others_Choice      : Node_Id := Empty;
1760                      Others_Box_Present : Boolean := False;
1761
1762                   begin
1763                      --  Count positional associations
1764
1765                      if Present (Expressions (N)) then
1766                         Comp_Expr := First (Expressions (N));
1767                         while Present (Comp_Expr) loop
1768                            Count_Components := Count_Components + 1;
1769                            Next (Comp_Expr);
1770                         end loop;
1771                      end if;
1772
1773                      --  Count the rest of elements and locate the N_Others
1774                      --  choice (if any)
1775
1776                      Assoc := First (Component_Associations (N));
1777                      while Present (Assoc) loop
1778                         Choice := First (Choices (Assoc));
1779                         while Present (Choice) loop
1780                            if Nkind (Choice) = N_Others_Choice then
1781                               Others_Assoc       := Assoc;
1782                               Others_Choice      := Choice;
1783                               Others_Box_Present := Box_Present (Assoc);
1784
1785                            --  Count several components
1786
1787                            elsif Nkind_In (Choice, N_Range,
1788                                                    N_Subtype_Indication)
1789                              or else (Is_Entity_Name (Choice)
1790                                         and then Is_Type (Entity (Choice)))
1791                            then
1792                               declare
1793                                  L, H : Node_Id;
1794                               begin
1795                                  Get_Index_Bounds (Choice, L, H);
1796                                  pragma Assert
1797                                    (Compile_Time_Known_Value (L)
1798                                       and then Compile_Time_Known_Value (H));
1799                                  Count_Components :=
1800                                    Count_Components
1801                                      + Expr_Value (H) - Expr_Value (L) + 1;
1802                               end;
1803
1804                            --  Count single component. No other case available
1805                            --  since we are handling an aggregate with static
1806                            --  bounds.
1807
1808                            else
1809                               pragma Assert (Is_Static_Expression (Choice)
1810                                 or else Nkind (Choice) = N_Identifier
1811                                 or else Nkind (Choice) = N_Integer_Literal);
1812
1813                               Count_Components := Count_Components + 1;
1814                            end if;
1815
1816                            Next (Choice);
1817                         end loop;
1818
1819                         Next (Assoc);
1820                      end loop;
1821
1822                      Num_Components :=
1823                        Expr_Value (High_Bound (Aggregate_Bounds (N))) -
1824                          Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
1825
1826                      pragma Assert (Count_Components <= Num_Components);
1827
1828                      --  Handle the N_Others choice if it covers several
1829                      --  components
1830
1831                      if Present (Others_Choice)
1832                        and then (Num_Components - Count_Components) > 1
1833                      then
1834                         if not Others_Box_Present then
1835
1836                            --  At this stage, if expansion is active, the
1837                            --  expression of the others choice has not been
1838                            --  analyzed. Hence we generate a duplicate and
1839                            --  we analyze it silently to have available the
1840                            --  minimum decoration required to collect the
1841                            --  identifiers.
1842
1843                            if not Expander_Active then
1844                               Comp_Expr := Expression (Others_Assoc);
1845                            else
1846                               Comp_Expr :=
1847                                 New_Copy_Tree (Expression (Others_Assoc));
1848                               Preanalyze_Without_Errors (Comp_Expr);
1849                            end if;
1850
1851                            Collect_Identifiers (Comp_Expr);
1852
1853                            if Writable_Actuals_List /= No_Elist then
1854
1855                               --  As suggested by Robert, at current stage we
1856                               --  report occurrences of this case as warnings.
1857
1858                               Error_Msg_N
1859                                 ("conflict of writable function parameter in "
1860                                  & "construct with arbitrary order of "
1861                                  & "evaluation?",
1862                                  Node (First_Elmt (Writable_Actuals_List)));
1863                            end if;
1864                         end if;
1865                      end if;
1866                   end;
1867                end if;
1868
1869                --  Handle ancestor part of extension aggregates
1870
1871                if Nkind (N) = N_Extension_Aggregate then
1872                   Collect_Identifiers (Ancestor_Part (N));
1873                end if;
1874
1875                --  Handle positional associations
1876
1877                if Present (Expressions (N)) then
1878                   Comp_Expr := First (Expressions (N));
1879                   while Present (Comp_Expr) loop
1880                      if not Is_Static_Expression (Comp_Expr) then
1881                         Collect_Identifiers (Comp_Expr);
1882                      end if;
1883
1884                      Next (Comp_Expr);
1885                   end loop;
1886                end if;
1887
1888                --  Handle discrete associations
1889
1890                if Present (Component_Associations (N)) then
1891                   Assoc := First (Component_Associations (N));
1892                   while Present (Assoc) loop
1893
1894                      if not Box_Present (Assoc) then
1895                         Choice := First (Choices (Assoc));
1896                         while Present (Choice) loop
1897
1898                            --  For now we skip discriminants since it requires
1899                            --  performing the analysis in two phases: first one
1900                            --  analyzing discriminants and second one analyzing
1901                            --  the rest of components since discriminants are
1902                            --  evaluated prior to components: too much extra
1903                            --  work to detect a corner case???
1904
1905                            if Nkind (Choice) in N_Has_Entity
1906                              and then Present (Entity (Choice))
1907                              and then Ekind (Entity (Choice)) = E_Discriminant
1908                            then
1909                               null;
1910
1911                            elsif Box_Present (Assoc) then
1912                               null;
1913
1914                            else
1915                               if not Analyzed (Expression (Assoc)) then
1916                                  Comp_Expr :=
1917                                    New_Copy_Tree (Expression (Assoc));
1918                                  Set_Parent (Comp_Expr, Parent (N));
1919                                  Preanalyze_Without_Errors (Comp_Expr);
1920                               else
1921                                  Comp_Expr := Expression (Assoc);
1922                               end if;
1923
1924                               Collect_Identifiers (Comp_Expr);
1925                            end if;
1926
1927                            Next (Choice);
1928                         end loop;
1929                      end if;
1930
1931                      Next (Assoc);
1932                   end loop;
1933                end if;
1934             end;
1935
1936          when others =>
1937             return;
1938       end case;
1939
1940       --  No further action needed if we already reported an error
1941
1942       if Present (Error_Node) then
1943          return;
1944       end if;
1945
1946       --  Check if some writable argument of a function is referenced
1947
1948       if Writable_Actuals_List /= No_Elist
1949         and then Identifiers_List /= No_Elist
1950       then
1951          declare
1952             Elmt_1 : Elmt_Id;
1953             Elmt_2 : Elmt_Id;
1954
1955          begin
1956             Elmt_1 := First_Elmt (Writable_Actuals_List);
1957             while Present (Elmt_1) loop
1958                Elmt_2 := First_Elmt (Identifiers_List);
1959                while Present (Elmt_2) loop
1960                   if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
1961                      Error_Msg_N
1962                        ("conflict of writable function parameter in construct "
1963                         & "with arbitrary order of evaluation",
1964                         Node (Elmt_1));
1965                   end if;
1966
1967                   Next_Elmt (Elmt_2);
1968                end loop;
1969
1970                Next_Elmt (Elmt_1);
1971             end loop;
1972          end;
1973       end if;
1974    end Check_Function_Writable_Actuals;
1975
1976    --------------------------------
1977    -- Check_Implicit_Dereference --
1978    --------------------------------
1979
1980    procedure Check_Implicit_Dereference (Nam : Node_Id;  Typ : Entity_Id) is
1981       Disc  : Entity_Id;
1982       Desig : Entity_Id;
1983
1984    begin
1985       if Ada_Version < Ada_2012
1986         or else not Has_Implicit_Dereference (Base_Type (Typ))
1987       then
1988          return;
1989
1990       elsif not Comes_From_Source (Nam) then
1991          return;
1992
1993       elsif Is_Entity_Name (Nam)
1994         and then Is_Type (Entity (Nam))
1995       then
1996          null;
1997
1998       else
1999          Disc := First_Discriminant (Typ);
2000          while Present (Disc) loop
2001             if Has_Implicit_Dereference (Disc) then
2002                Desig := Designated_Type (Etype (Disc));
2003                Add_One_Interp (Nam, Disc, Desig);
2004                exit;
2005             end if;
2006
2007             Next_Discriminant (Disc);
2008          end loop;
2009       end if;
2010    end Check_Implicit_Dereference;
2011
2012    ----------------------------------
2013    -- Check_Internal_Protected_Use --
2014    ----------------------------------
2015
2016    procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2017       S    : Entity_Id;
2018       Prot : Entity_Id;
2019
2020    begin
2021       S := Current_Scope;
2022       while Present (S) loop
2023          if S = Standard_Standard then
2024             return;
2025
2026          elsif Ekind (S) = E_Function
2027            and then Ekind (Scope (S)) = E_Protected_Type
2028          then
2029             Prot := Scope (S);
2030             exit;
2031          end if;
2032
2033          S := Scope (S);
2034       end loop;
2035
2036       if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2037          if Nkind (N) = N_Subprogram_Renaming_Declaration then
2038             Error_Msg_N
2039               ("within protected function cannot use protected "
2040                & "procedure in renaming or as generic actual", N);
2041
2042          elsif Nkind (N) = N_Attribute_Reference then
2043             Error_Msg_N
2044               ("within protected function cannot take access of "
2045                & " protected procedure", N);
2046
2047          else
2048             Error_Msg_N
2049               ("within protected function, protected object is constant", N);
2050             Error_Msg_N
2051               ("\cannot call operation that may modify it", N);
2052          end if;
2053       end if;
2054    end Check_Internal_Protected_Use;
2055
2056    ---------------------------------------
2057    -- Check_Later_Vs_Basic_Declarations --
2058    ---------------------------------------
2059
2060    procedure Check_Later_Vs_Basic_Declarations
2061      (Decls          : List_Id;
2062       During_Parsing : Boolean)
2063    is
2064       Body_Sloc : Source_Ptr;
2065       Decl      : Node_Id;
2066
2067       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2068       --  Return whether Decl is considered as a declarative item.
2069       --  When During_Parsing is True, the semantics of Ada 83 is followed.
2070       --  When During_Parsing is False, the semantics of SPARK is followed.
2071
2072       -------------------------------
2073       -- Is_Later_Declarative_Item --
2074       -------------------------------
2075
2076       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2077       begin
2078          if Nkind (Decl) in N_Later_Decl_Item then
2079             return True;
2080
2081          elsif Nkind (Decl) = N_Pragma then
2082             return True;
2083
2084          elsif During_Parsing then
2085             return False;
2086
2087          --  In SPARK, a package declaration is not considered as a later
2088          --  declarative item.
2089
2090          elsif Nkind (Decl) = N_Package_Declaration then
2091             return False;
2092
2093          --  In SPARK, a renaming is considered as a later declarative item
2094
2095          elsif Nkind (Decl) in N_Renaming_Declaration then
2096             return True;
2097
2098          else
2099             return False;
2100          end if;
2101       end Is_Later_Declarative_Item;
2102
2103    --  Start of Check_Later_Vs_Basic_Declarations
2104
2105    begin
2106       Decl := First (Decls);
2107
2108       --  Loop through sequence of basic declarative items
2109
2110       Outer : while Present (Decl) loop
2111          if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2112            and then Nkind (Decl) not in N_Body_Stub
2113          then
2114             Next (Decl);
2115
2116             --  Once a body is encountered, we only allow later declarative
2117             --  items. The inner loop checks the rest of the list.
2118
2119          else
2120             Body_Sloc := Sloc (Decl);
2121
2122             Inner : while Present (Decl) loop
2123                if not Is_Later_Declarative_Item (Decl) then
2124                   if During_Parsing then
2125                      if Ada_Version = Ada_83 then
2126                         Error_Msg_Sloc := Body_Sloc;
2127                         Error_Msg_N
2128                           ("(Ada 83) decl cannot appear after body#", Decl);
2129                      end if;
2130                   else
2131                      Error_Msg_Sloc := Body_Sloc;
2132                      Check_SPARK_Restriction
2133                        ("decl cannot appear after body#", Decl);
2134                   end if;
2135                end if;
2136
2137                Next (Decl);
2138             end loop Inner;
2139          end if;
2140       end loop Outer;
2141    end Check_Later_Vs_Basic_Declarations;
2142
2143    -------------------------
2144    -- Check_Nested_Access --
2145    -------------------------
2146
2147    procedure Check_Nested_Access (Ent : Entity_Id) is
2148       Scop         : constant Entity_Id := Current_Scope;
2149       Current_Subp : Entity_Id;
2150       Enclosing    : Entity_Id;
2151
2152    begin
2153       --  Currently only enabled for VM back-ends for efficiency, should we
2154       --  enable it more systematically ???
2155
2156       --  Check for Is_Imported needs commenting below ???
2157
2158       if VM_Target /= No_VM
2159         and then (Ekind (Ent) = E_Variable
2160                     or else
2161                   Ekind (Ent) = E_Constant
2162                     or else
2163                   Ekind (Ent) = E_Loop_Parameter)
2164         and then Scope (Ent) /= Empty
2165         and then not Is_Library_Level_Entity (Ent)
2166         and then not Is_Imported (Ent)
2167       then
2168          if Is_Subprogram (Scop)
2169            or else Is_Generic_Subprogram (Scop)
2170            or else Is_Entry (Scop)
2171          then
2172             Current_Subp := Scop;
2173          else
2174             Current_Subp := Current_Subprogram;
2175          end if;
2176
2177          Enclosing := Enclosing_Subprogram (Ent);
2178
2179          if Enclosing /= Empty
2180            and then Enclosing /= Current_Subp
2181          then
2182             Set_Has_Up_Level_Access (Ent, True);
2183          end if;
2184       end if;
2185    end Check_Nested_Access;
2186
2187    ---------------------------
2188    -- Check_No_Hidden_State --
2189    ---------------------------
2190
2191    procedure Check_No_Hidden_State (Id : Entity_Id) is
2192       function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2193       --  Determine whether the entity of a package denoted by Pkg has a null
2194       --  abstract state.
2195
2196       -----------------------------
2197       -- Has_Null_Abstract_State --
2198       -----------------------------
2199
2200       function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2201          States : constant Elist_Id := Abstract_States (Pkg);
2202
2203       begin
2204          --  Check first available state of related package. A null abstract
2205          --  state always appears as the sole element of the state list.
2206
2207          return
2208            Present (States)
2209              and then Is_Null_State (Node (First_Elmt (States)));
2210       end Has_Null_Abstract_State;
2211
2212       --  Local variables
2213
2214       Context     : Entity_Id := Empty;
2215       Not_Visible : Boolean   := False;
2216       Scop        : Entity_Id;
2217
2218    --  Start of processing for Check_No_Hidden_State
2219
2220    begin
2221       pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2222
2223       --  Find the proper context where the object or state appears
2224
2225       Scop := Scope (Id);
2226       while Present (Scop) loop
2227          Context := Scop;
2228
2229          --  Keep track of the context's visibility
2230
2231          Not_Visible := Not_Visible or else In_Private_Part (Context);
2232
2233          --  Prevent the search from going too far
2234
2235          if Context = Standard_Standard then
2236             return;
2237
2238          --  Objects and states that appear immediately within a subprogram or
2239          --  inside a construct nested within a subprogram do not introduce a
2240          --  hidden state. They behave as local variable declarations.
2241
2242          elsif Is_Subprogram (Context) then
2243             return;
2244
2245          --  When examining a package body, use the entity of the spec as it
2246          --  carries the abstract state declarations.
2247
2248          elsif Ekind (Context) = E_Package_Body then
2249             Context := Spec_Entity (Context);
2250          end if;
2251
2252          --  Stop the traversal when a package subject to a null abstract state
2253          --  has been found.
2254
2255          if Ekind_In (Context, E_Generic_Package, E_Package)
2256            and then Has_Null_Abstract_State (Context)
2257          then
2258             exit;
2259          end if;
2260
2261          Scop := Scope (Scop);
2262       end loop;
2263
2264       --  At this point we know that there is at least one package with a null
2265       --  abstract state in visibility. Emit an error message unconditionally
2266       --  if the entity being processed is a state because the placement of the
2267       --  related package is irrelevant. This is not the case for objects as
2268       --  the intermediate context matters.
2269
2270       if Present (Context)
2271         and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2272       then
2273          Error_Msg_N ("cannot introduce hidden state &", Id);
2274          Error_Msg_NE ("\package & has null abstract state", Id, Context);
2275       end if;
2276    end Check_No_Hidden_State;
2277
2278    ------------------------------------------
2279    -- Check_Potentially_Blocking_Operation --
2280    ------------------------------------------
2281
2282    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2283       S : Entity_Id;
2284
2285    begin
2286       --  N is one of the potentially blocking operations listed in 9.5.1(8).
2287       --  When pragma Detect_Blocking is active, the run time will raise
2288       --  Program_Error. Here we only issue a warning, since we generally
2289       --  support the use of potentially blocking operations in the absence
2290       --  of the pragma.
2291
2292       --  Indirect blocking through a subprogram call cannot be diagnosed
2293       --  statically without interprocedural analysis, so we do not attempt
2294       --  to do it here.
2295
2296       S := Scope (Current_Scope);
2297       while Present (S) and then S /= Standard_Standard loop
2298          if Is_Protected_Type (S) then
2299             Error_Msg_N
2300               ("potentially blocking operation in protected operation??", N);
2301             return;
2302          end if;
2303
2304          S := Scope (S);
2305       end loop;
2306    end Check_Potentially_Blocking_Operation;
2307
2308    ------------------------------
2309    -- Check_Unprotected_Access --
2310    ------------------------------
2311
2312    procedure Check_Unprotected_Access
2313      (Context : Node_Id;
2314       Expr    : Node_Id)
2315    is
2316       Cont_Encl_Typ : Entity_Id;
2317       Pref_Encl_Typ : Entity_Id;
2318
2319       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2320       --  Check whether Obj is a private component of a protected object.
2321       --  Return the protected type where the component resides, Empty
2322       --  otherwise.
2323
2324       function Is_Public_Operation return Boolean;
2325       --  Verify that the enclosing operation is callable from outside the
2326       --  protected object, to minimize false positives.
2327
2328       ------------------------------
2329       -- Enclosing_Protected_Type --
2330       ------------------------------
2331
2332       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2333       begin
2334          if Is_Entity_Name (Obj) then
2335             declare
2336                Ent : Entity_Id := Entity (Obj);
2337
2338             begin
2339                --  The object can be a renaming of a private component, use
2340                --  the original record component.
2341
2342                if Is_Prival (Ent) then
2343                   Ent := Prival_Link (Ent);
2344                end if;
2345
2346                if Is_Protected_Type (Scope (Ent)) then
2347                   return Scope (Ent);
2348                end if;
2349             end;
2350          end if;
2351
2352          --  For indexed and selected components, recursively check the prefix
2353
2354          if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2355             return Enclosing_Protected_Type (Prefix (Obj));
2356
2357          --  The object does not denote a protected component
2358
2359          else
2360             return Empty;
2361          end if;
2362       end Enclosing_Protected_Type;
2363
2364       -------------------------
2365       -- Is_Public_Operation --
2366       -------------------------
2367
2368       function Is_Public_Operation return Boolean is
2369          S : Entity_Id;
2370          E : Entity_Id;
2371
2372       begin
2373          S := Current_Scope;
2374          while Present (S)
2375            and then S /= Pref_Encl_Typ
2376          loop
2377             if Scope (S) = Pref_Encl_Typ then
2378                E := First_Entity (Pref_Encl_Typ);
2379                while Present (E)
2380                  and then E /= First_Private_Entity (Pref_Encl_Typ)
2381                loop
2382                   if E = S then
2383                      return True;
2384                   end if;
2385                   Next_Entity (E);
2386                end loop;
2387             end if;
2388
2389             S := Scope (S);
2390          end loop;
2391
2392          return False;
2393       end Is_Public_Operation;
2394
2395    --  Start of processing for Check_Unprotected_Access
2396
2397    begin
2398       if Nkind (Expr) = N_Attribute_Reference
2399         and then Attribute_Name (Expr) = Name_Unchecked_Access
2400       then
2401          Cont_Encl_Typ := Enclosing_Protected_Type (Context);
2402          Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
2403
2404          --  Check whether we are trying to export a protected component to a
2405          --  context with an equal or lower access level.
2406
2407          if Present (Pref_Encl_Typ)
2408            and then No (Cont_Encl_Typ)
2409            and then Is_Public_Operation
2410            and then Scope_Depth (Pref_Encl_Typ) >=
2411                       Object_Access_Level (Context)
2412          then
2413             Error_Msg_N
2414               ("??possible unprotected access to protected data", Expr);
2415          end if;
2416       end if;
2417    end Check_Unprotected_Access;
2418
2419    ---------------
2420    -- Check_VMS --
2421    ---------------
2422
2423    procedure Check_VMS (Construct : Node_Id) is
2424    begin
2425       if not OpenVMS_On_Target then
2426          Error_Msg_N
2427            ("this construct is allowed only in Open'V'M'S", Construct);
2428       end if;
2429    end Check_VMS;
2430
2431    ------------------------
2432    -- Collect_Interfaces --
2433    ------------------------
2434
2435    procedure Collect_Interfaces
2436      (T               : Entity_Id;
2437       Ifaces_List     : out Elist_Id;
2438       Exclude_Parents : Boolean := False;
2439       Use_Full_View   : Boolean := True)
2440    is
2441       procedure Collect (Typ : Entity_Id);
2442       --  Subsidiary subprogram used to traverse the whole list
2443       --  of directly and indirectly implemented interfaces
2444
2445       -------------
2446       -- Collect --
2447       -------------
2448
2449       procedure Collect (Typ : Entity_Id) is
2450          Ancestor   : Entity_Id;
2451          Full_T     : Entity_Id;
2452          Id         : Node_Id;
2453          Iface      : Entity_Id;
2454
2455       begin
2456          Full_T := Typ;
2457
2458          --  Handle private types
2459
2460          if Use_Full_View
2461            and then Is_Private_Type (Typ)
2462            and then Present (Full_View (Typ))
2463          then
2464             Full_T := Full_View (Typ);
2465          end if;
2466
2467          --  Include the ancestor if we are generating the whole list of
2468          --  abstract interfaces.
2469
2470          if Etype (Full_T) /= Typ
2471
2472             --  Protect the frontend against wrong sources. For example:
2473
2474             --    package P is
2475             --      type A is tagged null record;
2476             --      type B is new A with private;
2477             --      type C is new A with private;
2478             --    private
2479             --      type B is new C with null record;
2480             --      type C is new B with null record;
2481             --    end P;
2482
2483            and then Etype (Full_T) /= T
2484          then
2485             Ancestor := Etype (Full_T);
2486             Collect (Ancestor);
2487
2488             if Is_Interface (Ancestor)
2489               and then not Exclude_Parents
2490             then
2491                Append_Unique_Elmt (Ancestor, Ifaces_List);
2492             end if;
2493          end if;
2494
2495          --  Traverse the graph of ancestor interfaces
2496
2497          if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
2498             Id := First (Abstract_Interface_List (Full_T));
2499             while Present (Id) loop
2500                Iface := Etype (Id);
2501
2502                --  Protect against wrong uses. For example:
2503                --    type I is interface;
2504                --    type O is tagged null record;
2505                --    type Wrong is new I and O with null record; -- ERROR
2506
2507                if Is_Interface (Iface) then
2508                   if Exclude_Parents
2509                     and then Etype (T) /= T
2510                     and then Interface_Present_In_Ancestor (Etype (T), Iface)
2511                   then
2512                      null;
2513                   else
2514                      Collect (Iface);
2515                      Append_Unique_Elmt (Iface, Ifaces_List);
2516                   end if;
2517                end if;
2518
2519                Next (Id);
2520             end loop;
2521          end if;
2522       end Collect;
2523
2524    --  Start of processing for Collect_Interfaces
2525
2526    begin
2527       pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
2528       Ifaces_List := New_Elmt_List;
2529       Collect (T);
2530    end Collect_Interfaces;
2531
2532    ----------------------------------
2533    -- Collect_Interface_Components --
2534    ----------------------------------
2535
2536    procedure Collect_Interface_Components
2537      (Tagged_Type     : Entity_Id;
2538       Components_List : out Elist_Id)
2539    is
2540       procedure Collect (Typ : Entity_Id);
2541       --  Subsidiary subprogram used to climb to the parents
2542
2543       -------------
2544       -- Collect --
2545       -------------
2546
2547       procedure Collect (Typ : Entity_Id) is
2548          Tag_Comp   : Entity_Id;
2549          Parent_Typ : Entity_Id;
2550
2551       begin
2552          --  Handle private types
2553
2554          if Present (Full_View (Etype (Typ))) then
2555             Parent_Typ := Full_View (Etype (Typ));
2556          else
2557             Parent_Typ := Etype (Typ);
2558          end if;
2559
2560          if Parent_Typ /= Typ
2561
2562             --  Protect the frontend against wrong sources. For example:
2563
2564             --    package P is
2565             --      type A is tagged null record;
2566             --      type B is new A with private;
2567             --      type C is new A with private;
2568             --    private
2569             --      type B is new C with null record;
2570             --      type C is new B with null record;
2571             --    end P;
2572
2573            and then Parent_Typ /= Tagged_Type
2574          then
2575             Collect (Parent_Typ);
2576          end if;
2577
2578          --  Collect the components containing tags of secondary dispatch
2579          --  tables.
2580
2581          Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
2582          while Present (Tag_Comp) loop
2583             pragma Assert (Present (Related_Type (Tag_Comp)));
2584             Append_Elmt (Tag_Comp, Components_List);
2585
2586             Tag_Comp := Next_Tag_Component (Tag_Comp);
2587          end loop;
2588       end Collect;
2589
2590    --  Start of processing for Collect_Interface_Components
2591
2592    begin
2593       pragma Assert (Ekind (Tagged_Type) = E_Record_Type
2594         and then Is_Tagged_Type (Tagged_Type));
2595
2596       Components_List := New_Elmt_List;
2597       Collect (Tagged_Type);
2598    end Collect_Interface_Components;
2599
2600    -----------------------------
2601    -- Collect_Interfaces_Info --
2602    -----------------------------
2603
2604    procedure Collect_Interfaces_Info
2605      (T               : Entity_Id;
2606       Ifaces_List     : out Elist_Id;
2607       Components_List : out Elist_Id;
2608       Tags_List       : out Elist_Id)
2609    is
2610       Comps_List : Elist_Id;
2611       Comp_Elmt  : Elmt_Id;
2612       Comp_Iface : Entity_Id;
2613       Iface_Elmt : Elmt_Id;
2614       Iface      : Entity_Id;
2615
2616       function Search_Tag (Iface : Entity_Id) return Entity_Id;
2617       --  Search for the secondary tag associated with the interface type
2618       --  Iface that is implemented by T.
2619
2620       ----------------
2621       -- Search_Tag --
2622       ----------------
2623
2624       function Search_Tag (Iface : Entity_Id) return Entity_Id is
2625          ADT : Elmt_Id;
2626       begin
2627          if not Is_CPP_Class (T) then
2628             ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
2629          else
2630             ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
2631          end if;
2632
2633          while Present (ADT)
2634             and then Is_Tag (Node (ADT))
2635             and then Related_Type (Node (ADT)) /= Iface
2636          loop
2637             --  Skip secondary dispatch table referencing thunks to user
2638             --  defined primitives covered by this interface.
2639
2640             pragma Assert (Has_Suffix (Node (ADT), 'P'));
2641             Next_Elmt (ADT);
2642
2643             --  Skip secondary dispatch tables of Ada types
2644
2645             if not Is_CPP_Class (T) then
2646
2647                --  Skip secondary dispatch table referencing thunks to
2648                --  predefined primitives.
2649
2650                pragma Assert (Has_Suffix (Node (ADT), 'Y'));
2651                Next_Elmt (ADT);
2652
2653                --  Skip secondary dispatch table referencing user-defined
2654                --  primitives covered by this interface.
2655
2656                pragma Assert (Has_Suffix (Node (ADT), 'D'));
2657                Next_Elmt (ADT);
2658
2659                --  Skip secondary dispatch table referencing predefined
2660                --  primitives.
2661
2662                pragma Assert (Has_Suffix (Node (ADT), 'Z'));
2663                Next_Elmt (ADT);
2664             end if;
2665          end loop;
2666
2667          pragma Assert (Is_Tag (Node (ADT)));
2668          return Node (ADT);
2669       end Search_Tag;
2670
2671    --  Start of processing for Collect_Interfaces_Info
2672
2673    begin
2674       Collect_Interfaces (T, Ifaces_List);
2675       Collect_Interface_Components (T, Comps_List);
2676
2677       --  Search for the record component and tag associated with each
2678       --  interface type of T.
2679
2680       Components_List := New_Elmt_List;
2681       Tags_List       := New_Elmt_List;
2682
2683       Iface_Elmt := First_Elmt (Ifaces_List);
2684       while Present (Iface_Elmt) loop
2685          Iface := Node (Iface_Elmt);
2686
2687          --  Associate the primary tag component and the primary dispatch table
2688          --  with all the interfaces that are parents of T
2689
2690          if Is_Ancestor (Iface, T, Use_Full_View => True) then
2691             Append_Elmt (First_Tag_Component (T), Components_List);
2692             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
2693
2694          --  Otherwise search for the tag component and secondary dispatch
2695          --  table of Iface
2696
2697          else
2698             Comp_Elmt := First_Elmt (Comps_List);
2699             while Present (Comp_Elmt) loop
2700                Comp_Iface := Related_Type (Node (Comp_Elmt));
2701
2702                if Comp_Iface = Iface
2703                  or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
2704                then
2705                   Append_Elmt (Node (Comp_Elmt), Components_List);
2706                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
2707                   exit;
2708                end if;
2709
2710                Next_Elmt (Comp_Elmt);
2711             end loop;
2712             pragma Assert (Present (Comp_Elmt));
2713          end if;
2714
2715          Next_Elmt (Iface_Elmt);
2716       end loop;
2717    end Collect_Interfaces_Info;
2718
2719    ---------------------
2720    -- Collect_Parents --
2721    ---------------------
2722
2723    procedure Collect_Parents
2724      (T             : Entity_Id;
2725       List          : out Elist_Id;
2726       Use_Full_View : Boolean := True)
2727    is
2728       Current_Typ : Entity_Id := T;
2729       Parent_Typ  : Entity_Id;
2730
2731    begin
2732       List := New_Elmt_List;
2733
2734       --  No action if the if the type has no parents
2735
2736       if T = Etype (T) then
2737          return;
2738       end if;
2739
2740       loop
2741          Parent_Typ := Etype (Current_Typ);
2742
2743          if Is_Private_Type (Parent_Typ)
2744            and then Present (Full_View (Parent_Typ))
2745            and then Use_Full_View
2746          then
2747             Parent_Typ := Full_View (Base_Type (Parent_Typ));
2748          end if;
2749
2750          Append_Elmt (Parent_Typ, List);
2751
2752          exit when Parent_Typ = Current_Typ;
2753          Current_Typ := Parent_Typ;
2754       end loop;
2755    end Collect_Parents;
2756
2757    ----------------------------------
2758    -- Collect_Primitive_Operations --
2759    ----------------------------------
2760
2761    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
2762       B_Type         : constant Entity_Id := Base_Type (T);
2763       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
2764       B_Scope        : Entity_Id          := Scope (B_Type);
2765       Op_List        : Elist_Id;
2766       Formal         : Entity_Id;
2767       Is_Prim        : Boolean;
2768       Is_Type_In_Pkg : Boolean;
2769       Formal_Derived : Boolean := False;
2770       Id             : Entity_Id;
2771
2772       function Match (E : Entity_Id) return Boolean;
2773       --  True if E's base type is B_Type, or E is of an anonymous access type
2774       --  and the base type of its designated type is B_Type.
2775
2776       -----------
2777       -- Match --
2778       -----------
2779
2780       function Match (E : Entity_Id) return Boolean is
2781          Etyp : Entity_Id := Etype (E);
2782
2783       begin
2784          if Ekind (Etyp) = E_Anonymous_Access_Type then
2785             Etyp := Designated_Type (Etyp);
2786          end if;
2787
2788          return Base_Type (Etyp) = B_Type;
2789       end Match;
2790
2791    --  Start of processing for Collect_Primitive_Operations
2792
2793    begin
2794       --  For tagged types, the primitive operations are collected as they
2795       --  are declared, and held in an explicit list which is simply returned.
2796
2797       if Is_Tagged_Type (B_Type) then
2798          return Primitive_Operations (B_Type);
2799
2800       --  An untagged generic type that is a derived type inherits the
2801       --  primitive operations of its parent type. Other formal types only
2802       --  have predefined operators, which are not explicitly represented.
2803
2804       elsif Is_Generic_Type (B_Type) then
2805          if Nkind (B_Decl) = N_Formal_Type_Declaration
2806            and then Nkind (Formal_Type_Definition (B_Decl))
2807              = N_Formal_Derived_Type_Definition
2808          then
2809             Formal_Derived := True;
2810          else
2811             return New_Elmt_List;
2812          end if;
2813       end if;
2814
2815       Op_List := New_Elmt_List;
2816
2817       if B_Scope = Standard_Standard then
2818          if B_Type = Standard_String then
2819             Append_Elmt (Standard_Op_Concat, Op_List);
2820
2821          elsif B_Type = Standard_Wide_String then
2822             Append_Elmt (Standard_Op_Concatw, Op_List);
2823
2824          else
2825             null;
2826          end if;
2827
2828       --  Locate the primitive subprograms of the type
2829
2830       else
2831          --  The primitive operations appear after the base type, except
2832          --  if the derivation happens within the private part of B_Scope
2833          --  and the type is a private type, in which case both the type
2834          --  and some primitive operations may appear before the base
2835          --  type, and the list of candidates starts after the type.
2836
2837          if In_Open_Scopes (B_Scope)
2838            and then Scope (T) = B_Scope
2839            and then In_Private_Part (B_Scope)
2840          then
2841             Id := Next_Entity (T);
2842          else
2843             Id := Next_Entity (B_Type);
2844          end if;
2845
2846          --  Set flag if this is a type in a package spec
2847
2848          Is_Type_In_Pkg :=
2849            Is_Package_Or_Generic_Package (B_Scope)
2850              and then
2851                Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
2852                                                            N_Package_Body;
2853
2854          while Present (Id) loop
2855
2856             --  Test whether the result type or any of the parameter types of
2857             --  each subprogram following the type match that type when the
2858             --  type is declared in a package spec, is a derived type, or the
2859             --  subprogram is marked as primitive. (The Is_Primitive test is
2860             --  needed to find primitives of nonderived types in declarative
2861             --  parts that happen to override the predefined "=" operator.)
2862
2863             --  Note that generic formal subprograms are not considered to be
2864             --  primitive operations and thus are never inherited.
2865
2866             if Is_Overloadable (Id)
2867               and then (Is_Type_In_Pkg
2868                          or else Is_Derived_Type (B_Type)
2869                          or else Is_Primitive (Id))
2870               and then Nkind (Parent (Parent (Id)))
2871                          not in N_Formal_Subprogram_Declaration
2872             then
2873                Is_Prim := False;
2874
2875                if Match (Id) then
2876                   Is_Prim := True;
2877
2878                else
2879                   Formal := First_Formal (Id);
2880                   while Present (Formal) loop
2881                      if Match (Formal) then
2882                         Is_Prim := True;
2883                         exit;
2884                      end if;
2885
2886                      Next_Formal (Formal);
2887                   end loop;
2888                end if;
2889
2890                --  For a formal derived type, the only primitives are the ones
2891                --  inherited from the parent type. Operations appearing in the
2892                --  package declaration are not primitive for it.
2893
2894                if Is_Prim
2895                  and then (not Formal_Derived
2896                             or else Present (Alias (Id)))
2897                then
2898                   --  In the special case of an equality operator aliased to
2899                   --  an overriding dispatching equality belonging to the same
2900                   --  type, we don't include it in the list of primitives.
2901                   --  This avoids inheriting multiple equality operators when
2902                   --  deriving from untagged private types whose full type is
2903                   --  tagged, which can otherwise cause ambiguities. Note that
2904                   --  this should only happen for this kind of untagged parent
2905                   --  type, since normally dispatching operations are inherited
2906                   --  using the type's Primitive_Operations list.
2907
2908                   if Chars (Id) = Name_Op_Eq
2909                     and then Is_Dispatching_Operation (Id)
2910                     and then Present (Alias (Id))
2911                     and then Present (Overridden_Operation (Alias (Id)))
2912                     and then Base_Type (Etype (First_Entity (Id))) =
2913                                Base_Type (Etype (First_Entity (Alias (Id))))
2914                   then
2915                      null;
2916
2917                   --  Include the subprogram in the list of primitives
2918
2919                   else
2920                      Append_Elmt (Id, Op_List);
2921                   end if;
2922                end if;
2923             end if;
2924
2925             Next_Entity (Id);
2926
2927             --  For a type declared in System, some of its operations may
2928             --  appear in the target-specific extension to System.
2929
2930             if No (Id)
2931               and then B_Scope = RTU_Entity (System)
2932               and then Present_System_Aux
2933             then
2934                B_Scope := System_Aux_Id;
2935                Id := First_Entity (System_Aux_Id);
2936             end if;
2937          end loop;
2938       end if;
2939
2940       return Op_List;
2941    end Collect_Primitive_Operations;
2942
2943    -----------------------------------
2944    -- Compile_Time_Constraint_Error --
2945    -----------------------------------
2946
2947    function Compile_Time_Constraint_Error
2948      (N    : Node_Id;
2949       Msg  : String;
2950       Ent  : Entity_Id  := Empty;
2951       Loc  : Source_Ptr := No_Location;
2952       Warn : Boolean    := False) return Node_Id
2953    is
2954       Msgc : String (1 .. Msg'Length + 3);
2955       --  Copy of message, with room for possible ?? and ! at end
2956
2957       Msgl : Natural;
2958       Wmsg : Boolean;
2959       P    : Node_Id;
2960       OldP : Node_Id;
2961       Msgs : Boolean;
2962       Eloc : Source_Ptr;
2963
2964    begin
2965       --  A static constraint error in an instance body is not a fatal error.
2966       --  we choose to inhibit the message altogether, because there is no
2967       --  obvious node (for now) on which to post it. On the other hand the
2968       --  offending node must be replaced with a constraint_error in any case.
2969
2970       --  No messages are generated if we already posted an error on this node
2971
2972       if not Error_Posted (N) then
2973          if Loc /= No_Location then
2974             Eloc := Loc;
2975          else
2976             Eloc := Sloc (N);
2977          end if;
2978
2979          Msgc (1 .. Msg'Length) := Msg;
2980          Msgl := Msg'Length;
2981
2982          --  Message is a warning, even in Ada 95 case
2983
2984          if Msg (Msg'Last) = '?' then
2985             Wmsg := True;
2986
2987          --  In Ada 83, all messages are warnings. In the private part and
2988          --  the body of an instance, constraint_checks are only warnings.
2989          --  We also make this a warning if the Warn parameter is set.
2990
2991          elsif Warn
2992            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
2993          then
2994             Msgl := Msgl + 1;
2995             Msgc (Msgl) := '?';
2996             Msgl := Msgl + 1;
2997             Msgc (Msgl) := '?';
2998             Wmsg := True;
2999
3000          elsif In_Instance_Not_Visible then
3001             Msgl := Msgl + 1;
3002             Msgc (Msgl) := '?';
3003             Msgl := Msgl + 1;
3004             Msgc (Msgl) := '?';
3005             Wmsg := True;
3006
3007          --  Otherwise we have a real error message (Ada 95 static case)
3008          --  and we make this an unconditional message. Note that in the
3009          --  warning case we do not make the message unconditional, it seems
3010          --  quite reasonable to delete messages like this (about exceptions
3011          --  that will be raised) in dead code.
3012
3013          else
3014             Wmsg := False;
3015             Msgl := Msgl + 1;
3016             Msgc (Msgl) := '!';
3017          end if;
3018
3019          --  Should we generate a warning? The answer is not quite yes. The
3020          --  very annoying exception occurs in the case of a short circuit
3021          --  operator where the left operand is static and decisive. Climb
3022          --  parents to see if that is the case we have here. Conditional
3023          --  expressions with decisive conditions are a similar situation.
3024
3025          Msgs := True;
3026          P := N;
3027          loop
3028             OldP := P;
3029             P := Parent (P);
3030
3031             --  And then with False as left operand
3032
3033             if Nkind (P) = N_And_Then
3034               and then Compile_Time_Known_Value (Left_Opnd (P))
3035               and then Is_False (Expr_Value (Left_Opnd (P)))
3036             then
3037                Msgs := False;
3038                exit;
3039
3040             --  OR ELSE with True as left operand
3041
3042             elsif Nkind (P) = N_Or_Else
3043               and then Compile_Time_Known_Value (Left_Opnd (P))
3044               and then Is_True (Expr_Value (Left_Opnd (P)))
3045             then
3046                Msgs := False;
3047                exit;
3048
3049             --  If expression
3050
3051             elsif Nkind (P) = N_If_Expression then
3052                declare
3053                   Cond : constant Node_Id := First (Expressions (P));
3054                   Texp : constant Node_Id := Next (Cond);
3055                   Fexp : constant Node_Id := Next (Texp);
3056
3057                begin
3058                   if Compile_Time_Known_Value (Cond) then
3059
3060                      --  Condition is True and we are in the right operand
3061
3062                      if Is_True (Expr_Value (Cond))
3063                        and then OldP = Fexp
3064                      then
3065                         Msgs := False;
3066                         exit;
3067
3068                      --  Condition is False and we are in the left operand
3069
3070                      elsif Is_False (Expr_Value (Cond))
3071                        and then OldP = Texp
3072                      then
3073                         Msgs := False;
3074                         exit;
3075                      end if;
3076                   end if;
3077                end;
3078
3079             --  Special case for component association in aggregates, where
3080             --  we want to keep climbing up to the parent aggregate.
3081
3082             elsif Nkind (P) = N_Component_Association
3083               and then Nkind (Parent (P)) = N_Aggregate
3084             then
3085                null;
3086
3087             --  Keep going if within subexpression
3088
3089             else
3090                exit when Nkind (P) not in N_Subexpr;
3091             end if;
3092          end loop;
3093
3094          if Msgs then
3095             if Present (Ent) then
3096                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
3097             else
3098                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
3099             end if;
3100
3101             if Wmsg then
3102
3103                --  Check whether the context is an Init_Proc
3104
3105                if Inside_Init_Proc then
3106                   declare
3107                      Conc_Typ : constant Entity_Id :=
3108                                   Corresponding_Concurrent_Type
3109                                     (Entity (Parameter_Type (First
3110                                       (Parameter_Specifications
3111                                         (Parent (Current_Scope))))));
3112
3113                   begin
3114                      --  Don't complain if the corresponding concurrent type
3115                      --  doesn't come from source (i.e. a single task/protected
3116                      --  object).
3117
3118                      if Present (Conc_Typ)
3119                        and then not Comes_From_Source (Conc_Typ)
3120                      then
3121                         Error_Msg_NEL
3122                           ("\??& will be raised at run time",
3123                            N, Standard_Constraint_Error, Eloc);
3124
3125                      else
3126                         Error_Msg_NEL
3127                           ("\??& will be raised for objects of this type",
3128                            N, Standard_Constraint_Error, Eloc);
3129                      end if;
3130                   end;
3131
3132                else
3133                   Error_Msg_NEL
3134                     ("\??& will be raised at run time",
3135                      N, Standard_Constraint_Error, Eloc);
3136                end if;
3137
3138             else
3139                Error_Msg
3140                  ("\static expression fails Constraint_Check", Eloc);
3141                Set_Error_Posted (N);
3142             end if;
3143          end if;
3144       end if;
3145
3146       return N;
3147    end Compile_Time_Constraint_Error;
3148
3149    -----------------------
3150    -- Conditional_Delay --
3151    -----------------------
3152
3153    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
3154    begin
3155       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
3156          Set_Has_Delayed_Freeze (New_Ent);
3157       end if;
3158    end Conditional_Delay;
3159
3160    -------------------------
3161    -- Copy_Component_List --
3162    -------------------------
3163
3164    function Copy_Component_List
3165      (R_Typ : Entity_Id;
3166       Loc   : Source_Ptr) return List_Id
3167    is
3168       Comp  : Node_Id;
3169       Comps : constant List_Id := New_List;
3170
3171    begin
3172       Comp := First_Component (Underlying_Type (R_Typ));
3173       while Present (Comp) loop
3174          if Comes_From_Source (Comp) then
3175             declare
3176                Comp_Decl : constant Node_Id := Declaration_Node (Comp);
3177             begin
3178                Append_To (Comps,
3179                  Make_Component_Declaration (Loc,
3180                    Defining_Identifier =>
3181                      Make_Defining_Identifier (Loc, Chars (Comp)),
3182                    Component_Definition =>
3183                      New_Copy_Tree
3184                        (Component_Definition (Comp_Decl), New_Sloc => Loc)));
3185             end;
3186          end if;
3187
3188          Next_Component (Comp);
3189       end loop;
3190
3191       return Comps;
3192    end Copy_Component_List;
3193
3194    -------------------------
3195    -- Copy_Parameter_List --
3196    -------------------------
3197
3198    function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
3199       Loc    : constant Source_Ptr := Sloc (Subp_Id);
3200       Plist  : List_Id;
3201       Formal : Entity_Id;
3202
3203    begin
3204       if No (First_Formal (Subp_Id)) then
3205          return No_List;
3206       else
3207          Plist := New_List;
3208          Formal := First_Formal (Subp_Id);
3209          while Present (Formal) loop
3210             Append
3211               (Make_Parameter_Specification (Loc,
3212                 Defining_Identifier =>
3213                   Make_Defining_Identifier (Sloc (Formal),
3214                     Chars => Chars (Formal)),
3215                 In_Present  => In_Present (Parent (Formal)),
3216                 Out_Present => Out_Present (Parent (Formal)),
3217              Parameter_Type =>
3218                   New_Reference_To (Etype (Formal), Loc),
3219                 Expression =>
3220                   New_Copy_Tree (Expression (Parent (Formal)))),
3221               Plist);
3222
3223             Next_Formal (Formal);
3224          end loop;
3225       end if;
3226
3227       return Plist;
3228    end Copy_Parameter_List;
3229
3230    --------------------------------
3231    -- Corresponding_Generic_Type --
3232    --------------------------------
3233
3234    function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
3235       Inst : Entity_Id;
3236       Gen  : Entity_Id;
3237       Typ  : Entity_Id;
3238
3239    begin
3240       if not Is_Generic_Actual_Type (T) then
3241          return Any_Type;
3242
3243       --  If the actual is the actual of an enclosing instance, resolution
3244       --  was correct in the generic.
3245
3246       elsif Nkind (Parent (T)) = N_Subtype_Declaration
3247         and then Is_Entity_Name (Subtype_Indication (Parent (T)))
3248         and then
3249           Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
3250       then
3251          return Any_Type;
3252
3253       else
3254          Inst := Scope (T);
3255
3256          if Is_Wrapper_Package (Inst) then
3257             Inst := Related_Instance (Inst);
3258          end if;
3259
3260          Gen  :=
3261            Generic_Parent
3262              (Specification (Unit_Declaration_Node (Inst)));
3263
3264          --  Generic actual has the same name as the corresponding formal
3265
3266          Typ := First_Entity (Gen);
3267          while Present (Typ) loop
3268             if Chars (Typ) = Chars (T) then
3269                return Typ;
3270             end if;
3271
3272             Next_Entity (Typ);
3273          end loop;
3274
3275          return Any_Type;
3276       end if;
3277    end Corresponding_Generic_Type;
3278
3279    --------------------
3280    -- Current_Entity --
3281    --------------------
3282
3283    --  The currently visible definition for a given identifier is the
3284    --  one most chained at the start of the visibility chain, i.e. the
3285    --  one that is referenced by the Node_Id value of the name of the
3286    --  given identifier.
3287
3288    function Current_Entity (N : Node_Id) return Entity_Id is
3289    begin
3290       return Get_Name_Entity_Id (Chars (N));
3291    end Current_Entity;
3292
3293    -----------------------------
3294    -- Current_Entity_In_Scope --
3295    -----------------------------
3296
3297    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
3298       E  : Entity_Id;
3299       CS : constant Entity_Id := Current_Scope;
3300
3301       Transient_Case : constant Boolean := Scope_Is_Transient;
3302
3303    begin
3304       E := Get_Name_Entity_Id (Chars (N));
3305       while Present (E)
3306         and then Scope (E) /= CS
3307         and then (not Transient_Case or else Scope (E) /= Scope (CS))
3308       loop
3309          E := Homonym (E);
3310       end loop;
3311
3312       return E;
3313    end Current_Entity_In_Scope;
3314
3315    -------------------
3316    -- Current_Scope --
3317    -------------------
3318
3319    function Current_Scope return Entity_Id is
3320    begin
3321       if Scope_Stack.Last = -1 then
3322          return Standard_Standard;
3323       else
3324          declare
3325             C : constant Entity_Id :=
3326                   Scope_Stack.Table (Scope_Stack.Last).Entity;
3327          begin
3328             if Present (C) then
3329                return C;
3330             else
3331                return Standard_Standard;
3332             end if;
3333          end;
3334       end if;
3335    end Current_Scope;
3336
3337    ------------------------
3338    -- Current_Subprogram --
3339    ------------------------
3340
3341    function Current_Subprogram return Entity_Id is
3342       Scop : constant Entity_Id := Current_Scope;
3343    begin
3344       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
3345          return Scop;
3346       else
3347          return Enclosing_Subprogram (Scop);
3348       end if;
3349    end Current_Subprogram;
3350
3351    ----------------------------------
3352    -- Deepest_Type_Access_Level --
3353    ----------------------------------
3354
3355    function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
3356    begin
3357       if Ekind (Typ) = E_Anonymous_Access_Type
3358         and then not Is_Local_Anonymous_Access (Typ)
3359         and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
3360       then
3361          --  Typ is the type of an Ada 2012 stand-alone object of an anonymous
3362          --  access type.
3363
3364          return
3365            Scope_Depth (Enclosing_Dynamic_Scope
3366                          (Defining_Identifier
3367                            (Associated_Node_For_Itype (Typ))));
3368
3369       --  For generic formal type, return Int'Last (infinite).
3370       --  See comment preceding Is_Generic_Type call in Type_Access_Level.
3371
3372       elsif Is_Generic_Type (Root_Type (Typ)) then
3373          return UI_From_Int (Int'Last);
3374
3375       else
3376          return Type_Access_Level (Typ);
3377       end if;
3378    end Deepest_Type_Access_Level;
3379
3380    ---------------------
3381    -- Defining_Entity --
3382    ---------------------
3383
3384    function Defining_Entity (N : Node_Id) return Entity_Id is
3385       K   : constant Node_Kind := Nkind (N);
3386       Err : Entity_Id := Empty;
3387
3388    begin
3389       case K is
3390          when
3391            N_Subprogram_Declaration                 |
3392            N_Abstract_Subprogram_Declaration        |
3393            N_Subprogram_Body                        |
3394            N_Package_Declaration                    |
3395            N_Subprogram_Renaming_Declaration        |
3396            N_Subprogram_Body_Stub                   |
3397            N_Generic_Subprogram_Declaration         |
3398            N_Generic_Package_Declaration            |
3399            N_Formal_Subprogram_Declaration          |
3400            N_Expression_Function
3401          =>
3402             return Defining_Entity (Specification (N));
3403
3404          when
3405            N_Component_Declaration                  |
3406            N_Defining_Program_Unit_Name             |
3407            N_Discriminant_Specification             |
3408            N_Entry_Body                             |
3409            N_Entry_Declaration                      |
3410            N_Entry_Index_Specification              |
3411            N_Exception_Declaration                  |
3412            N_Exception_Renaming_Declaration         |
3413            N_Formal_Object_Declaration              |
3414            N_Formal_Package_Declaration             |
3415            N_Formal_Type_Declaration                |
3416            N_Full_Type_Declaration                  |
3417            N_Implicit_Label_Declaration             |
3418            N_Incomplete_Type_Declaration            |
3419            N_Loop_Parameter_Specification           |
3420            N_Number_Declaration                     |
3421            N_Object_Declaration                     |
3422            N_Object_Renaming_Declaration            |
3423            N_Package_Body_Stub                      |
3424            N_Parameter_Specification                |
3425            N_Private_Extension_Declaration          |
3426            N_Private_Type_Declaration               |
3427            N_Protected_Body                         |
3428            N_Protected_Body_Stub                    |
3429            N_Protected_Type_Declaration             |
3430            N_Single_Protected_Declaration           |
3431            N_Single_Task_Declaration                |
3432            N_Subtype_Declaration                    |
3433            N_Task_Body                              |
3434            N_Task_Body_Stub                         |
3435            N_Task_Type_Declaration
3436          =>
3437             return Defining_Identifier (N);
3438
3439          when N_Subunit =>
3440             return Defining_Entity (Proper_Body (N));
3441
3442          when
3443            N_Function_Instantiation                 |
3444            N_Function_Specification                 |
3445            N_Generic_Function_Renaming_Declaration  |
3446            N_Generic_Package_Renaming_Declaration   |
3447            N_Generic_Procedure_Renaming_Declaration |
3448            N_Package_Body                           |
3449            N_Package_Instantiation                  |
3450            N_Package_Renaming_Declaration           |
3451            N_Package_Specification                  |
3452            N_Procedure_Instantiation                |
3453            N_Procedure_Specification
3454          =>
3455             declare
3456                Nam : constant Node_Id := Defining_Unit_Name (N);
3457
3458             begin
3459                if Nkind (Nam) in N_Entity then
3460                   return Nam;
3461
3462                --  For Error, make up a name and attach to declaration
3463                --  so we can continue semantic analysis
3464
3465                elsif Nam = Error then
3466                   Err := Make_Temporary (Sloc (N), 'T');
3467                   Set_Defining_Unit_Name (N, Err);
3468
3469                   return Err;
3470                --  If not an entity, get defining identifier
3471
3472                else
3473                   return Defining_Identifier (Nam);
3474                end if;
3475             end;
3476
3477          when N_Block_Statement =>
3478             return Entity (Identifier (N));
3479
3480          when others =>
3481             raise Program_Error;
3482
3483       end case;
3484    end Defining_Entity;
3485
3486    --------------------------
3487    -- Denotes_Discriminant --
3488    --------------------------
3489
3490    function Denotes_Discriminant
3491      (N                : Node_Id;
3492       Check_Concurrent : Boolean := False) return Boolean
3493    is
3494       E : Entity_Id;
3495    begin
3496       if not Is_Entity_Name (N)
3497         or else No (Entity (N))
3498       then
3499          return False;
3500       else
3501          E := Entity (N);
3502       end if;
3503
3504       --  If we are checking for a protected type, the discriminant may have
3505       --  been rewritten as the corresponding discriminal of the original type
3506       --  or of the corresponding concurrent record, depending on whether we
3507       --  are in the spec or body of the protected type.
3508
3509       return Ekind (E) = E_Discriminant
3510         or else
3511           (Check_Concurrent
3512             and then Ekind (E) = E_In_Parameter
3513             and then Present (Discriminal_Link (E))
3514             and then
3515               (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
3516                 or else
3517                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
3518
3519    end Denotes_Discriminant;
3520
3521    -------------------------
3522    -- Denotes_Same_Object --
3523    -------------------------
3524
3525    function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
3526       Obj1 : Node_Id := A1;
3527       Obj2 : Node_Id := A2;
3528
3529       function Has_Prefix (N : Node_Id) return Boolean;
3530       --  Return True if N has attribute Prefix
3531
3532       function Is_Renaming (N : Node_Id) return Boolean;
3533       --  Return true if N names a renaming entity
3534
3535       function Is_Valid_Renaming (N : Node_Id) return Boolean;
3536       --  For renamings, return False if the prefix of any dereference within
3537       --  the renamed object_name is a variable, or any expression within the
3538       --  renamed object_name contains references to variables or calls on
3539       --  nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
3540
3541       ----------------
3542       -- Has_Prefix --
3543       ----------------
3544
3545       function Has_Prefix (N : Node_Id) return Boolean is
3546       begin
3547          return
3548            Nkind_In (N,
3549              N_Attribute_Reference,
3550              N_Expanded_Name,
3551              N_Explicit_Dereference,
3552              N_Indexed_Component,
3553              N_Reference,
3554              N_Selected_Component,
3555              N_Slice);
3556       end Has_Prefix;
3557
3558       -----------------
3559       -- Is_Renaming --
3560       -----------------
3561
3562       function Is_Renaming (N : Node_Id) return Boolean is
3563       begin
3564          return Is_Entity_Name (N)
3565            and then Present (Renamed_Entity (Entity (N)));
3566       end Is_Renaming;
3567
3568       -----------------------
3569       -- Is_Valid_Renaming --
3570       -----------------------
3571
3572       function Is_Valid_Renaming (N : Node_Id) return Boolean is
3573
3574          function Check_Renaming (N : Node_Id) return Boolean;
3575          --  Recursive function used to traverse all the prefixes of N
3576
3577          function Check_Renaming (N : Node_Id) return Boolean is
3578          begin
3579             if Is_Renaming (N)
3580               and then not Check_Renaming (Renamed_Entity (Entity (N)))
3581             then
3582                return False;
3583             end if;
3584
3585             if Nkind (N) = N_Indexed_Component then
3586                declare
3587                   Indx : Node_Id;
3588
3589                begin
3590                   Indx := First (Expressions (N));
3591                   while Present (Indx) loop
3592                      if not Is_OK_Static_Expression (Indx) then
3593                         return False;
3594                      end if;
3595
3596                      Next_Index (Indx);
3597                   end loop;
3598                end;
3599             end if;
3600
3601             if Has_Prefix (N) then
3602                declare
3603                   P : constant Node_Id := Prefix (N);
3604
3605                begin
3606                   if Nkind (N) = N_Explicit_Dereference
3607                     and then Is_Variable (P)
3608                   then
3609                      return False;
3610
3611                   elsif Is_Entity_Name (P)
3612                     and then Ekind (Entity (P)) = E_Function
3613                   then
3614                      return False;
3615
3616                   elsif Nkind (P) = N_Function_Call then
3617                      return False;
3618                   end if;
3619
3620                   --  Recursion to continue traversing the prefix of the
3621                   --  renaming expression
3622
3623                   return Check_Renaming (P);
3624                end;
3625             end if;
3626
3627             return True;
3628          end Check_Renaming;
3629
3630       --  Start of processing for Is_Valid_Renaming
3631
3632       begin
3633          return Check_Renaming (N);
3634       end Is_Valid_Renaming;
3635
3636    --  Start of processing for Denotes_Same_Object
3637
3638    begin
3639       --  Both names statically denote the same stand-alone object or parameter
3640       --  (RM 6.4.1(6.5/3))
3641
3642       if Is_Entity_Name (Obj1)
3643         and then Is_Entity_Name (Obj2)
3644         and then Entity (Obj1) = Entity (Obj2)
3645       then
3646          return True;
3647       end if;
3648
3649       --  For renamings, the prefix of any dereference within the renamed
3650       --  object_name is not a variable, and any expression within the
3651       --  renamed object_name contains no references to variables nor
3652       --  calls on nonstatic functions (RM 6.4.1(6.10/3)).
3653
3654       if Is_Renaming (Obj1) then
3655          if Is_Valid_Renaming (Obj1) then
3656             Obj1 := Renamed_Entity (Entity (Obj1));
3657          else
3658             return False;
3659          end if;
3660       end if;
3661
3662       if Is_Renaming (Obj2) then
3663          if Is_Valid_Renaming (Obj2) then
3664             Obj2 := Renamed_Entity (Entity (Obj2));
3665          else
3666             return False;
3667          end if;
3668       end if;
3669
3670       --  No match if not same node kind (such cases are handled by
3671       --  Denotes_Same_Prefix)
3672
3673       if Nkind (Obj1) /= Nkind (Obj2) then
3674          return False;
3675
3676       --  After handling valid renamings, one of the two names statically
3677       --  denoted a renaming declaration whose renamed object_name is known
3678       --  to denote the same object as the other (RM 6.4.1(6.10/3))
3679
3680       elsif Is_Entity_Name (Obj1) then
3681          if Is_Entity_Name (Obj2) then
3682             return Entity (Obj1) = Entity (Obj2);
3683          else
3684             return False;
3685          end if;
3686
3687       --  Both names are selected_components, their prefixes are known to
3688       --  denote the same object, and their selector_names denote the same
3689       --  component (RM 6.4.1(6.6/3)
3690
3691       elsif Nkind (Obj1) = N_Selected_Component then
3692          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3693            and then
3694          Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
3695
3696       --  Both names are dereferences and the dereferenced names are known to
3697       --  denote the same object (RM 6.4.1(6.7/3))
3698
3699       elsif Nkind (Obj1) = N_Explicit_Dereference then
3700          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
3701
3702       --  Both names are indexed_components, their prefixes are known to denote
3703       --  the same object, and each of the pairs of corresponding index values
3704       --  are either both static expressions with the same static value or both
3705       --  names that are known to denote the same object (RM 6.4.1(6.8/3))
3706
3707       elsif Nkind (Obj1) = N_Indexed_Component then
3708          if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
3709             return False;
3710          else
3711             declare
3712                Indx1 : Node_Id;
3713                Indx2 : Node_Id;
3714
3715             begin
3716                Indx1 := First (Expressions (Obj1));
3717                Indx2 := First (Expressions (Obj2));
3718                while Present (Indx1) loop
3719
3720                   --  Indexes must denote the same static value or same object
3721
3722                   if Is_OK_Static_Expression (Indx1) then
3723                      if not Is_OK_Static_Expression (Indx2) then
3724                         return False;
3725
3726                      elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
3727                         return False;
3728                      end if;
3729
3730                   elsif not Denotes_Same_Object (Indx1, Indx2) then
3731                      return False;
3732                   end if;
3733
3734                   Next (Indx1);
3735                   Next (Indx2);
3736                end loop;
3737
3738                return True;
3739             end;
3740          end if;
3741
3742       --  Both names are slices, their prefixes are known to denote the same
3743       --  object, and the two slices have statically matching index constraints
3744       --  (RM 6.4.1(6.9/3))
3745
3746       elsif Nkind (Obj1) = N_Slice
3747         and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3748       then
3749          declare
3750             Lo1, Lo2, Hi1, Hi2 : Node_Id;
3751
3752          begin
3753             Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
3754             Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
3755
3756             --  Check whether bounds are statically identical. There is no
3757             --  attempt to detect partial overlap of slices.
3758
3759             return Denotes_Same_Object (Lo1, Lo2)
3760               and then Denotes_Same_Object (Hi1, Hi2);
3761          end;
3762
3763       --  In the recursion, literals appear as indexes.
3764
3765       elsif Nkind (Obj1) = N_Integer_Literal
3766         and then Nkind (Obj2) = N_Integer_Literal
3767       then
3768          return Intval (Obj1) = Intval (Obj2);
3769
3770       else
3771          return False;
3772       end if;
3773    end Denotes_Same_Object;
3774
3775    -------------------------
3776    -- Denotes_Same_Prefix --
3777    -------------------------
3778
3779    function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
3780
3781    begin
3782       if Is_Entity_Name (A1) then
3783          if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
3784            and then not Is_Access_Type (Etype (A1))
3785          then
3786             return Denotes_Same_Object (A1, Prefix (A2))
3787               or else Denotes_Same_Prefix (A1, Prefix (A2));
3788          else
3789             return False;
3790          end if;
3791
3792       elsif Is_Entity_Name (A2) then
3793          return Denotes_Same_Prefix (A1 => A2, A2 => A1);
3794
3795       elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
3796               and then
3797             Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
3798       then
3799          declare
3800             Root1, Root2 : Node_Id;
3801             Depth1, Depth2 : Int := 0;
3802
3803          begin
3804             Root1 := Prefix (A1);
3805             while not Is_Entity_Name (Root1) loop
3806                if not Nkind_In
3807                  (Root1, N_Selected_Component, N_Indexed_Component)
3808                then
3809                   return False;
3810                else
3811                   Root1 := Prefix (Root1);
3812                end if;
3813
3814                Depth1 := Depth1 + 1;
3815             end loop;
3816
3817             Root2 := Prefix (A2);
3818             while not Is_Entity_Name (Root2) loop
3819                if not Nkind_In
3820                  (Root2, N_Selected_Component, N_Indexed_Component)
3821                then
3822                   return False;
3823                else
3824                   Root2 := Prefix (Root2);
3825                end if;
3826
3827                Depth2 := Depth2 + 1;
3828             end loop;
3829
3830             --  If both have the same depth and they do not denote the same
3831             --  object, they are disjoint and no warning is needed.
3832
3833             if Depth1 = Depth2 then
3834                return False;
3835
3836             elsif Depth1 > Depth2 then
3837                Root1 := Prefix (A1);
3838                for I in 1 .. Depth1 - Depth2 - 1 loop
3839                   Root1 := Prefix (Root1);
3840                end loop;
3841
3842                return Denotes_Same_Object (Root1, A2);
3843
3844             else
3845                Root2 := Prefix (A2);
3846                for I in 1 .. Depth2 - Depth1 - 1 loop
3847                   Root2 := Prefix (Root2);
3848                end loop;
3849
3850                return Denotes_Same_Object (A1, Root2);
3851             end if;
3852          end;
3853
3854       else
3855          return False;
3856       end if;
3857    end Denotes_Same_Prefix;
3858
3859    ----------------------
3860    -- Denotes_Variable --
3861    ----------------------
3862
3863    function Denotes_Variable (N : Node_Id) return Boolean is
3864    begin
3865       return Is_Variable (N) and then Paren_Count (N) = 0;
3866    end Denotes_Variable;
3867
3868    -----------------------------
3869    -- Depends_On_Discriminant --
3870    -----------------------------
3871
3872    function Depends_On_Discriminant (N : Node_Id) return Boolean is
3873       L : Node_Id;
3874       H : Node_Id;
3875
3876    begin
3877       Get_Index_Bounds (N, L, H);
3878       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
3879    end Depends_On_Discriminant;
3880
3881    -------------------------
3882    -- Designate_Same_Unit --
3883    -------------------------
3884
3885    function Designate_Same_Unit
3886      (Name1 : Node_Id;
3887       Name2 : Node_Id) return Boolean
3888    is
3889       K1 : constant Node_Kind := Nkind (Name1);
3890       K2 : constant Node_Kind := Nkind (Name2);
3891
3892       function Prefix_Node (N : Node_Id) return Node_Id;
3893       --  Returns the parent unit name node of a defining program unit name
3894       --  or the prefix if N is a selected component or an expanded name.
3895
3896       function Select_Node (N : Node_Id) return Node_Id;
3897       --  Returns the defining identifier node of a defining program unit
3898       --  name or  the selector node if N is a selected component or an
3899       --  expanded name.
3900
3901       -----------------
3902       -- Prefix_Node --
3903       -----------------
3904
3905       function Prefix_Node (N : Node_Id) return Node_Id is
3906       begin
3907          if Nkind (N) = N_Defining_Program_Unit_Name then
3908             return Name (N);
3909
3910          else
3911             return Prefix (N);
3912          end if;
3913       end Prefix_Node;
3914
3915       -----------------
3916       -- Select_Node --
3917       -----------------
3918
3919       function Select_Node (N : Node_Id) return Node_Id is
3920       begin
3921          if Nkind (N) = N_Defining_Program_Unit_Name then
3922             return Defining_Identifier (N);
3923
3924          else
3925             return Selector_Name (N);
3926          end if;
3927       end Select_Node;
3928
3929    --  Start of processing for Designate_Next_Unit
3930
3931    begin
3932       if (K1 = N_Identifier or else
3933           K1 = N_Defining_Identifier)
3934         and then
3935          (K2 = N_Identifier or else
3936           K2 = N_Defining_Identifier)
3937       then
3938          return Chars (Name1) = Chars (Name2);
3939
3940       elsif
3941          (K1 = N_Expanded_Name      or else
3942           K1 = N_Selected_Component or else
3943           K1 = N_Defining_Program_Unit_Name)
3944         and then
3945          (K2 = N_Expanded_Name      or else
3946           K2 = N_Selected_Component or else
3947           K2 = N_Defining_Program_Unit_Name)
3948       then
3949          return
3950            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
3951              and then
3952                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
3953
3954       else
3955          return False;
3956       end if;
3957    end Designate_Same_Unit;
3958
3959    ------------------------------------------
3960    -- function Dynamic_Accessibility_Level --
3961    ------------------------------------------
3962
3963    function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
3964       E : Entity_Id;
3965       Loc : constant Source_Ptr := Sloc (Expr);
3966
3967       function Make_Level_Literal (Level : Uint) return Node_Id;
3968       --  Construct an integer literal representing an accessibility level
3969       --  with its type set to Natural.
3970
3971       ------------------------
3972       -- Make_Level_Literal --
3973       ------------------------
3974
3975       function Make_Level_Literal (Level : Uint) return Node_Id is
3976          Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
3977       begin
3978          Set_Etype (Result, Standard_Natural);
3979          return Result;
3980       end Make_Level_Literal;
3981
3982    --  Start of processing for Dynamic_Accessibility_Level
3983
3984    begin
3985       if Is_Entity_Name (Expr) then
3986          E := Entity (Expr);
3987
3988          if Present (Renamed_Object (E)) then
3989             return Dynamic_Accessibility_Level (Renamed_Object (E));
3990          end if;
3991
3992          if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
3993             if Present (Extra_Accessibility (E)) then
3994                return New_Occurrence_Of (Extra_Accessibility (E), Loc);
3995             end if;
3996          end if;
3997       end if;
3998
3999       --  Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
4000
4001       case Nkind (Expr) is
4002
4003          --  For access discriminant, the level of the enclosing object
4004
4005          when N_Selected_Component =>
4006             if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
4007               and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
4008                                             E_Anonymous_Access_Type
4009             then
4010                return Make_Level_Literal (Object_Access_Level (Expr));
4011             end if;
4012
4013          when N_Attribute_Reference =>
4014             case Get_Attribute_Id (Attribute_Name (Expr)) is
4015
4016                --  For X'Access, the level of the prefix X
4017
4018                when Attribute_Access =>
4019                   return Make_Level_Literal
4020                            (Object_Access_Level (Prefix (Expr)));
4021
4022                --  Treat the unchecked attributes as library-level
4023
4024                when Attribute_Unchecked_Access    |
4025                     Attribute_Unrestricted_Access =>
4026                   return Make_Level_Literal (Scope_Depth (Standard_Standard));
4027
4028                --  No other access-valued attributes
4029
4030                when others =>
4031                   raise Program_Error;
4032             end case;
4033
4034          when N_Allocator =>
4035
4036             --  Unimplemented: depends on context. As an actual parameter where
4037             --  formal type is anonymous, use
4038             --    Scope_Depth (Current_Scope) + 1.
4039             --  For other cases, see 3.10.2(14/3) and following. ???
4040
4041             null;
4042
4043          when N_Type_Conversion =>
4044             if not Is_Local_Anonymous_Access (Etype (Expr)) then
4045
4046                --  Handle type conversions introduced for a rename of an
4047                --  Ada 2012 stand-alone object of an anonymous access type.
4048
4049                return Dynamic_Accessibility_Level (Expression (Expr));
4050             end if;
4051
4052          when others =>
4053             null;
4054       end case;
4055
4056       return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
4057    end Dynamic_Accessibility_Level;
4058
4059    -----------------------------------
4060    -- Effective_Extra_Accessibility --
4061    -----------------------------------
4062
4063    function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
4064    begin
4065       if Present (Renamed_Object (Id))
4066         and then Is_Entity_Name (Renamed_Object (Id))
4067       then
4068          return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
4069       else
4070          return Extra_Accessibility (Id);
4071       end if;
4072    end Effective_Extra_Accessibility;
4073
4074    ------------------------------
4075    -- Enclosing_Comp_Unit_Node --
4076    ------------------------------
4077
4078    function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
4079       Current_Node : Node_Id;
4080
4081    begin
4082       Current_Node := N;
4083       while Present (Current_Node)
4084         and then Nkind (Current_Node) /= N_Compilation_Unit
4085       loop
4086          Current_Node := Parent (Current_Node);
4087       end loop;
4088
4089       if Nkind (Current_Node) /= N_Compilation_Unit then
4090          return Empty;
4091       else
4092          return Current_Node;
4093       end if;
4094    end Enclosing_Comp_Unit_Node;
4095
4096    --------------------------
4097    -- Enclosing_CPP_Parent --
4098    --------------------------
4099
4100    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
4101       Parent_Typ : Entity_Id := Typ;
4102
4103    begin
4104       while not Is_CPP_Class (Parent_Typ)
4105          and then Etype (Parent_Typ) /= Parent_Typ
4106       loop
4107          Parent_Typ := Etype (Parent_Typ);
4108
4109          if Is_Private_Type (Parent_Typ) then
4110             Parent_Typ := Full_View (Base_Type (Parent_Typ));
4111          end if;
4112       end loop;
4113
4114       pragma Assert (Is_CPP_Class (Parent_Typ));
4115       return Parent_Typ;
4116    end Enclosing_CPP_Parent;
4117
4118    ----------------------------
4119    -- Enclosing_Generic_Body --
4120    ----------------------------
4121
4122    function Enclosing_Generic_Body
4123      (N : Node_Id) return Node_Id
4124    is
4125       P    : Node_Id;
4126       Decl : Node_Id;
4127       Spec : Node_Id;
4128
4129    begin
4130       P := Parent (N);
4131       while Present (P) loop
4132          if Nkind (P) = N_Package_Body
4133            or else Nkind (P) = N_Subprogram_Body
4134          then
4135             Spec := Corresponding_Spec (P);
4136
4137             if Present (Spec) then
4138                Decl := Unit_Declaration_Node (Spec);
4139
4140                if Nkind (Decl) = N_Generic_Package_Declaration
4141                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4142                then
4143                   return P;
4144                end if;
4145             end if;
4146          end if;
4147
4148          P := Parent (P);
4149       end loop;
4150
4151       return Empty;
4152    end Enclosing_Generic_Body;
4153
4154    ----------------------------
4155    -- Enclosing_Generic_Unit --
4156    ----------------------------
4157
4158    function Enclosing_Generic_Unit
4159      (N : Node_Id) return Node_Id
4160    is
4161       P    : Node_Id;
4162       Decl : Node_Id;
4163       Spec : Node_Id;
4164
4165    begin
4166       P := Parent (N);
4167       while Present (P) loop
4168          if Nkind (P) = N_Generic_Package_Declaration
4169            or else Nkind (P) = N_Generic_Subprogram_Declaration
4170          then
4171             return P;
4172
4173          elsif Nkind (P) = N_Package_Body
4174            or else Nkind (P) = N_Subprogram_Body
4175          then
4176             Spec := Corresponding_Spec (P);
4177
4178             if Present (Spec) then
4179                Decl := Unit_Declaration_Node (Spec);
4180
4181                if Nkind (Decl) = N_Generic_Package_Declaration
4182                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
4183                then
4184                   return Decl;
4185                end if;
4186             end if;
4187          end if;
4188
4189          P := Parent (P);
4190       end loop;
4191
4192       return Empty;
4193    end Enclosing_Generic_Unit;
4194
4195    -------------------------------
4196    -- Enclosing_Lib_Unit_Entity --
4197    -------------------------------
4198
4199    function Enclosing_Lib_Unit_Entity
4200       (E : Entity_Id := Current_Scope) return Entity_Id
4201    is
4202       Unit_Entity : Entity_Id;
4203
4204    begin
4205       --  Look for enclosing library unit entity by following scope links.
4206       --  Equivalent to, but faster than indexing through the scope stack.
4207
4208       Unit_Entity := E;
4209       while (Present (Scope (Unit_Entity))
4210         and then Scope (Unit_Entity) /= Standard_Standard)
4211         and not Is_Child_Unit (Unit_Entity)
4212       loop
4213          Unit_Entity := Scope (Unit_Entity);
4214       end loop;
4215
4216       return Unit_Entity;
4217    end Enclosing_Lib_Unit_Entity;
4218
4219    -----------------------
4220    -- Enclosing_Package --
4221    -----------------------
4222
4223    function Enclosing_Package (E : Entity_Id) return Entity_Id is
4224       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4225
4226    begin
4227       if Dynamic_Scope = Standard_Standard then
4228          return Standard_Standard;
4229
4230       elsif Dynamic_Scope = Empty then
4231          return Empty;
4232
4233       elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
4234                       E_Generic_Package)
4235       then
4236          return Dynamic_Scope;
4237
4238       else
4239          return Enclosing_Package (Dynamic_Scope);
4240       end if;
4241    end Enclosing_Package;
4242
4243    --------------------------
4244    -- Enclosing_Subprogram --
4245    --------------------------
4246
4247    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
4248       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4249
4250    begin
4251       if Dynamic_Scope = Standard_Standard then
4252          return Empty;
4253
4254       elsif Dynamic_Scope = Empty then
4255          return Empty;
4256
4257       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
4258          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
4259
4260       elsif Ekind (Dynamic_Scope) = E_Block
4261         or else Ekind (Dynamic_Scope) = E_Return_Statement
4262       then
4263          return Enclosing_Subprogram (Dynamic_Scope);
4264
4265       elsif Ekind (Dynamic_Scope) = E_Task_Type then
4266          return Get_Task_Body_Procedure (Dynamic_Scope);
4267
4268       elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
4269         and then Present (Full_View (Dynamic_Scope))
4270         and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
4271       then
4272          return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
4273
4274       --  No body is generated if the protected operation is eliminated
4275
4276       elsif Convention (Dynamic_Scope) = Convention_Protected
4277         and then not Is_Eliminated (Dynamic_Scope)
4278         and then Present (Protected_Body_Subprogram (Dynamic_Scope))
4279       then
4280          return Protected_Body_Subprogram (Dynamic_Scope);
4281
4282       else
4283          return Dynamic_Scope;
4284       end if;
4285    end Enclosing_Subprogram;
4286
4287    ------------------------
4288    -- Ensure_Freeze_Node --
4289    ------------------------
4290
4291    procedure Ensure_Freeze_Node (E : Entity_Id) is
4292       FN : Node_Id;
4293
4294    begin
4295       if No (Freeze_Node (E)) then
4296          FN := Make_Freeze_Entity (Sloc (E));
4297          Set_Has_Delayed_Freeze (E);
4298          Set_Freeze_Node (E, FN);
4299          Set_Access_Types_To_Process (FN, No_Elist);
4300          Set_TSS_Elist (FN, No_Elist);
4301          Set_Entity (FN, E);
4302       end if;
4303    end Ensure_Freeze_Node;
4304
4305    ----------------
4306    -- Enter_Name --
4307    ----------------
4308
4309    procedure Enter_Name (Def_Id : Entity_Id) is
4310       C : constant Entity_Id := Current_Entity (Def_Id);
4311       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
4312       S : constant Entity_Id := Current_Scope;
4313
4314    begin
4315       Generate_Definition (Def_Id);
4316
4317       --  Add new name to current scope declarations. Check for duplicate
4318       --  declaration, which may or may not be a genuine error.
4319
4320       if Present (E) then
4321
4322          --  Case of previous entity entered because of a missing declaration
4323          --  or else a bad subtype indication. Best is to use the new entity,
4324          --  and make the previous one invisible.
4325
4326          if Etype (E) = Any_Type then
4327             Set_Is_Immediately_Visible (E, False);
4328
4329          --  Case of renaming declaration constructed for package instances.
4330          --  if there is an explicit declaration with the same identifier,
4331          --  the renaming is not immediately visible any longer, but remains
4332          --  visible through selected component notation.
4333
4334          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
4335            and then not Comes_From_Source (E)
4336          then
4337             Set_Is_Immediately_Visible (E, False);
4338
4339          --  The new entity may be the package renaming, which has the same
4340          --  same name as a generic formal which has been seen already.
4341
4342          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
4343             and then not Comes_From_Source (Def_Id)
4344          then
4345             Set_Is_Immediately_Visible (E, False);
4346
4347          --  For a fat pointer corresponding to a remote access to subprogram,
4348          --  we use the same identifier as the RAS type, so that the proper
4349          --  name appears in the stub. This type is only retrieved through
4350          --  the RAS type and never by visibility, and is not added to the
4351          --  visibility list (see below).
4352
4353          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
4354            and then Present (Corresponding_Remote_Type (Def_Id))
4355          then
4356             null;
4357
4358          --  Case of an implicit operation or derived literal. The new entity
4359          --  hides the implicit one,  which is removed from all visibility,
4360          --  i.e. the entity list of its scope, and homonym chain of its name.
4361
4362          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
4363            or else Is_Internal (E)
4364          then
4365             declare
4366                Prev     : Entity_Id;
4367                Prev_Vis : Entity_Id;
4368                Decl     : constant Node_Id := Parent (E);
4369
4370             begin
4371                --  If E is an implicit declaration, it cannot be the first
4372                --  entity in the scope.
4373
4374                Prev := First_Entity (Current_Scope);
4375                while Present (Prev)
4376                  and then Next_Entity (Prev) /= E
4377                loop
4378                   Next_Entity (Prev);
4379                end loop;
4380
4381                if No (Prev) then
4382
4383                   --  If E is not on the entity chain of the current scope,
4384                   --  it is an implicit declaration in the generic formal
4385                   --  part of a generic subprogram. When analyzing the body,
4386                   --  the generic formals are visible but not on the entity
4387                   --  chain of the subprogram. The new entity will become
4388                   --  the visible one in the body.
4389
4390                   pragma Assert
4391                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
4392                   null;
4393
4394                else
4395                   Set_Next_Entity (Prev, Next_Entity (E));
4396
4397                   if No (Next_Entity (Prev)) then
4398                      Set_Last_Entity (Current_Scope, Prev);
4399                   end if;
4400
4401                   if E = Current_Entity (E) then
4402                      Prev_Vis := Empty;
4403
4404                   else
4405                      Prev_Vis := Current_Entity (E);
4406                      while Homonym (Prev_Vis) /= E loop
4407                         Prev_Vis := Homonym (Prev_Vis);
4408                      end loop;
4409                   end if;
4410
4411                   if Present (Prev_Vis)  then
4412
4413                      --  Skip E in the visibility chain
4414
4415                      Set_Homonym (Prev_Vis, Homonym (E));
4416
4417                   else
4418                      Set_Name_Entity_Id (Chars (E), Homonym (E));
4419                   end if;
4420                end if;
4421             end;
4422
4423          --  This section of code could use a comment ???
4424
4425          elsif Present (Etype (E))
4426            and then Is_Concurrent_Type (Etype (E))
4427            and then E = Def_Id
4428          then
4429             return;
4430
4431          --  If the homograph is a protected component renaming, it should not
4432          --  be hiding the current entity. Such renamings are treated as weak
4433          --  declarations.
4434
4435          elsif Is_Prival (E) then
4436             Set_Is_Immediately_Visible (E, False);
4437
4438          --  In this case the current entity is a protected component renaming.
4439          --  Perform minimal decoration by setting the scope and return since
4440          --  the prival should not be hiding other visible entities.
4441
4442          elsif Is_Prival (Def_Id) then
4443             Set_Scope (Def_Id, Current_Scope);
4444             return;
4445
4446          --  Analogous to privals, the discriminal generated for an entry index
4447          --  parameter acts as a weak declaration. Perform minimal decoration
4448          --  to avoid bogus errors.
4449
4450          elsif Is_Discriminal (Def_Id)
4451            and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
4452          then
4453             Set_Scope (Def_Id, Current_Scope);
4454             return;
4455
4456          --  In the body or private part of an instance, a type extension may
4457          --  introduce a component with the same name as that of an actual. The
4458          --  legality rule is not enforced, but the semantics of the full type
4459          --  with two components of same name are not clear at this point???
4460
4461          elsif In_Instance_Not_Visible then
4462             null;
4463
4464          --  When compiling a package body, some child units may have become
4465          --  visible. They cannot conflict with local entities that hide them.
4466
4467          elsif Is_Child_Unit (E)
4468            and then In_Open_Scopes (Scope (E))
4469            and then not Is_Immediately_Visible (E)
4470          then
4471             null;
4472
4473          --  Conversely, with front-end inlining we may compile the parent body
4474          --  first, and a child unit subsequently. The context is now the
4475          --  parent spec, and body entities are not visible.
4476
4477          elsif Is_Child_Unit (Def_Id)
4478            and then Is_Package_Body_Entity (E)
4479            and then not In_Package_Body (Current_Scope)
4480          then
4481             null;
4482
4483          --  Case of genuine duplicate declaration
4484
4485          else
4486             Error_Msg_Sloc := Sloc (E);
4487
4488             --  If the previous declaration is an incomplete type declaration
4489             --  this may be an attempt to complete it with a private type. The
4490             --  following avoids confusing cascaded errors.
4491
4492             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
4493               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
4494             then
4495                Error_Msg_N
4496                  ("incomplete type cannot be completed with a private " &
4497                   "declaration", Parent (Def_Id));
4498                Set_Is_Immediately_Visible (E, False);
4499                Set_Full_View (E, Def_Id);
4500
4501             --  An inherited component of a record conflicts with a new
4502             --  discriminant. The discriminant is inserted first in the scope,
4503             --  but the error should be posted on it, not on the component.
4504
4505             elsif Ekind (E) = E_Discriminant
4506               and then Present (Scope (Def_Id))
4507               and then Scope (Def_Id) /= Current_Scope
4508             then
4509                Error_Msg_Sloc := Sloc (Def_Id);
4510                Error_Msg_N ("& conflicts with declaration#", E);
4511                return;
4512
4513             --  If the name of the unit appears in its own context clause, a
4514             --  dummy package with the name has already been created, and the
4515             --  error emitted. Try to continue quietly.
4516
4517             elsif Error_Posted (E)
4518               and then Sloc (E) = No_Location
4519               and then Nkind (Parent (E)) = N_Package_Specification
4520               and then Current_Scope = Standard_Standard
4521             then
4522                Set_Scope (Def_Id, Current_Scope);
4523                return;
4524
4525             else
4526                Error_Msg_N ("& conflicts with declaration#", Def_Id);
4527
4528                --  Avoid cascaded messages with duplicate components in
4529                --  derived types.
4530
4531                if Ekind_In (E, E_Component, E_Discriminant) then
4532                   return;
4533                end if;
4534             end if;
4535
4536             if Nkind (Parent (Parent (Def_Id))) =
4537                 N_Generic_Subprogram_Declaration
4538               and then Def_Id =
4539                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
4540             then
4541                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
4542             end if;
4543
4544             --  If entity is in standard, then we are in trouble, because it
4545             --  means that we have a library package with a duplicated name.
4546             --  That's hard to recover from, so abort!
4547
4548             if S = Standard_Standard then
4549                raise Unrecoverable_Error;
4550
4551             --  Otherwise we continue with the declaration. Having two
4552             --  identical declarations should not cause us too much trouble!
4553
4554             else
4555                null;
4556             end if;
4557          end if;
4558       end if;
4559
4560       --  If we fall through, declaration is OK, at least OK enough to continue
4561
4562       --  If Def_Id is a discriminant or a record component we are in the midst
4563       --  of inheriting components in a derived record definition. Preserve
4564       --  their Ekind and Etype.
4565
4566       if Ekind_In (Def_Id, E_Discriminant, E_Component) then
4567          null;
4568
4569       --  If a type is already set, leave it alone (happens when a type
4570       --  declaration is reanalyzed following a call to the optimizer).
4571
4572       elsif Present (Etype (Def_Id)) then
4573          null;
4574
4575       --  Otherwise, the kind E_Void insures that premature uses of the entity
4576       --  will be detected. Any_Type insures that no cascaded errors will occur
4577
4578       else
4579          Set_Ekind (Def_Id, E_Void);
4580          Set_Etype (Def_Id, Any_Type);
4581       end if;
4582
4583       --  Inherited discriminants and components in derived record types are
4584       --  immediately visible. Itypes are not.
4585
4586       if Ekind_In (Def_Id, E_Discriminant, E_Component)
4587         or else (No (Corresponding_Remote_Type (Def_Id))
4588                  and then not Is_Itype (Def_Id))
4589       then
4590          Set_Is_Immediately_Visible (Def_Id);
4591          Set_Current_Entity         (Def_Id);
4592       end if;
4593
4594       Set_Homonym       (Def_Id, C);
4595       Append_Entity     (Def_Id, S);
4596       Set_Public_Status (Def_Id);
4597
4598       --  Declaring a homonym is not allowed in SPARK ...
4599
4600       if Present (C)
4601         and then Restriction_Check_Required (SPARK_05)
4602       then
4603          declare
4604             Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
4605             Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
4606             Other_Scope    : constant Node_Id := Enclosing_Dynamic_Scope (C);
4607
4608          begin
4609             --  ... unless the new declaration is in a subprogram, and the
4610             --  visible declaration is a variable declaration or a parameter
4611             --  specification outside that subprogram.
4612
4613             if Present (Enclosing_Subp)
4614               and then Nkind_In (Parent (C), N_Object_Declaration,
4615                                              N_Parameter_Specification)
4616               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
4617             then
4618                null;
4619
4620             --  ... or the new declaration is in a package, and the visible
4621             --  declaration occurs outside that package.
4622
4623             elsif Present (Enclosing_Pack)
4624               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
4625             then
4626                null;
4627
4628             --  ... or the new declaration is a component declaration in a
4629             --  record type definition.
4630
4631             elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
4632                null;
4633
4634             --  Don't issue error for non-source entities
4635
4636             elsif Comes_From_Source (Def_Id)
4637               and then Comes_From_Source (C)
4638             then
4639                Error_Msg_Sloc := Sloc (C);
4640                Check_SPARK_Restriction
4641                  ("redeclaration of identifier &#", Def_Id);
4642             end if;
4643          end;
4644       end if;
4645
4646       --  Warn if new entity hides an old one
4647
4648       if Warn_On_Hiding and then Present (C)
4649
4650          --  Don't warn for record components since they always have a well
4651          --  defined scope which does not confuse other uses. Note that in
4652          --  some cases, Ekind has not been set yet.
4653
4654          and then Ekind (C) /= E_Component
4655          and then Ekind (C) /= E_Discriminant
4656          and then Nkind (Parent (C)) /= N_Component_Declaration
4657          and then Ekind (Def_Id) /= E_Component
4658          and then Ekind (Def_Id) /= E_Discriminant
4659          and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
4660
4661          --  Don't warn for one character variables. It is too common to use
4662          --  such variables as locals and will just cause too many false hits.
4663
4664          and then Length_Of_Name (Chars (C)) /= 1
4665
4666          --  Don't warn for non-source entities
4667
4668          and then Comes_From_Source (C)
4669          and then Comes_From_Source (Def_Id)
4670
4671          --  Don't warn unless entity in question is in extended main source
4672
4673          and then In_Extended_Main_Source_Unit (Def_Id)
4674
4675          --  Finally, the hidden entity must be either immediately visible or
4676          --  use visible (i.e. from a used package).
4677
4678          and then
4679            (Is_Immediately_Visible (C)
4680               or else
4681             Is_Potentially_Use_Visible (C))
4682       then
4683          Error_Msg_Sloc := Sloc (C);
4684          Error_Msg_N ("declaration hides &#?h?", Def_Id);
4685       end if;
4686    end Enter_Name;
4687
4688    --------------------------
4689    -- Explain_Limited_Type --
4690    --------------------------
4691
4692    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
4693       C : Entity_Id;
4694
4695    begin
4696       --  For array, component type must be limited
4697
4698       if Is_Array_Type (T) then
4699          Error_Msg_Node_2 := T;
4700          Error_Msg_NE
4701            ("\component type& of type& is limited", N, Component_Type (T));
4702          Explain_Limited_Type (Component_Type (T), N);
4703
4704       elsif Is_Record_Type (T) then
4705
4706          --  No need for extra messages if explicit limited record
4707
4708          if Is_Limited_Record (Base_Type (T)) then
4709             return;
4710          end if;
4711
4712          --  Otherwise find a limited component. Check only components that
4713          --  come from source, or inherited components that appear in the
4714          --  source of the ancestor.
4715
4716          C := First_Component (T);
4717          while Present (C) loop
4718             if Is_Limited_Type (Etype (C))
4719               and then
4720                 (Comes_From_Source (C)
4721                    or else
4722                      (Present (Original_Record_Component (C))
4723                        and then
4724                          Comes_From_Source (Original_Record_Component (C))))
4725             then
4726                Error_Msg_Node_2 := T;
4727                Error_Msg_NE ("\component& of type& has limited type", N, C);
4728                Explain_Limited_Type (Etype (C), N);
4729                return;
4730             end if;
4731
4732             Next_Component (C);
4733          end loop;
4734
4735          --  The type may be declared explicitly limited, even if no component
4736          --  of it is limited, in which case we fall out of the loop.
4737          return;
4738       end if;
4739    end Explain_Limited_Type;
4740
4741    -----------------
4742    -- Find_Actual --
4743    -----------------
4744
4745    procedure Find_Actual
4746      (N        : Node_Id;
4747       Formal   : out Entity_Id;
4748       Call     : out Node_Id)
4749    is
4750       Parnt  : constant Node_Id := Parent (N);
4751       Actual : Node_Id;
4752
4753    begin
4754       if (Nkind (Parnt) = N_Indexed_Component
4755             or else
4756           Nkind (Parnt) = N_Selected_Component)
4757         and then N = Prefix (Parnt)
4758       then
4759          Find_Actual (Parnt, Formal, Call);
4760          return;
4761
4762       elsif Nkind (Parnt) = N_Parameter_Association
4763         and then N = Explicit_Actual_Parameter (Parnt)
4764       then
4765          Call := Parent (Parnt);
4766
4767       elsif Nkind (Parnt) in N_Subprogram_Call then
4768          Call := Parnt;
4769
4770       else
4771          Formal := Empty;
4772          Call   := Empty;
4773          return;
4774       end if;
4775
4776       --  If we have a call to a subprogram look for the parameter. Note that
4777       --  we exclude overloaded calls, since we don't know enough to be sure
4778       --  of giving the right answer in this case.
4779
4780       if Is_Entity_Name (Name (Call))
4781         and then Present (Entity (Name (Call)))
4782         and then Is_Overloadable (Entity (Name (Call)))
4783         and then not Is_Overloaded (Name (Call))
4784       then
4785          --  Fall here if we are definitely a parameter
4786
4787          Actual := First_Actual (Call);
4788          Formal := First_Formal (Entity (Name (Call)));
4789          while Present (Formal) and then Present (Actual) loop
4790             if Actual = N then
4791                return;
4792             else
4793                Actual := Next_Actual (Actual);
4794                Formal := Next_Formal (Formal);
4795             end if;
4796          end loop;
4797       end if;
4798
4799       --  Fall through here if we did not find matching actual
4800
4801       Formal := Empty;
4802       Call   := Empty;
4803    end Find_Actual;
4804
4805    ---------------------------
4806    -- Find_Body_Discriminal --
4807    ---------------------------
4808
4809    function Find_Body_Discriminal
4810      (Spec_Discriminant : Entity_Id) return Entity_Id
4811    is
4812       Tsk  : Entity_Id;
4813       Disc : Entity_Id;
4814
4815    begin
4816       --  If expansion is suppressed, then the scope can be the concurrent type
4817       --  itself rather than a corresponding concurrent record type.
4818
4819       if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
4820          Tsk := Scope (Spec_Discriminant);
4821
4822       else
4823          pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
4824
4825          Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
4826       end if;
4827
4828       --  Find discriminant of original concurrent type, and use its current
4829       --  discriminal, which is the renaming within the task/protected body.
4830
4831       Disc := First_Discriminant (Tsk);
4832       while Present (Disc) loop
4833          if Chars (Disc) = Chars (Spec_Discriminant) then
4834             return Discriminal (Disc);
4835          end if;
4836
4837          Next_Discriminant (Disc);
4838       end loop;
4839
4840       --  That loop should always succeed in finding a matching entry and
4841       --  returning. Fatal error if not.
4842
4843       raise Program_Error;
4844    end Find_Body_Discriminal;
4845
4846    -------------------------------------
4847    -- Find_Corresponding_Discriminant --
4848    -------------------------------------
4849
4850    function Find_Corresponding_Discriminant
4851      (Id  : Node_Id;
4852       Typ : Entity_Id) return Entity_Id
4853    is
4854       Par_Disc : Entity_Id;
4855       Old_Disc : Entity_Id;
4856       New_Disc : Entity_Id;
4857
4858    begin
4859       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
4860
4861       --  The original type may currently be private, and the discriminant
4862       --  only appear on its full view.
4863
4864       if Is_Private_Type (Scope (Par_Disc))
4865         and then not Has_Discriminants (Scope (Par_Disc))
4866         and then Present (Full_View (Scope (Par_Disc)))
4867       then
4868          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
4869       else
4870          Old_Disc := First_Discriminant (Scope (Par_Disc));
4871       end if;
4872
4873       if Is_Class_Wide_Type (Typ) then
4874          New_Disc := First_Discriminant (Root_Type (Typ));
4875       else
4876          New_Disc := First_Discriminant (Typ);
4877       end if;
4878
4879       while Present (Old_Disc) and then Present (New_Disc) loop
4880          if Old_Disc = Par_Disc  then
4881             return New_Disc;
4882          else
4883             Next_Discriminant (Old_Disc);
4884             Next_Discriminant (New_Disc);
4885          end if;
4886       end loop;
4887
4888       --  Should always find it
4889
4890       raise Program_Error;
4891    end Find_Corresponding_Discriminant;
4892
4893    ------------------------------------
4894    -- Find_Loop_In_Conditional_Block --
4895    ------------------------------------
4896
4897    function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
4898       Stmt : Node_Id;
4899
4900    begin
4901       Stmt := N;
4902
4903       if Nkind (Stmt) = N_If_Statement then
4904          Stmt := First (Then_Statements (Stmt));
4905       end if;
4906
4907       pragma Assert (Nkind (Stmt) = N_Block_Statement);
4908
4909       --  Inspect the statements of the conditional block. In general the loop
4910       --  should be the first statement in the statement sequence of the block,
4911       --  but the finalization machinery may have introduced extra object
4912       --  declarations.
4913
4914       Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
4915       while Present (Stmt) loop
4916          if Nkind (Stmt) = N_Loop_Statement then
4917             return Stmt;
4918          end if;
4919
4920          Next (Stmt);
4921       end loop;
4922
4923       --  The expansion of attribute 'Loop_Entry produced a malformed block
4924
4925       raise Program_Error;
4926    end Find_Loop_In_Conditional_Block;
4927
4928    --------------------------
4929    -- Find_Overlaid_Entity --
4930    --------------------------
4931
4932    procedure Find_Overlaid_Entity
4933      (N   : Node_Id;
4934       Ent : out Entity_Id;
4935       Off : out Boolean)
4936    is
4937       Expr : Node_Id;
4938
4939    begin
4940       --  We are looking for one of the two following forms:
4941
4942       --    for X'Address use Y'Address
4943
4944       --  or
4945
4946       --    Const : constant Address := expr;
4947       --    ...
4948       --    for X'Address use Const;
4949
4950       --  In the second case, the expr is either Y'Address, or recursively a
4951       --  constant that eventually references Y'Address.
4952
4953       Ent := Empty;
4954       Off := False;
4955
4956       if Nkind (N) = N_Attribute_Definition_Clause
4957         and then Chars (N) = Name_Address
4958       then
4959          Expr := Expression (N);
4960
4961          --  This loop checks the form of the expression for Y'Address,
4962          --  using recursion to deal with intermediate constants.
4963
4964          loop
4965             --  Check for Y'Address
4966
4967             if Nkind (Expr) = N_Attribute_Reference
4968               and then Attribute_Name (Expr) = Name_Address
4969             then
4970                Expr := Prefix (Expr);
4971                exit;
4972
4973                --  Check for Const where Const is a constant entity
4974
4975             elsif Is_Entity_Name (Expr)
4976               and then Ekind (Entity (Expr)) = E_Constant
4977             then
4978                Expr := Constant_Value (Entity (Expr));
4979
4980             --  Anything else does not need checking
4981
4982             else
4983                return;
4984             end if;
4985          end loop;
4986
4987          --  This loop checks the form of the prefix for an entity, using
4988          --  recursion to deal with intermediate components.
4989
4990          loop
4991             --  Check for Y where Y is an entity
4992
4993             if Is_Entity_Name (Expr) then
4994                Ent := Entity (Expr);
4995                return;
4996
4997             --  Check for components
4998
4999             elsif
5000               Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
5001             then
5002                Expr := Prefix (Expr);
5003                Off := True;
5004
5005             --  Anything else does not need checking
5006
5007             else
5008                return;
5009             end if;
5010          end loop;
5011       end if;
5012    end Find_Overlaid_Entity;
5013
5014    -------------------------
5015    -- Find_Parameter_Type --
5016    -------------------------
5017
5018    function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
5019    begin
5020       if Nkind (Param) /= N_Parameter_Specification then
5021          return Empty;
5022
5023       --  For an access parameter, obtain the type from the formal entity
5024       --  itself, because access to subprogram nodes do not carry a type.
5025       --  Shouldn't we always use the formal entity ???
5026
5027       elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
5028          return Etype (Defining_Identifier (Param));
5029
5030       else
5031          return Etype (Parameter_Type (Param));
5032       end if;
5033    end Find_Parameter_Type;
5034
5035    -----------------------------
5036    -- Find_Static_Alternative --
5037    -----------------------------
5038
5039    function Find_Static_Alternative (N : Node_Id) return Node_Id is
5040       Expr   : constant Node_Id := Expression (N);
5041       Val    : constant Uint    := Expr_Value (Expr);
5042       Alt    : Node_Id;
5043       Choice : Node_Id;
5044
5045    begin
5046       Alt := First (Alternatives (N));
5047
5048       Search : loop
5049          if Nkind (Alt) /= N_Pragma then
5050             Choice := First (Discrete_Choices (Alt));
5051             while Present (Choice) loop
5052
5053                --  Others choice, always matches
5054
5055                if Nkind (Choice) = N_Others_Choice then
5056                   exit Search;
5057
5058                --  Range, check if value is in the range
5059
5060                elsif Nkind (Choice) = N_Range then
5061                   exit Search when
5062                     Val >= Expr_Value (Low_Bound (Choice))
5063                       and then
5064                     Val <= Expr_Value (High_Bound (Choice));
5065
5066                --  Choice is a subtype name. Note that we know it must
5067                --  be a static subtype, since otherwise it would have
5068                --  been diagnosed as illegal.
5069
5070                elsif Is_Entity_Name (Choice)
5071                  and then Is_Type (Entity (Choice))
5072                then
5073                   exit Search when Is_In_Range (Expr, Etype (Choice),
5074                                                 Assume_Valid => False);
5075
5076                --  Choice is a subtype indication
5077
5078                elsif Nkind (Choice) = N_Subtype_Indication then
5079                   declare
5080                      C : constant Node_Id := Constraint (Choice);
5081                      R : constant Node_Id := Range_Expression (C);
5082
5083                   begin
5084                      exit Search when
5085                        Val >= Expr_Value (Low_Bound (R))
5086                          and then
5087                        Val <= Expr_Value (High_Bound (R));
5088                   end;
5089
5090                --  Choice is a simple expression
5091
5092                else
5093                   exit Search when Val = Expr_Value (Choice);
5094                end if;
5095
5096                Next (Choice);
5097             end loop;
5098          end if;
5099
5100          Next (Alt);
5101          pragma Assert (Present (Alt));
5102       end loop Search;
5103
5104       --  The above loop *must* terminate by finding a match, since
5105       --  we know the case statement is valid, and the value of the
5106       --  expression is known at compile time. When we fall out of
5107       --  the loop, Alt points to the alternative that we know will
5108       --  be selected at run time.
5109
5110       return Alt;
5111    end Find_Static_Alternative;
5112
5113    ------------------
5114    -- First_Actual --
5115    ------------------
5116
5117    function First_Actual (Node : Node_Id) return Node_Id is
5118       N : Node_Id;
5119
5120    begin
5121       if No (Parameter_Associations (Node)) then
5122          return Empty;
5123       end if;
5124
5125       N := First (Parameter_Associations (Node));
5126
5127       if Nkind (N) = N_Parameter_Association then
5128          return First_Named_Actual (Node);
5129       else
5130          return N;
5131       end if;
5132    end First_Actual;
5133
5134    -----------------------
5135    -- Gather_Components --
5136    -----------------------
5137
5138    procedure Gather_Components
5139      (Typ           : Entity_Id;
5140       Comp_List     : Node_Id;
5141       Governed_By   : List_Id;
5142       Into          : Elist_Id;
5143       Report_Errors : out Boolean)
5144    is
5145       Assoc           : Node_Id;
5146       Variant         : Node_Id;
5147       Discrete_Choice : Node_Id;
5148       Comp_Item       : Node_Id;
5149
5150       Discrim       : Entity_Id;
5151       Discrim_Name  : Node_Id;
5152       Discrim_Value : Node_Id;
5153
5154    begin
5155       Report_Errors := False;
5156
5157       if No (Comp_List) or else Null_Present (Comp_List) then
5158          return;
5159
5160       elsif Present (Component_Items (Comp_List)) then
5161          Comp_Item := First (Component_Items (Comp_List));
5162
5163       else
5164          Comp_Item := Empty;
5165       end if;
5166
5167       while Present (Comp_Item) loop
5168
5169          --  Skip the tag of a tagged record, the interface tags, as well
5170          --  as all items that are not user components (anonymous types,
5171          --  rep clauses, Parent field, controller field).
5172
5173          if Nkind (Comp_Item) = N_Component_Declaration then
5174             declare
5175                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
5176             begin
5177                if not Is_Tag (Comp)
5178                  and then Chars (Comp) /= Name_uParent
5179                then
5180                   Append_Elmt (Comp, Into);
5181                end if;
5182             end;
5183          end if;
5184
5185          Next (Comp_Item);
5186       end loop;
5187
5188       if No (Variant_Part (Comp_List)) then
5189          return;
5190       else
5191          Discrim_Name := Name (Variant_Part (Comp_List));
5192          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
5193       end if;
5194
5195       --  Look for the discriminant that governs this variant part.
5196       --  The discriminant *must* be in the Governed_By List
5197
5198       Assoc := First (Governed_By);
5199       Find_Constraint : loop
5200          Discrim := First (Choices (Assoc));
5201          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
5202            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
5203                      and then
5204                        Chars (Corresponding_Discriminant (Entity (Discrim))) =
5205                                                        Chars  (Discrim_Name))
5206            or else Chars (Original_Record_Component (Entity (Discrim)))
5207                          = Chars (Discrim_Name);
5208
5209          if No (Next (Assoc)) then
5210             if not Is_Constrained (Typ)
5211               and then Is_Derived_Type (Typ)
5212               and then Present (Stored_Constraint (Typ))
5213             then
5214                --  If the type is a tagged type with inherited discriminants,
5215                --  use the stored constraint on the parent in order to find
5216                --  the values of discriminants that are otherwise hidden by an
5217                --  explicit constraint. Renamed discriminants are handled in
5218                --  the code above.
5219
5220                --  If several parent discriminants are renamed by a single
5221                --  discriminant of the derived type, the call to obtain the
5222                --  Corresponding_Discriminant field only retrieves the last
5223                --  of them. We recover the constraint on the others from the
5224                --  Stored_Constraint as well.
5225
5226                declare
5227                   D : Entity_Id;
5228                   C : Elmt_Id;
5229
5230                begin
5231                   D := First_Discriminant (Etype (Typ));
5232                   C := First_Elmt (Stored_Constraint (Typ));
5233                   while Present (D) and then Present (C) loop
5234                      if Chars (Discrim_Name) = Chars (D) then
5235                         if Is_Entity_Name (Node (C))
5236                           and then Entity (Node (C)) = Entity (Discrim)
5237                         then
5238                            --  D is renamed by Discrim, whose value is given in
5239                            --  Assoc.
5240
5241                            null;
5242
5243                         else
5244                            Assoc :=
5245                              Make_Component_Association (Sloc (Typ),
5246                                New_List
5247                                  (New_Occurrence_Of (D, Sloc (Typ))),
5248                                   Duplicate_Subexpr_No_Checks (Node (C)));
5249                         end if;
5250                         exit Find_Constraint;
5251                      end if;
5252
5253                      Next_Discriminant (D);
5254                      Next_Elmt (C);
5255                   end loop;
5256                end;
5257             end if;
5258          end if;
5259
5260          if No (Next (Assoc)) then
5261             Error_Msg_NE (" missing value for discriminant&",
5262               First (Governed_By), Discrim_Name);
5263             Report_Errors := True;
5264             return;
5265          end if;
5266
5267          Next (Assoc);
5268       end loop Find_Constraint;
5269
5270       Discrim_Value := Expression (Assoc);
5271
5272       if not Is_OK_Static_Expression (Discrim_Value) then
5273          Error_Msg_FE
5274            ("value for discriminant & must be static!",
5275             Discrim_Value, Discrim);
5276          Why_Not_Static (Discrim_Value);
5277          Report_Errors := True;
5278          return;
5279       end if;
5280
5281       Search_For_Discriminant_Value : declare
5282          Low  : Node_Id;
5283          High : Node_Id;
5284
5285          UI_High          : Uint;
5286          UI_Low           : Uint;
5287          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
5288
5289       begin
5290          Find_Discrete_Value : while Present (Variant) loop
5291             Discrete_Choice := First (Discrete_Choices (Variant));
5292             while Present (Discrete_Choice) loop
5293                exit Find_Discrete_Value when
5294                  Nkind (Discrete_Choice) = N_Others_Choice;
5295
5296                Get_Index_Bounds (Discrete_Choice, Low, High);
5297
5298                UI_Low  := Expr_Value (Low);
5299                UI_High := Expr_Value (High);
5300
5301                exit Find_Discrete_Value when
5302                  UI_Low <= UI_Discrim_Value
5303                    and then
5304                  UI_High >= UI_Discrim_Value;
5305
5306                Next (Discrete_Choice);
5307             end loop;
5308
5309             Next_Non_Pragma (Variant);
5310          end loop Find_Discrete_Value;
5311       end Search_For_Discriminant_Value;
5312
5313       if No (Variant) then
5314          Error_Msg_NE
5315            ("value of discriminant & is out of range", Discrim_Value, Discrim);
5316          Report_Errors := True;
5317          return;
5318       end  if;
5319
5320       --  If we have found the corresponding choice, recursively add its
5321       --  components to the Into list.
5322
5323       Gather_Components
5324         (Empty, Component_List (Variant), Governed_By, Into, Report_Errors);
5325    end Gather_Components;
5326
5327    ------------------------
5328    -- Get_Actual_Subtype --
5329    ------------------------
5330
5331    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
5332       Typ  : constant Entity_Id := Etype (N);
5333       Utyp : Entity_Id := Underlying_Type (Typ);
5334       Decl : Node_Id;
5335       Atyp : Entity_Id;
5336
5337    begin
5338       if No (Utyp) then
5339          Utyp := Typ;
5340       end if;
5341
5342       --  If what we have is an identifier that references a subprogram
5343       --  formal, or a variable or constant object, then we get the actual
5344       --  subtype from the referenced entity if one has been built.
5345
5346       if Nkind (N) = N_Identifier
5347         and then
5348           (Is_Formal (Entity (N))
5349             or else Ekind (Entity (N)) = E_Constant
5350             or else Ekind (Entity (N)) = E_Variable)
5351         and then Present (Actual_Subtype (Entity (N)))
5352       then
5353          return Actual_Subtype (Entity (N));
5354
5355       --  Actual subtype of unchecked union is always itself. We never need
5356       --  the "real" actual subtype. If we did, we couldn't get it anyway
5357       --  because the discriminant is not available. The restrictions on
5358       --  Unchecked_Union are designed to make sure that this is OK.
5359
5360       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
5361          return Typ;
5362
5363       --  Here for the unconstrained case, we must find actual subtype
5364       --  No actual subtype is available, so we must build it on the fly.
5365
5366       --  Checking the type, not the underlying type, for constrainedness
5367       --  seems to be necessary. Maybe all the tests should be on the type???
5368
5369       elsif (not Is_Constrained (Typ))
5370            and then (Is_Array_Type (Utyp)
5371                       or else (Is_Record_Type (Utyp)
5372                                 and then Has_Discriminants (Utyp)))
5373            and then not Has_Unknown_Discriminants (Utyp)
5374            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
5375       then
5376          --  Nothing to do if in spec expression (why not???)
5377
5378          if In_Spec_Expression then
5379             return Typ;
5380
5381          elsif Is_Private_Type (Typ)
5382            and then not Has_Discriminants (Typ)
5383          then
5384             --  If the type has no discriminants, there is no subtype to
5385             --  build, even if the underlying type is discriminated.
5386
5387             return Typ;
5388
5389          --  Else build the actual subtype
5390
5391          else
5392             Decl := Build_Actual_Subtype (Typ, N);
5393             Atyp := Defining_Identifier (Decl);
5394
5395             --  If Build_Actual_Subtype generated a new declaration then use it
5396
5397             if Atyp /= Typ then
5398
5399                --  The actual subtype is an Itype, so analyze the declaration,
5400                --  but do not attach it to the tree, to get the type defined.
5401
5402                Set_Parent (Decl, N);
5403                Set_Is_Itype (Atyp);
5404                Analyze (Decl, Suppress => All_Checks);
5405                Set_Associated_Node_For_Itype (Atyp, N);
5406                Set_Has_Delayed_Freeze (Atyp, False);
5407
5408                --  We need to freeze the actual subtype immediately. This is
5409                --  needed, because otherwise this Itype will not get frozen
5410                --  at all, and it is always safe to freeze on creation because
5411                --  any associated types must be frozen at this point.
5412
5413                Freeze_Itype (Atyp, N);
5414                return Atyp;
5415
5416             --  Otherwise we did not build a declaration, so return original
5417
5418             else
5419                return Typ;
5420             end if;
5421          end if;
5422
5423       --  For all remaining cases, the actual subtype is the same as
5424       --  the nominal type.
5425
5426       else
5427          return Typ;
5428       end if;
5429    end Get_Actual_Subtype;
5430
5431    -------------------------------------
5432    -- Get_Actual_Subtype_If_Available --
5433    -------------------------------------
5434
5435    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
5436       Typ  : constant Entity_Id := Etype (N);
5437
5438    begin
5439       --  If what we have is an identifier that references a subprogram
5440       --  formal, or a variable or constant object, then we get the actual
5441       --  subtype from the referenced entity if one has been built.
5442
5443       if Nkind (N) = N_Identifier
5444         and then
5445           (Is_Formal (Entity (N))
5446             or else Ekind (Entity (N)) = E_Constant
5447             or else Ekind (Entity (N)) = E_Variable)
5448         and then Present (Actual_Subtype (Entity (N)))
5449       then
5450          return Actual_Subtype (Entity (N));
5451
5452       --  Otherwise the Etype of N is returned unchanged
5453
5454       else
5455          return Typ;
5456       end if;
5457    end Get_Actual_Subtype_If_Available;
5458
5459    ------------------------
5460    -- Get_Body_From_Stub --
5461    ------------------------
5462
5463    function Get_Body_From_Stub (N : Node_Id) return Node_Id is
5464    begin
5465       return Proper_Body (Unit (Library_Unit (N)));
5466    end Get_Body_From_Stub;
5467
5468    -------------------------------
5469    -- Get_Default_External_Name --
5470    -------------------------------
5471
5472    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
5473    begin
5474       Get_Decoded_Name_String (Chars (E));
5475
5476       if Opt.External_Name_Imp_Casing = Uppercase then
5477          Set_Casing (All_Upper_Case);
5478       else
5479          Set_Casing (All_Lower_Case);
5480       end if;
5481
5482       return
5483         Make_String_Literal (Sloc (E),
5484           Strval => String_From_Name_Buffer);
5485    end Get_Default_External_Name;
5486
5487    --------------------------
5488    -- Get_Enclosing_Object --
5489    --------------------------
5490
5491    function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
5492    begin
5493       if Is_Entity_Name (N) then
5494          return Entity (N);
5495       else
5496          case Nkind (N) is
5497             when N_Indexed_Component  |
5498                  N_Slice              |
5499                  N_Selected_Component =>
5500
5501                --  If not generating code, a dereference may be left implicit.
5502                --  In thoses cases, return Empty.
5503
5504                if Is_Access_Type (Etype (Prefix (N))) then
5505                   return Empty;
5506                else
5507                   return Get_Enclosing_Object (Prefix (N));
5508                end if;
5509
5510             when N_Type_Conversion =>
5511                return Get_Enclosing_Object (Expression (N));
5512
5513             when others =>
5514                return Empty;
5515          end case;
5516       end if;
5517    end Get_Enclosing_Object;
5518
5519    ---------------------------
5520    -- Get_Enum_Lit_From_Pos --
5521    ---------------------------
5522
5523    function Get_Enum_Lit_From_Pos
5524      (T   : Entity_Id;
5525       Pos : Uint;
5526       Loc : Source_Ptr) return Node_Id
5527    is
5528       Btyp : Entity_Id := Base_Type (T);
5529       Lit  : Node_Id;
5530
5531    begin
5532       --  In the case where the literal is of type Character, Wide_Character
5533       --  or Wide_Wide_Character or of a type derived from them, there needs
5534       --  to be some special handling since there is no explicit chain of
5535       --  literals to search. Instead, an N_Character_Literal node is created
5536       --  with the appropriate Char_Code and Chars fields.
5537
5538       if Is_Standard_Character_Type (T) then
5539          Set_Character_Literal_Name (UI_To_CC (Pos));
5540          return
5541            Make_Character_Literal (Loc,
5542              Chars              => Name_Find,
5543              Char_Literal_Value => Pos);
5544
5545       --  For all other cases, we have a complete table of literals, and
5546       --  we simply iterate through the chain of literal until the one
5547       --  with the desired position value is found.
5548       --
5549
5550       else
5551          if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
5552             Btyp := Full_View (Btyp);
5553          end if;
5554
5555          Lit := First_Literal (Btyp);
5556          for J in 1 .. UI_To_Int (Pos) loop
5557             Next_Literal (Lit);
5558          end loop;
5559
5560          return New_Occurrence_Of (Lit, Loc);
5561       end if;
5562    end Get_Enum_Lit_From_Pos;
5563
5564    ---------------------------------
5565    -- Get_Ensures_From_CTC_Pragma --
5566    ---------------------------------
5567
5568    function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
5569       Args : constant List_Id := Pragma_Argument_Associations (N);
5570       Res  : Node_Id;
5571
5572    begin
5573       if List_Length (Args) = 4 then
5574          Res := Pick (Args, 4);
5575
5576       elsif List_Length (Args) = 3 then
5577          Res := Pick (Args, 3);
5578
5579          if Chars (Res) /= Name_Ensures then
5580             Res := Empty;
5581          end if;
5582
5583       else
5584          Res := Empty;
5585       end if;
5586
5587       return Res;
5588    end Get_Ensures_From_CTC_Pragma;
5589
5590    ------------------------
5591    -- Get_Generic_Entity --
5592    ------------------------
5593
5594    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
5595       Ent : constant Entity_Id := Entity (Name (N));
5596    begin
5597       if Present (Renamed_Object (Ent)) then
5598          return Renamed_Object (Ent);
5599       else
5600          return Ent;
5601       end if;
5602    end Get_Generic_Entity;
5603
5604    -------------------------------------
5605    -- Get_Incomplete_View_Of_Ancestor --
5606    -------------------------------------
5607
5608    function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
5609       Cur_Unit  : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
5610       Par_Scope : Entity_Id;
5611       Par_Type  : Entity_Id;
5612
5613    begin
5614       --  The incomplete view of an ancestor is only relevant for private
5615       --  derived types in child units.
5616
5617       if not Is_Derived_Type (E)
5618         or else not Is_Child_Unit (Cur_Unit)
5619       then
5620          return Empty;
5621
5622       else
5623          Par_Scope := Scope (Cur_Unit);
5624          if No (Par_Scope) then
5625             return Empty;
5626          end if;
5627
5628          Par_Type := Etype (Base_Type (E));
5629
5630          --  Traverse list of ancestor types until we find one declared in
5631          --  a parent or grandparent unit (two levels seem sufficient).
5632
5633          while Present (Par_Type) loop
5634             if Scope (Par_Type) = Par_Scope
5635               or else Scope (Par_Type) = Scope (Par_Scope)
5636             then
5637                return Par_Type;
5638
5639             elsif not Is_Derived_Type (Par_Type) then
5640                return Empty;
5641
5642             else
5643                Par_Type := Etype (Base_Type (Par_Type));
5644             end if;
5645          end loop;
5646
5647          --  If none found, there is no relevant ancestor type.
5648
5649          return Empty;
5650       end if;
5651    end Get_Incomplete_View_Of_Ancestor;
5652
5653    ----------------------
5654    -- Get_Index_Bounds --
5655    ----------------------
5656
5657    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
5658       Kind : constant Node_Kind := Nkind (N);
5659       R    : Node_Id;
5660
5661    begin
5662       if Kind = N_Range then
5663          L := Low_Bound (N);
5664          H := High_Bound (N);
5665
5666       elsif Kind = N_Subtype_Indication then
5667          R := Range_Expression (Constraint (N));
5668
5669          if R = Error then
5670             L := Error;
5671             H := Error;
5672             return;
5673
5674          else
5675             L := Low_Bound  (Range_Expression (Constraint (N)));
5676             H := High_Bound (Range_Expression (Constraint (N)));
5677          end if;
5678
5679       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
5680          if Error_Posted (Scalar_Range (Entity (N))) then
5681             L := Error;
5682             H := Error;
5683
5684          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
5685             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
5686
5687          else
5688             L := Low_Bound  (Scalar_Range (Entity (N)));
5689             H := High_Bound (Scalar_Range (Entity (N)));
5690          end if;
5691
5692       else
5693          --  N is an expression, indicating a range with one value
5694
5695          L := N;
5696          H := N;
5697       end if;
5698    end Get_Index_Bounds;
5699
5700    ----------------------------------
5701    -- Get_Library_Unit_Name_string --
5702    ----------------------------------
5703
5704    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
5705       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
5706
5707    begin
5708       Get_Unit_Name_String (Unit_Name_Id);
5709
5710       --  Remove seven last character (" (spec)" or " (body)")
5711
5712       Name_Len := Name_Len - 7;
5713       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
5714    end Get_Library_Unit_Name_String;
5715
5716    ------------------------
5717    -- Get_Name_Entity_Id --
5718    ------------------------
5719
5720    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
5721    begin
5722       return Entity_Id (Get_Name_Table_Info (Id));
5723    end Get_Name_Entity_Id;
5724
5725    ------------------------------
5726    -- Get_Name_From_CTC_Pragma --
5727    ------------------------------
5728
5729    function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
5730       Arg : constant Node_Id :=
5731               Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
5732    begin
5733       return Strval (Expr_Value_S (Arg));
5734    end Get_Name_From_CTC_Pragma;
5735
5736    -------------------
5737    -- Get_Pragma_Id --
5738    -------------------
5739
5740    function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
5741    begin
5742       return Get_Pragma_Id (Pragma_Name (N));
5743    end Get_Pragma_Id;
5744
5745    ---------------------------
5746    -- Get_Referenced_Object --
5747    ---------------------------
5748
5749    function Get_Referenced_Object (N : Node_Id) return Node_Id is
5750       R : Node_Id;
5751
5752    begin
5753       R := N;
5754       while Is_Entity_Name (R)
5755         and then Present (Renamed_Object (Entity (R)))
5756       loop
5757          R := Renamed_Object (Entity (R));
5758       end loop;
5759
5760       return R;
5761    end Get_Referenced_Object;
5762
5763    ------------------------
5764    -- Get_Renamed_Entity --
5765    ------------------------
5766
5767    function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
5768       R : Entity_Id;
5769
5770    begin
5771       R := E;
5772       while Present (Renamed_Entity (R)) loop
5773          R := Renamed_Entity (R);
5774       end loop;
5775
5776       return R;
5777    end Get_Renamed_Entity;
5778
5779    ----------------------------------
5780    -- Get_Requires_From_CTC_Pragma --
5781    ----------------------------------
5782
5783    function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
5784       Args : constant List_Id := Pragma_Argument_Associations (N);
5785       Res  : Node_Id;
5786
5787    begin
5788       if List_Length (Args) >= 3 then
5789          Res := Pick (Args, 3);
5790
5791          if Chars (Res) /= Name_Requires then
5792             Res := Empty;
5793          end if;
5794
5795       else
5796          Res := Empty;
5797       end if;
5798
5799       return Res;
5800    end Get_Requires_From_CTC_Pragma;
5801
5802    -------------------------
5803    -- Get_Subprogram_Body --
5804    -------------------------
5805
5806    function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
5807       Decl : Node_Id;
5808
5809    begin
5810       Decl := Unit_Declaration_Node (E);
5811
5812       if Nkind (Decl) = N_Subprogram_Body then
5813          return Decl;
5814
5815       --  The below comment is bad, because it is possible for
5816       --  Nkind (Decl) to be an N_Subprogram_Body_Stub ???
5817
5818       else           --  Nkind (Decl) = N_Subprogram_Declaration
5819
5820          if Present (Corresponding_Body (Decl)) then
5821             return Unit_Declaration_Node (Corresponding_Body (Decl));
5822
5823          --  Imported subprogram case
5824
5825          else
5826             return Empty;
5827          end if;
5828       end if;
5829    end Get_Subprogram_Body;
5830
5831    ---------------------------
5832    -- Get_Subprogram_Entity --
5833    ---------------------------
5834
5835    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
5836       Subp    : Node_Id;
5837       Subp_Id : Entity_Id;
5838
5839    begin
5840       if Nkind (Nod) = N_Accept_Statement then
5841          Subp := Entry_Direct_Name (Nod);
5842
5843       elsif Nkind (Nod) = N_Slice then
5844          Subp := Prefix (Nod);
5845
5846       else
5847          Subp := Name (Nod);
5848       end if;
5849
5850       --  Strip the subprogram call
5851
5852       loop
5853          if Nkind_In (Subp, N_Explicit_Dereference,
5854                             N_Indexed_Component,
5855                             N_Selected_Component)
5856          then
5857             Subp := Prefix (Subp);
5858
5859          elsif Nkind_In (Subp, N_Type_Conversion,
5860                                N_Unchecked_Type_Conversion)
5861          then
5862             Subp := Expression (Subp);
5863
5864          else
5865             exit;
5866          end if;
5867       end loop;
5868
5869       --  Extract the entity of the subprogram call
5870
5871       if Is_Entity_Name (Subp) then
5872          Subp_Id := Entity (Subp);
5873
5874          if Ekind (Subp_Id) = E_Access_Subprogram_Type then
5875             Subp_Id := Directly_Designated_Type (Subp_Id);
5876          end if;
5877
5878          if Is_Subprogram (Subp_Id) then
5879             return Subp_Id;
5880          else
5881             return Empty;
5882          end if;
5883
5884       --  The search did not find a construct that denotes a subprogram
5885
5886       else
5887          return Empty;
5888       end if;
5889    end Get_Subprogram_Entity;
5890
5891    -----------------------------
5892    -- Get_Task_Body_Procedure --
5893    -----------------------------
5894
5895    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
5896    begin
5897       --  Note: A task type may be the completion of a private type with
5898       --  discriminants. When performing elaboration checks on a task
5899       --  declaration, the current view of the type may be the private one,
5900       --  and the procedure that holds the body of the task is held in its
5901       --  underlying type.
5902
5903       --  This is an odd function, why not have Task_Body_Procedure do
5904       --  the following digging???
5905
5906       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
5907    end Get_Task_Body_Procedure;
5908
5909    -----------------------
5910    -- Has_Access_Values --
5911    -----------------------
5912
5913    function Has_Access_Values (T : Entity_Id) return Boolean is
5914       Typ : constant Entity_Id := Underlying_Type (T);
5915
5916    begin
5917       --  Case of a private type which is not completed yet. This can only
5918       --  happen in the case of a generic format type appearing directly, or
5919       --  as a component of the type to which this function is being applied
5920       --  at the top level. Return False in this case, since we certainly do
5921       --  not know that the type contains access types.
5922
5923       if No (Typ) then
5924          return False;
5925
5926       elsif Is_Access_Type (Typ) then
5927          return True;
5928
5929       elsif Is_Array_Type (Typ) then
5930          return Has_Access_Values (Component_Type (Typ));
5931
5932       elsif Is_Record_Type (Typ) then
5933          declare
5934             Comp : Entity_Id;
5935
5936          begin
5937             --  Loop to Check components
5938
5939             Comp := First_Component_Or_Discriminant (Typ);
5940             while Present (Comp) loop
5941
5942                --  Check for access component, tag field does not count, even
5943                --  though it is implemented internally using an access type.
5944
5945                if Has_Access_Values (Etype (Comp))
5946                  and then Chars (Comp) /= Name_uTag
5947                then
5948                   return True;
5949                end if;
5950
5951                Next_Component_Or_Discriminant (Comp);
5952             end loop;
5953          end;
5954
5955          return False;
5956
5957       else
5958          return False;
5959       end if;
5960    end Has_Access_Values;
5961
5962    ------------------------------
5963    -- Has_Compatible_Alignment --
5964    ------------------------------
5965
5966    function Has_Compatible_Alignment
5967      (Obj  : Entity_Id;
5968       Expr : Node_Id) return Alignment_Result
5969    is
5970       function Has_Compatible_Alignment_Internal
5971         (Obj     : Entity_Id;
5972          Expr    : Node_Id;
5973          Default : Alignment_Result) return Alignment_Result;
5974       --  This is the internal recursive function that actually does the work.
5975       --  There is one additional parameter, which says what the result should
5976       --  be if no alignment information is found, and there is no definite
5977       --  indication of compatible alignments. At the outer level, this is set
5978       --  to Unknown, but for internal recursive calls in the case where types
5979       --  are known to be correct, it is set to Known_Compatible.
5980
5981       ---------------------------------------
5982       -- Has_Compatible_Alignment_Internal --
5983       ---------------------------------------
5984
5985       function Has_Compatible_Alignment_Internal
5986         (Obj     : Entity_Id;
5987          Expr    : Node_Id;
5988          Default : Alignment_Result) return Alignment_Result
5989       is
5990          Result : Alignment_Result := Known_Compatible;
5991          --  Holds the current status of the result. Note that once a value of
5992          --  Known_Incompatible is set, it is sticky and does not get changed
5993          --  to Unknown (the value in Result only gets worse as we go along,
5994          --  never better).
5995
5996          Offs : Uint := No_Uint;
5997          --  Set to a factor of the offset from the base object when Expr is a
5998          --  selected or indexed component, based on Component_Bit_Offset and
5999          --  Component_Size respectively. A negative value is used to represent
6000          --  a value which is not known at compile time.
6001
6002          procedure Check_Prefix;
6003          --  Checks the prefix recursively in the case where the expression
6004          --  is an indexed or selected component.
6005
6006          procedure Set_Result (R : Alignment_Result);
6007          --  If R represents a worse outcome (unknown instead of known
6008          --  compatible, or known incompatible), then set Result to R.
6009
6010          ------------------
6011          -- Check_Prefix --
6012          ------------------
6013
6014          procedure Check_Prefix is
6015          begin
6016             --  The subtlety here is that in doing a recursive call to check
6017             --  the prefix, we have to decide what to do in the case where we
6018             --  don't find any specific indication of an alignment problem.
6019
6020             --  At the outer level, we normally set Unknown as the result in
6021             --  this case, since we can only set Known_Compatible if we really
6022             --  know that the alignment value is OK, but for the recursive
6023             --  call, in the case where the types match, and we have not
6024             --  specified a peculiar alignment for the object, we are only
6025             --  concerned about suspicious rep clauses, the default case does
6026             --  not affect us, since the compiler will, in the absence of such
6027             --  rep clauses, ensure that the alignment is correct.
6028
6029             if Default = Known_Compatible
6030               or else
6031                 (Etype (Obj) = Etype (Expr)
6032                   and then (Unknown_Alignment (Obj)
6033                              or else
6034                                Alignment (Obj) = Alignment (Etype (Obj))))
6035             then
6036                Set_Result
6037                  (Has_Compatible_Alignment_Internal
6038                     (Obj, Prefix (Expr), Known_Compatible));
6039
6040             --  In all other cases, we need a full check on the prefix
6041
6042             else
6043                Set_Result
6044                  (Has_Compatible_Alignment_Internal
6045                     (Obj, Prefix (Expr), Unknown));
6046             end if;
6047          end Check_Prefix;
6048
6049          ----------------
6050          -- Set_Result --
6051          ----------------
6052
6053          procedure Set_Result (R : Alignment_Result) is
6054          begin
6055             if R > Result then
6056                Result := R;
6057             end if;
6058          end Set_Result;
6059
6060       --  Start of processing for Has_Compatible_Alignment_Internal
6061
6062       begin
6063          --  If Expr is a selected component, we must make sure there is no
6064          --  potentially troublesome component clause, and that the record is
6065          --  not packed.
6066
6067          if Nkind (Expr) = N_Selected_Component then
6068
6069             --  Packed record always generate unknown alignment
6070
6071             if Is_Packed (Etype (Prefix (Expr))) then
6072                Set_Result (Unknown);
6073             end if;
6074
6075             --  Check prefix and component offset
6076
6077             Check_Prefix;
6078             Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
6079
6080          --  If Expr is an indexed component, we must make sure there is no
6081          --  potentially troublesome Component_Size clause and that the array
6082          --  is not bit-packed.
6083
6084          elsif Nkind (Expr) = N_Indexed_Component then
6085             declare
6086                Typ : constant Entity_Id := Etype (Prefix (Expr));
6087                Ind : constant Node_Id   := First_Index (Typ);
6088
6089             begin
6090                --  Bit packed array always generates unknown alignment
6091
6092                if Is_Bit_Packed_Array (Typ) then
6093                   Set_Result (Unknown);
6094                end if;
6095
6096                --  Check prefix and component offset
6097
6098                Check_Prefix;
6099                Offs := Component_Size (Typ);
6100
6101                --  Small optimization: compute the full offset when possible
6102
6103                if Offs /= No_Uint
6104                  and then Offs > Uint_0
6105                  and then Present (Ind)
6106                  and then Nkind (Ind) = N_Range
6107                  and then Compile_Time_Known_Value (Low_Bound (Ind))
6108                  and then Compile_Time_Known_Value (First (Expressions (Expr)))
6109                then
6110                   Offs := Offs * (Expr_Value (First (Expressions (Expr)))
6111                                     - Expr_Value (Low_Bound ((Ind))));
6112                end if;
6113             end;
6114          end if;
6115
6116          --  If we have a null offset, the result is entirely determined by
6117          --  the base object and has already been computed recursively.
6118
6119          if Offs = Uint_0 then
6120             null;
6121
6122          --  Case where we know the alignment of the object
6123
6124          elsif Known_Alignment (Obj) then
6125             declare
6126                ObjA : constant Uint := Alignment (Obj);
6127                ExpA : Uint          := No_Uint;
6128                SizA : Uint          := No_Uint;
6129
6130             begin
6131                --  If alignment of Obj is 1, then we are always OK
6132
6133                if ObjA = 1 then
6134                   Set_Result (Known_Compatible);
6135
6136                --  Alignment of Obj is greater than 1, so we need to check
6137
6138                else
6139                   --  If we have an offset, see if it is compatible
6140
6141                   if Offs /= No_Uint and Offs > Uint_0 then
6142                      if Offs mod (System_Storage_Unit * ObjA) /= 0 then
6143                         Set_Result (Known_Incompatible);
6144                      end if;
6145
6146                      --  See if Expr is an object with known alignment
6147
6148                   elsif Is_Entity_Name (Expr)
6149                     and then Known_Alignment (Entity (Expr))
6150                   then
6151                      ExpA := Alignment (Entity (Expr));
6152
6153                      --  Otherwise, we can use the alignment of the type of
6154                      --  Expr given that we already checked for
6155                      --  discombobulating rep clauses for the cases of indexed
6156                      --  and selected components above.
6157
6158                   elsif Known_Alignment (Etype (Expr)) then
6159                      ExpA := Alignment (Etype (Expr));
6160
6161                      --  Otherwise the alignment is unknown
6162
6163                   else
6164                      Set_Result (Default);
6165                   end if;
6166
6167                   --  If we got an alignment, see if it is acceptable
6168
6169                   if ExpA /= No_Uint and then ExpA < ObjA then
6170                      Set_Result (Known_Incompatible);
6171                   end if;
6172
6173                   --  If Expr is not a piece of a larger object, see if size
6174                   --  is given. If so, check that it is not too small for the
6175                   --  required alignment.
6176
6177                   if Offs /= No_Uint then
6178                      null;
6179
6180                      --  See if Expr is an object with known size
6181
6182                   elsif Is_Entity_Name (Expr)
6183                     and then Known_Static_Esize (Entity (Expr))
6184                   then
6185                      SizA := Esize (Entity (Expr));
6186
6187                      --  Otherwise, we check the object size of the Expr type
6188
6189                   elsif Known_Static_Esize (Etype (Expr)) then
6190                      SizA := Esize (Etype (Expr));
6191                   end if;
6192
6193                   --  If we got a size, see if it is a multiple of the Obj
6194                   --  alignment, if not, then the alignment cannot be
6195                   --  acceptable, since the size is always a multiple of the
6196                   --  alignment.
6197
6198                   if SizA /= No_Uint then
6199                      if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
6200                         Set_Result (Known_Incompatible);
6201                      end if;
6202                   end if;
6203                end if;
6204             end;
6205
6206          --  If we do not know required alignment, any non-zero offset is a
6207          --  potential problem (but certainly may be OK, so result is unknown).
6208
6209          elsif Offs /= No_Uint then
6210             Set_Result (Unknown);
6211
6212          --  If we can't find the result by direct comparison of alignment
6213          --  values, then there is still one case that we can determine known
6214          --  result, and that is when we can determine that the types are the
6215          --  same, and no alignments are specified. Then we known that the
6216          --  alignments are compatible, even if we don't know the alignment
6217          --  value in the front end.
6218
6219          elsif Etype (Obj) = Etype (Expr) then
6220
6221             --  Types are the same, but we have to check for possible size
6222             --  and alignments on the Expr object that may make the alignment
6223             --  different, even though the types are the same.
6224
6225             if Is_Entity_Name (Expr) then
6226
6227                --  First check alignment of the Expr object. Any alignment less
6228                --  than Maximum_Alignment is worrisome since this is the case
6229                --  where we do not know the alignment of Obj.
6230
6231                if Known_Alignment (Entity (Expr))
6232                  and then
6233                    UI_To_Int (Alignment (Entity (Expr))) <
6234                                                     Ttypes.Maximum_Alignment
6235                then
6236                   Set_Result (Unknown);
6237
6238                   --  Now check size of Expr object. Any size that is not an
6239                   --  even multiple of Maximum_Alignment is also worrisome
6240                   --  since it may cause the alignment of the object to be less
6241                   --  than the alignment of the type.
6242
6243                elsif Known_Static_Esize (Entity (Expr))
6244                  and then
6245                    (UI_To_Int (Esize (Entity (Expr))) mod
6246                      (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
6247                                                                         /= 0
6248                then
6249                   Set_Result (Unknown);
6250
6251                   --  Otherwise same type is decisive
6252
6253                else
6254                   Set_Result (Known_Compatible);
6255                end if;
6256             end if;
6257
6258          --  Another case to deal with is when there is an explicit size or
6259          --  alignment clause when the types are not the same. If so, then the
6260          --  result is Unknown. We don't need to do this test if the Default is
6261          --  Unknown, since that result will be set in any case.
6262
6263          elsif Default /= Unknown
6264            and then (Has_Size_Clause      (Etype (Expr))
6265                       or else
6266                      Has_Alignment_Clause (Etype (Expr)))
6267          then
6268             Set_Result (Unknown);
6269
6270          --  If no indication found, set default
6271
6272          else
6273             Set_Result (Default);
6274          end if;
6275
6276          --  Return worst result found
6277
6278          return Result;
6279       end Has_Compatible_Alignment_Internal;
6280
6281    --  Start of processing for Has_Compatible_Alignment
6282
6283    begin
6284       --  If Obj has no specified alignment, then set alignment from the type
6285       --  alignment. Perhaps we should always do this, but for sure we should
6286       --  do it when there is an address clause since we can do more if the
6287       --  alignment is known.
6288
6289       if Unknown_Alignment (Obj) then
6290          Set_Alignment (Obj, Alignment (Etype (Obj)));
6291       end if;
6292
6293       --  Now do the internal call that does all the work
6294
6295       return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
6296    end Has_Compatible_Alignment;
6297
6298    ----------------------
6299    -- Has_Declarations --
6300    ----------------------
6301
6302    function Has_Declarations (N : Node_Id) return Boolean is
6303    begin
6304       return Nkind_In (Nkind (N), N_Accept_Statement,
6305                                   N_Block_Statement,
6306                                   N_Compilation_Unit_Aux,
6307                                   N_Entry_Body,
6308                                   N_Package_Body,
6309                                   N_Protected_Body,
6310                                   N_Subprogram_Body,
6311                                   N_Task_Body,
6312                                   N_Package_Specification);
6313    end Has_Declarations;
6314
6315    -------------------
6316    -- Has_Denormals --
6317    -------------------
6318
6319    function Has_Denormals (E : Entity_Id) return Boolean is
6320    begin
6321       return Is_Floating_Point_Type (E)
6322         and then Denorm_On_Target
6323         and then not Vax_Float (E);
6324    end Has_Denormals;
6325
6326    -------------------------------------------
6327    -- Has_Discriminant_Dependent_Constraint --
6328    -------------------------------------------
6329
6330    function Has_Discriminant_Dependent_Constraint
6331      (Comp : Entity_Id) return Boolean
6332    is
6333       Comp_Decl  : constant Node_Id := Parent (Comp);
6334       Subt_Indic : constant Node_Id :=
6335                      Subtype_Indication (Component_Definition (Comp_Decl));
6336       Constr     : Node_Id;
6337       Assn       : Node_Id;
6338
6339    begin
6340       if Nkind (Subt_Indic) = N_Subtype_Indication then
6341          Constr := Constraint (Subt_Indic);
6342
6343          if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
6344             Assn := First (Constraints (Constr));
6345             while Present (Assn) loop
6346                case Nkind (Assn) is
6347                   when N_Subtype_Indication |
6348                        N_Range              |
6349                        N_Identifier
6350                   =>
6351                      if Depends_On_Discriminant (Assn) then
6352                         return True;
6353                      end if;
6354
6355                   when N_Discriminant_Association =>
6356                      if Depends_On_Discriminant (Expression (Assn)) then
6357                         return True;
6358                      end if;
6359
6360                   when others =>
6361                      null;
6362
6363                end case;
6364
6365                Next (Assn);
6366             end loop;
6367          end if;
6368       end if;
6369
6370       return False;
6371    end Has_Discriminant_Dependent_Constraint;
6372
6373    --------------------
6374    -- Has_Infinities --
6375    --------------------
6376
6377    function Has_Infinities (E : Entity_Id) return Boolean is
6378    begin
6379       return
6380         Is_Floating_Point_Type (E)
6381           and then Nkind (Scalar_Range (E)) = N_Range
6382           and then Includes_Infinities (Scalar_Range (E));
6383    end Has_Infinities;
6384
6385    --------------------
6386    -- Has_Interfaces --
6387    --------------------
6388
6389    function Has_Interfaces
6390      (T             : Entity_Id;
6391       Use_Full_View : Boolean := True) return Boolean
6392    is
6393       Typ : Entity_Id := Base_Type (T);
6394
6395    begin
6396       --  Handle concurrent types
6397
6398       if Is_Concurrent_Type (Typ) then
6399          Typ := Corresponding_Record_Type (Typ);
6400       end if;
6401
6402       if not Present (Typ)
6403         or else not Is_Record_Type (Typ)
6404         or else not Is_Tagged_Type (Typ)
6405       then
6406          return False;
6407       end if;
6408
6409       --  Handle private types
6410
6411       if Use_Full_View
6412         and then Present (Full_View (Typ))
6413       then
6414          Typ := Full_View (Typ);
6415       end if;
6416
6417       --  Handle concurrent record types
6418
6419       if Is_Concurrent_Record_Type (Typ)
6420         and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
6421       then
6422          return True;
6423       end if;
6424
6425       loop
6426          if Is_Interface (Typ)
6427            or else
6428              (Is_Record_Type (Typ)
6429                and then Present (Interfaces (Typ))
6430                and then not Is_Empty_Elmt_List (Interfaces (Typ)))
6431          then
6432             return True;
6433          end if;
6434
6435          exit when Etype (Typ) = Typ
6436
6437             --  Handle private types
6438
6439             or else (Present (Full_View (Etype (Typ)))
6440                        and then Full_View (Etype (Typ)) = Typ)
6441
6442             --  Protect the frontend against wrong source with cyclic
6443             --  derivations
6444
6445             or else Etype (Typ) = T;
6446
6447          --  Climb to the ancestor type handling private types
6448
6449          if Present (Full_View (Etype (Typ))) then
6450             Typ := Full_View (Etype (Typ));
6451          else
6452             Typ := Etype (Typ);
6453          end if;
6454       end loop;
6455
6456       return False;
6457    end Has_Interfaces;
6458
6459    ------------------------
6460    -- Has_Null_Exclusion --
6461    ------------------------
6462
6463    function Has_Null_Exclusion (N : Node_Id) return Boolean is
6464    begin
6465       case Nkind (N) is
6466          when N_Access_Definition               |
6467               N_Access_Function_Definition      |
6468               N_Access_Procedure_Definition     |
6469               N_Access_To_Object_Definition     |
6470               N_Allocator                       |
6471               N_Derived_Type_Definition         |
6472               N_Function_Specification          |
6473               N_Subtype_Declaration             =>
6474             return Null_Exclusion_Present (N);
6475
6476          when N_Component_Definition            |
6477               N_Formal_Object_Declaration       |
6478               N_Object_Renaming_Declaration     =>
6479             if Present (Subtype_Mark (N)) then
6480                return Null_Exclusion_Present (N);
6481             else pragma Assert (Present (Access_Definition (N)));
6482                return Null_Exclusion_Present (Access_Definition (N));
6483             end if;
6484
6485          when N_Discriminant_Specification =>
6486             if Nkind (Discriminant_Type (N)) = N_Access_Definition then
6487                return Null_Exclusion_Present (Discriminant_Type (N));
6488             else
6489                return Null_Exclusion_Present (N);
6490             end if;
6491
6492          when N_Object_Declaration =>
6493             if Nkind (Object_Definition (N)) = N_Access_Definition then
6494                return Null_Exclusion_Present (Object_Definition (N));
6495             else
6496                return Null_Exclusion_Present (N);
6497             end if;
6498
6499          when N_Parameter_Specification =>
6500             if Nkind (Parameter_Type (N)) = N_Access_Definition then
6501                return Null_Exclusion_Present (Parameter_Type (N));
6502             else
6503                return Null_Exclusion_Present (N);
6504             end if;
6505
6506          when others =>
6507             return False;
6508
6509       end case;
6510    end Has_Null_Exclusion;
6511
6512    ------------------------
6513    -- Has_Null_Extension --
6514    ------------------------
6515
6516    function Has_Null_Extension (T : Entity_Id) return Boolean is
6517       B     : constant Entity_Id := Base_Type (T);
6518       Comps : Node_Id;
6519       Ext   : Node_Id;
6520
6521    begin
6522       if Nkind (Parent (B)) = N_Full_Type_Declaration
6523         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
6524       then
6525          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
6526
6527          if Present (Ext) then
6528             if Null_Present (Ext) then
6529                return True;
6530             else
6531                Comps := Component_List (Ext);
6532
6533                --  The null component list is rewritten during analysis to
6534                --  include the parent component. Any other component indicates
6535                --  that the extension was not originally null.
6536
6537                return Null_Present (Comps)
6538                  or else No (Next (First (Component_Items (Comps))));
6539             end if;
6540          else
6541             return False;
6542          end if;
6543
6544       else
6545          return False;
6546       end if;
6547    end Has_Null_Extension;
6548
6549    -------------------------------
6550    -- Has_Overriding_Initialize --
6551    -------------------------------
6552
6553    function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
6554       BT   : constant Entity_Id := Base_Type (T);
6555       P    : Elmt_Id;
6556
6557    begin
6558       if Is_Controlled (BT) then
6559          if Is_RTU (Scope (BT), Ada_Finalization) then
6560             return False;
6561
6562          elsif Present (Primitive_Operations (BT)) then
6563             P := First_Elmt (Primitive_Operations (BT));
6564             while Present (P) loop
6565                declare
6566                   Init : constant Entity_Id := Node (P);
6567                   Formal : constant Entity_Id := First_Formal (Init);
6568                begin
6569                   if Ekind (Init) = E_Procedure
6570                        and then Chars (Init) = Name_Initialize
6571                        and then Comes_From_Source (Init)
6572                        and then Present (Formal)
6573                        and then Etype (Formal) = BT
6574                        and then No (Next_Formal (Formal))
6575                        and then (Ada_Version < Ada_2012
6576                                    or else not Null_Present (Parent (Init)))
6577                   then
6578                      return True;
6579                   end if;
6580                end;
6581
6582                Next_Elmt (P);
6583             end loop;
6584          end if;
6585
6586          --  Here if type itself does not have a non-null Initialize operation:
6587          --  check immediate ancestor.
6588
6589          if Is_Derived_Type (BT)
6590            and then Has_Overriding_Initialize (Etype (BT))
6591          then
6592             return True;
6593          end if;
6594       end if;
6595
6596       return False;
6597    end Has_Overriding_Initialize;
6598
6599    --------------------------------------
6600    -- Has_Preelaborable_Initialization --
6601    --------------------------------------
6602
6603    function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
6604       Has_PE : Boolean;
6605
6606       procedure Check_Components (E : Entity_Id);
6607       --  Check component/discriminant chain, sets Has_PE False if a component
6608       --  or discriminant does not meet the preelaborable initialization rules.
6609
6610       ----------------------
6611       -- Check_Components --
6612       ----------------------
6613
6614       procedure Check_Components (E : Entity_Id) is
6615          Ent : Entity_Id;
6616          Exp : Node_Id;
6617
6618          function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
6619          --  Returns True if and only if the expression denoted by N does not
6620          --  violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
6621
6622          ---------------------------------
6623          -- Is_Preelaborable_Expression --
6624          ---------------------------------
6625
6626          function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
6627             Exp           : Node_Id;
6628             Assn          : Node_Id;
6629             Choice        : Node_Id;
6630             Comp_Type     : Entity_Id;
6631             Is_Array_Aggr : Boolean;
6632
6633          begin
6634             if Is_Static_Expression (N) then
6635                return True;
6636
6637             elsif Nkind (N) = N_Null then
6638                return True;
6639
6640             --  Attributes are allowed in general, even if their prefix is a
6641             --  formal type. (It seems that certain attributes known not to be
6642             --  static might not be allowed, but there are no rules to prevent
6643             --  them.)
6644
6645             elsif Nkind (N) = N_Attribute_Reference then
6646                return True;
6647
6648             --  The name of a discriminant evaluated within its parent type is
6649             --  defined to be preelaborable (10.2.1(8)). Note that we test for
6650             --  names that denote discriminals as well as discriminants to
6651             --  catch references occurring within init procs.
6652
6653             elsif Is_Entity_Name (N)
6654               and then
6655                 (Ekind (Entity (N)) = E_Discriminant
6656                   or else
6657                     ((Ekind (Entity (N)) = E_Constant
6658                        or else Ekind (Entity (N)) = E_In_Parameter)
6659                      and then Present (Discriminal_Link (Entity (N)))))
6660             then
6661                return True;
6662
6663             elsif Nkind (N) = N_Qualified_Expression then
6664                return Is_Preelaborable_Expression (Expression (N));
6665
6666             --  For aggregates we have to check that each of the associations
6667             --  is preelaborable.
6668
6669             elsif Nkind (N) = N_Aggregate
6670               or else Nkind (N) = N_Extension_Aggregate
6671             then
6672                Is_Array_Aggr := Is_Array_Type (Etype (N));
6673
6674                if Is_Array_Aggr then
6675                   Comp_Type := Component_Type (Etype (N));
6676                end if;
6677
6678                --  Check the ancestor part of extension aggregates, which must
6679                --  be either the name of a type that has preelaborable init or
6680                --  an expression that is preelaborable.
6681
6682                if Nkind (N) = N_Extension_Aggregate then
6683                   declare
6684                      Anc_Part : constant Node_Id := Ancestor_Part (N);
6685
6686                   begin
6687                      if Is_Entity_Name (Anc_Part)
6688                        and then Is_Type (Entity (Anc_Part))
6689                      then
6690                         if not Has_Preelaborable_Initialization
6691                                  (Entity (Anc_Part))
6692                         then
6693                            return False;
6694                         end if;
6695
6696                      elsif not Is_Preelaborable_Expression (Anc_Part) then
6697                         return False;
6698                      end if;
6699                   end;
6700                end if;
6701
6702                --  Check positional associations
6703
6704                Exp := First (Expressions (N));
6705                while Present (Exp) loop
6706                   if not Is_Preelaborable_Expression (Exp) then
6707                      return False;
6708                   end if;
6709
6710                   Next (Exp);
6711                end loop;
6712
6713                --  Check named associations
6714
6715                Assn := First (Component_Associations (N));
6716                while Present (Assn) loop
6717                   Choice := First (Choices (Assn));
6718                   while Present (Choice) loop
6719                      if Is_Array_Aggr then
6720                         if Nkind (Choice) = N_Others_Choice then
6721                            null;
6722
6723                         elsif Nkind (Choice) = N_Range then
6724                            if not Is_Static_Range (Choice) then
6725                               return False;
6726                            end if;
6727
6728                         elsif not Is_Static_Expression (Choice) then
6729                            return False;
6730                         end if;
6731
6732                      else
6733                         Comp_Type := Etype (Choice);
6734                      end if;
6735
6736                      Next (Choice);
6737                   end loop;
6738
6739                   --  If the association has a <> at this point, then we have
6740                   --  to check whether the component's type has preelaborable
6741                   --  initialization. Note that this only occurs when the
6742                   --  association's corresponding component does not have a
6743                   --  default expression, the latter case having already been
6744                   --  expanded as an expression for the association.
6745
6746                   if Box_Present (Assn) then
6747                      if not Has_Preelaborable_Initialization (Comp_Type) then
6748                         return False;
6749                      end if;
6750
6751                   --  In the expression case we check whether the expression
6752                   --  is preelaborable.
6753
6754                   elsif
6755                     not Is_Preelaborable_Expression (Expression (Assn))
6756                   then
6757                      return False;
6758                   end if;
6759
6760                   Next (Assn);
6761                end loop;
6762
6763                --  If we get here then aggregate as a whole is preelaborable
6764
6765                return True;
6766
6767             --  All other cases are not preelaborable
6768
6769             else
6770                return False;
6771             end if;
6772          end Is_Preelaborable_Expression;
6773
6774       --  Start of processing for Check_Components
6775
6776       begin
6777          --  Loop through entities of record or protected type
6778
6779          Ent := E;
6780          while Present (Ent) loop
6781
6782             --  We are interested only in components and discriminants
6783
6784             Exp := Empty;
6785
6786             case Ekind (Ent) is
6787                when E_Component =>
6788
6789                   --  Get default expression if any. If there is no declaration
6790                   --  node, it means we have an internal entity. The parent and
6791                   --  tag fields are examples of such entities. For such cases,
6792                   --  we just test the type of the entity.
6793
6794                   if Present (Declaration_Node (Ent)) then
6795                      Exp := Expression (Declaration_Node (Ent));
6796                   end if;
6797
6798                when E_Discriminant =>
6799
6800                   --  Note: for a renamed discriminant, the Declaration_Node
6801                   --  may point to the one from the ancestor, and have a
6802                   --  different expression, so use the proper attribute to
6803                   --  retrieve the expression from the derived constraint.
6804
6805                   Exp := Discriminant_Default_Value (Ent);
6806
6807                when others =>
6808                   goto Check_Next_Entity;
6809             end case;
6810
6811             --  A component has PI if it has no default expression and the
6812             --  component type has PI.
6813
6814             if No (Exp) then
6815                if not Has_Preelaborable_Initialization (Etype (Ent)) then
6816                   Has_PE := False;
6817                   exit;
6818                end if;
6819
6820             --  Require the default expression to be preelaborable
6821
6822             elsif not Is_Preelaborable_Expression (Exp) then
6823                Has_PE := False;
6824                exit;
6825             end if;
6826
6827          <<Check_Next_Entity>>
6828             Next_Entity (Ent);
6829          end loop;
6830       end Check_Components;
6831
6832    --  Start of processing for Has_Preelaborable_Initialization
6833
6834    begin
6835       --  Immediate return if already marked as known preelaborable init. This
6836       --  covers types for which this function has already been called once
6837       --  and returned True (in which case the result is cached), and also
6838       --  types to which a pragma Preelaborable_Initialization applies.
6839
6840       if Known_To_Have_Preelab_Init (E) then
6841          return True;
6842       end if;
6843
6844       --  If the type is a subtype representing a generic actual type, then
6845       --  test whether its base type has preelaborable initialization since
6846       --  the subtype representing the actual does not inherit this attribute
6847       --  from the actual or formal. (but maybe it should???)
6848
6849       if Is_Generic_Actual_Type (E) then
6850          return Has_Preelaborable_Initialization (Base_Type (E));
6851       end if;
6852
6853       --  All elementary types have preelaborable initialization
6854
6855       if Is_Elementary_Type (E) then
6856          Has_PE := True;
6857
6858       --  Array types have PI if the component type has PI
6859
6860       elsif Is_Array_Type (E) then
6861          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
6862
6863       --  A derived type has preelaborable initialization if its parent type
6864       --  has preelaborable initialization and (in the case of a derived record
6865       --  extension) if the non-inherited components all have preelaborable
6866       --  initialization. However, a user-defined controlled type with an
6867       --  overriding Initialize procedure does not have preelaborable
6868       --  initialization.
6869
6870       elsif Is_Derived_Type (E) then
6871
6872          --  If the derived type is a private extension then it doesn't have
6873          --  preelaborable initialization.
6874
6875          if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
6876             return False;
6877          end if;
6878
6879          --  First check whether ancestor type has preelaborable initialization
6880
6881          Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
6882
6883          --  If OK, check extension components (if any)
6884
6885          if Has_PE and then Is_Record_Type (E) then
6886             Check_Components (First_Entity (E));
6887          end if;
6888
6889          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
6890          --  with a user defined Initialize procedure does not have PI.
6891
6892          if Has_PE
6893            and then Is_Controlled (E)
6894            and then Has_Overriding_Initialize (E)
6895          then
6896             Has_PE := False;
6897          end if;
6898
6899       --  Private types not derived from a type having preelaborable init and
6900       --  that are not marked with pragma Preelaborable_Initialization do not
6901       --  have preelaborable initialization.
6902
6903       elsif Is_Private_Type (E) then
6904          return False;
6905
6906       --  Record type has PI if it is non private and all components have PI
6907
6908       elsif Is_Record_Type (E) then
6909          Has_PE := True;
6910          Check_Components (First_Entity (E));
6911
6912       --  Protected types must not have entries, and components must meet
6913       --  same set of rules as for record components.
6914
6915       elsif Is_Protected_Type (E) then
6916          if Has_Entries (E) then
6917             Has_PE := False;
6918          else
6919             Has_PE := True;
6920             Check_Components (First_Entity (E));
6921             Check_Components (First_Private_Entity (E));
6922          end if;
6923
6924       --  Type System.Address always has preelaborable initialization
6925
6926       elsif Is_RTE (E, RE_Address) then
6927          Has_PE := True;
6928
6929       --  In all other cases, type does not have preelaborable initialization
6930
6931       else
6932          return False;
6933       end if;
6934
6935       --  If type has preelaborable initialization, cache result
6936
6937       if Has_PE then
6938          Set_Known_To_Have_Preelab_Init (E);
6939       end if;
6940
6941       return Has_PE;
6942    end Has_Preelaborable_Initialization;
6943
6944    ---------------------------
6945    -- Has_Private_Component --
6946    ---------------------------
6947
6948    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
6949       Btype     : Entity_Id := Base_Type (Type_Id);
6950       Component : Entity_Id;
6951
6952    begin
6953       if Error_Posted (Type_Id)
6954         or else Error_Posted (Btype)
6955       then
6956          return False;
6957       end if;
6958
6959       if Is_Class_Wide_Type (Btype) then
6960          Btype := Root_Type (Btype);
6961       end if;
6962
6963       if Is_Private_Type (Btype) then
6964          declare
6965             UT : constant Entity_Id := Underlying_Type (Btype);
6966          begin
6967             if No (UT) then
6968                if No (Full_View (Btype)) then
6969                   return not Is_Generic_Type (Btype)
6970                     and then not Is_Generic_Type (Root_Type (Btype));
6971                else
6972                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
6973                end if;
6974             else
6975                return not Is_Frozen (UT) and then Has_Private_Component (UT);
6976             end if;
6977          end;
6978
6979       elsif Is_Array_Type (Btype) then
6980          return Has_Private_Component (Component_Type (Btype));
6981
6982       elsif Is_Record_Type (Btype) then
6983          Component := First_Component (Btype);
6984          while Present (Component) loop
6985             if Has_Private_Component (Etype (Component)) then
6986                return True;
6987             end if;
6988
6989             Next_Component (Component);
6990          end loop;
6991
6992          return False;
6993
6994       elsif Is_Protected_Type (Btype)
6995         and then Present (Corresponding_Record_Type (Btype))
6996       then
6997          return Has_Private_Component (Corresponding_Record_Type (Btype));
6998
6999       else
7000          return False;
7001       end if;
7002    end Has_Private_Component;
7003
7004    ----------------------
7005    -- Has_Signed_Zeros --
7006    ----------------------
7007
7008    function Has_Signed_Zeros (E : Entity_Id) return Boolean is
7009    begin
7010       return Is_Floating_Point_Type (E)
7011         and then Signed_Zeros_On_Target
7012         and then not Vax_Float (E);
7013    end Has_Signed_Zeros;
7014
7015    -----------------------------
7016    -- Has_Static_Array_Bounds --
7017    -----------------------------
7018
7019    function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
7020       Ndims : constant Nat := Number_Dimensions (Typ);
7021
7022       Index : Node_Id;
7023       Low   : Node_Id;
7024       High  : Node_Id;
7025
7026    begin
7027       --  Unconstrained types do not have static bounds
7028
7029       if not Is_Constrained (Typ) then
7030          return False;
7031       end if;
7032
7033       --  First treat string literals specially, as the lower bound and length
7034       --  of string literals are not stored like those of arrays.
7035
7036       --  A string literal always has static bounds
7037
7038       if Ekind (Typ) = E_String_Literal_Subtype then
7039          return True;
7040       end if;
7041
7042       --  Treat all dimensions in turn
7043
7044       Index := First_Index (Typ);
7045       for Indx in 1 .. Ndims loop
7046
7047          --  In case of an erroneous index which is not a discrete type, return
7048          --  that the type is not static.
7049
7050          if not Is_Discrete_Type (Etype (Index))
7051            or else Etype (Index) = Any_Type
7052          then
7053             return False;
7054          end if;
7055
7056          Get_Index_Bounds (Index, Low, High);
7057
7058          if Error_Posted (Low) or else Error_Posted (High) then
7059             return False;
7060          end if;
7061
7062          if Is_OK_Static_Expression (Low)
7063               and then
7064             Is_OK_Static_Expression (High)
7065          then
7066             null;
7067          else
7068             return False;
7069          end if;
7070
7071          Next (Index);
7072       end loop;
7073
7074       --  If we fall through the loop, all indexes matched
7075
7076       return True;
7077    end Has_Static_Array_Bounds;
7078
7079    ----------------
7080    -- Has_Stream --
7081    ----------------
7082
7083    function Has_Stream (T : Entity_Id) return Boolean is
7084       E : Entity_Id;
7085
7086    begin
7087       if No (T) then
7088          return False;
7089
7090       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
7091          return True;
7092
7093       elsif Is_Array_Type (T) then
7094          return Has_Stream (Component_Type (T));
7095
7096       elsif Is_Record_Type (T) then
7097          E := First_Component (T);
7098          while Present (E) loop
7099             if Has_Stream (Etype (E)) then
7100                return True;
7101             else
7102                Next_Component (E);
7103             end if;
7104          end loop;
7105
7106          return False;
7107
7108       elsif Is_Private_Type (T) then
7109          return Has_Stream (Underlying_Type (T));
7110
7111       else
7112          return False;
7113       end if;
7114    end Has_Stream;
7115
7116    ----------------
7117    -- Has_Suffix --
7118    ----------------
7119
7120    function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
7121    begin
7122       Get_Name_String (Chars (E));
7123       return Name_Buffer (Name_Len) = Suffix;
7124    end Has_Suffix;
7125
7126    ----------------
7127    -- Add_Suffix --
7128    ----------------
7129
7130    function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
7131    begin
7132       Get_Name_String (Chars (E));
7133       Add_Char_To_Name_Buffer (Suffix);
7134       return Name_Find;
7135    end Add_Suffix;
7136
7137    -------------------
7138    -- Remove_Suffix --
7139    -------------------
7140
7141    function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
7142    begin
7143       pragma Assert (Has_Suffix (E, Suffix));
7144       Get_Name_String (Chars (E));
7145       Name_Len := Name_Len - 1;
7146       return Name_Find;
7147    end Remove_Suffix;
7148
7149    --------------------------
7150    -- Has_Tagged_Component --
7151    --------------------------
7152
7153    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
7154       Comp : Entity_Id;
7155
7156    begin
7157       if Is_Private_Type (Typ)
7158         and then Present (Underlying_Type (Typ))
7159       then
7160          return Has_Tagged_Component (Underlying_Type (Typ));
7161
7162       elsif Is_Array_Type (Typ) then
7163          return Has_Tagged_Component (Component_Type (Typ));
7164
7165       elsif Is_Tagged_Type (Typ) then
7166          return True;
7167
7168       elsif Is_Record_Type (Typ) then
7169          Comp := First_Component (Typ);
7170          while Present (Comp) loop
7171             if Has_Tagged_Component (Etype (Comp)) then
7172                return True;
7173             end if;
7174
7175             Next_Component (Comp);
7176          end loop;
7177
7178          return False;
7179
7180       else
7181          return False;
7182       end if;
7183    end Has_Tagged_Component;
7184
7185    -------------------------
7186    -- Implementation_Kind --
7187    -------------------------
7188
7189    function Implementation_Kind (Subp : Entity_Id) return Name_Id is
7190       Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
7191       Arg       : Node_Id;
7192    begin
7193       pragma Assert (Present (Impl_Prag));
7194       Arg := Last (Pragma_Argument_Associations (Impl_Prag));
7195       return Chars (Get_Pragma_Arg (Arg));
7196    end Implementation_Kind;
7197
7198    --------------------------
7199    -- Implements_Interface --
7200    --------------------------
7201
7202    function Implements_Interface
7203      (Typ_Ent         : Entity_Id;
7204       Iface_Ent       : Entity_Id;
7205       Exclude_Parents : Boolean := False) return Boolean
7206    is
7207       Ifaces_List : Elist_Id;
7208       Elmt        : Elmt_Id;
7209       Iface       : Entity_Id := Base_Type (Iface_Ent);
7210       Typ         : Entity_Id := Base_Type (Typ_Ent);
7211
7212    begin
7213       if Is_Class_Wide_Type (Typ) then
7214          Typ := Root_Type (Typ);
7215       end if;
7216
7217       if not Has_Interfaces (Typ) then
7218          return False;
7219       end if;
7220
7221       if Is_Class_Wide_Type (Iface) then
7222          Iface := Root_Type (Iface);
7223       end if;
7224
7225       Collect_Interfaces (Typ, Ifaces_List);
7226
7227       Elmt := First_Elmt (Ifaces_List);
7228       while Present (Elmt) loop
7229          if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
7230            and then Exclude_Parents
7231          then
7232             null;
7233
7234          elsif Node (Elmt) = Iface then
7235             return True;
7236          end if;
7237
7238          Next_Elmt (Elmt);
7239       end loop;
7240
7241       return False;
7242    end Implements_Interface;
7243
7244    -----------------
7245    -- In_Instance --
7246    -----------------
7247
7248    function In_Instance return Boolean is
7249       Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
7250       S         : Entity_Id;
7251
7252    begin
7253       S := Current_Scope;
7254       while Present (S)
7255         and then S /= Standard_Standard
7256       loop
7257          if (Ekind (S) = E_Function
7258               or else Ekind (S) = E_Package
7259               or else Ekind (S) = E_Procedure)
7260            and then Is_Generic_Instance (S)
7261          then
7262             --  A child instance is always compiled in the context of a parent
7263             --  instance. Nevertheless, the actuals are not analyzed in an
7264             --  instance context. We detect this case by examining the current
7265             --  compilation unit, which must be a child instance, and checking
7266             --  that it is not currently on the scope stack.
7267
7268             if Is_Child_Unit (Curr_Unit)
7269               and then
7270                 Nkind (Unit (Cunit (Current_Sem_Unit)))
7271                   = N_Package_Instantiation
7272               and then not In_Open_Scopes (Curr_Unit)
7273             then
7274                return False;
7275             else
7276                return True;
7277             end if;
7278          end if;
7279
7280          S := Scope (S);
7281       end loop;
7282
7283       return False;
7284    end In_Instance;
7285
7286    ----------------------
7287    -- In_Instance_Body --
7288    ----------------------
7289
7290    function In_Instance_Body return Boolean is
7291       S : Entity_Id;
7292
7293    begin
7294       S := Current_Scope;
7295       while Present (S)
7296         and then S /= Standard_Standard
7297       loop
7298          if (Ekind (S) = E_Function
7299               or else Ekind (S) = E_Procedure)
7300            and then Is_Generic_Instance (S)
7301          then
7302             return True;
7303
7304          elsif Ekind (S) = E_Package
7305            and then In_Package_Body (S)
7306            and then Is_Generic_Instance (S)
7307          then
7308             return True;
7309          end if;
7310
7311          S := Scope (S);
7312       end loop;
7313
7314       return False;
7315    end In_Instance_Body;
7316
7317    -----------------------------
7318    -- In_Instance_Not_Visible --
7319    -----------------------------
7320
7321    function In_Instance_Not_Visible return Boolean is
7322       S : Entity_Id;
7323
7324    begin
7325       S := Current_Scope;
7326       while Present (S)
7327         and then S /= Standard_Standard
7328       loop
7329          if (Ekind (S) = E_Function
7330               or else Ekind (S) = E_Procedure)
7331            and then Is_Generic_Instance (S)
7332          then
7333             return True;
7334
7335          elsif Ekind (S) = E_Package
7336            and then (In_Package_Body (S) or else In_Private_Part (S))
7337            and then Is_Generic_Instance (S)
7338          then
7339             return True;
7340          end if;
7341
7342          S := Scope (S);
7343       end loop;
7344
7345       return False;
7346    end In_Instance_Not_Visible;
7347
7348    ------------------------------
7349    -- In_Instance_Visible_Part --
7350    ------------------------------
7351
7352    function In_Instance_Visible_Part return Boolean is
7353       S : Entity_Id;
7354
7355    begin
7356       S := Current_Scope;
7357       while Present (S)
7358         and then S /= Standard_Standard
7359       loop
7360          if Ekind (S) = E_Package
7361            and then Is_Generic_Instance (S)
7362            and then not In_Package_Body (S)
7363            and then not In_Private_Part (S)
7364          then
7365             return True;
7366          end if;
7367
7368          S := Scope (S);
7369       end loop;
7370
7371       return False;
7372    end In_Instance_Visible_Part;
7373
7374    ---------------------
7375    -- In_Package_Body --
7376    ---------------------
7377
7378    function In_Package_Body return Boolean is
7379       S : Entity_Id;
7380
7381    begin
7382       S := Current_Scope;
7383       while Present (S)
7384         and then S /= Standard_Standard
7385       loop
7386          if Ekind (S) = E_Package
7387            and then In_Package_Body (S)
7388          then
7389             return True;
7390          else
7391             S := Scope (S);
7392          end if;
7393       end loop;
7394
7395       return False;
7396    end In_Package_Body;
7397
7398    --------------------------------
7399    -- In_Parameter_Specification --
7400    --------------------------------
7401
7402    function In_Parameter_Specification (N : Node_Id) return Boolean is
7403       PN : Node_Id;
7404
7405    begin
7406       PN := Parent (N);
7407       while Present (PN) loop
7408          if Nkind (PN) = N_Parameter_Specification then
7409             return True;
7410          end if;
7411
7412          PN := Parent (PN);
7413       end loop;
7414
7415       return False;
7416    end In_Parameter_Specification;
7417
7418    -------------------------------------
7419    -- In_Reverse_Storage_Order_Object --
7420    -------------------------------------
7421
7422    function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
7423       Pref : Node_Id;
7424       Btyp : Entity_Id := Empty;
7425
7426    begin
7427       --  Climb up indexed components
7428
7429       Pref := N;
7430       loop
7431          case Nkind (Pref) is
7432             when N_Selected_Component =>
7433                Pref := Prefix (Pref);
7434                exit;
7435
7436             when N_Indexed_Component =>
7437                Pref := Prefix (Pref);
7438
7439             when others =>
7440                Pref := Empty;
7441                exit;
7442          end case;
7443       end loop;
7444
7445       if Present (Pref) then
7446          Btyp := Base_Type (Etype (Pref));
7447       end if;
7448
7449       return
7450         Present (Btyp)
7451           and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
7452           and then Reverse_Storage_Order (Btyp);
7453    end In_Reverse_Storage_Order_Object;
7454
7455    --------------------------------------
7456    -- In_Subprogram_Or_Concurrent_Unit --
7457    --------------------------------------
7458
7459    function In_Subprogram_Or_Concurrent_Unit return Boolean is
7460       E : Entity_Id;
7461       K : Entity_Kind;
7462
7463    begin
7464       --  Use scope chain to check successively outer scopes
7465
7466       E := Current_Scope;
7467       loop
7468          K := Ekind (E);
7469
7470          if K in Subprogram_Kind
7471            or else K in Concurrent_Kind
7472            or else K in Generic_Subprogram_Kind
7473          then
7474             return True;
7475
7476          elsif E = Standard_Standard then
7477             return False;
7478          end if;
7479
7480          E := Scope (E);
7481       end loop;
7482    end In_Subprogram_Or_Concurrent_Unit;
7483
7484    ---------------------
7485    -- In_Visible_Part --
7486    ---------------------
7487
7488    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
7489    begin
7490       return
7491         Is_Package_Or_Generic_Package (Scope_Id)
7492           and then In_Open_Scopes (Scope_Id)
7493           and then not In_Package_Body (Scope_Id)
7494           and then not In_Private_Part (Scope_Id);
7495    end In_Visible_Part;
7496
7497    --------------------------------
7498    -- Incomplete_Or_Private_View --
7499    --------------------------------
7500
7501    function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
7502       function Inspect_Decls
7503         (Decls : List_Id;
7504          Taft  : Boolean := False) return Entity_Id;
7505       --  Check whether a declarative region contains the incomplete or private
7506       --  view of Typ.
7507
7508       -------------------
7509       -- Inspect_Decls --
7510       -------------------
7511
7512       function Inspect_Decls
7513         (Decls : List_Id;
7514          Taft  : Boolean := False) return Entity_Id
7515       is
7516          Decl  : Node_Id;
7517          Match : Node_Id;
7518
7519       begin
7520          Decl := First (Decls);
7521          while Present (Decl) loop
7522             Match := Empty;
7523
7524             if Taft then
7525                if Nkind (Decl) = N_Incomplete_Type_Declaration then
7526                   Match := Defining_Identifier (Decl);
7527                end if;
7528
7529             else
7530                if Nkind_In (Decl, N_Private_Extension_Declaration,
7531                                   N_Private_Type_Declaration)
7532                then
7533                   Match := Defining_Identifier (Decl);
7534                end if;
7535             end if;
7536
7537             if Present (Match)
7538               and then Present (Full_View (Match))
7539               and then Full_View (Match) = Typ
7540             then
7541                return Match;
7542             end if;
7543
7544             Next (Decl);
7545          end loop;
7546
7547          return Empty;
7548       end Inspect_Decls;
7549
7550       --  Local variables
7551
7552       Prev : Entity_Id;
7553
7554    --  Start of processing for Incomplete_Or_Partial_View
7555
7556    begin
7557       --  Incomplete type case
7558
7559       Prev := Current_Entity_In_Scope (Typ);
7560
7561       if Present (Prev)
7562         and then Is_Incomplete_Type (Prev)
7563         and then Present (Full_View (Prev))
7564         and then Full_View (Prev) = Typ
7565       then
7566          return Prev;
7567       end if;
7568
7569       --  Private or Taft amendment type case
7570
7571       declare
7572          Pkg      : constant Entity_Id := Scope (Typ);
7573          Pkg_Decl : Node_Id := Pkg;
7574
7575       begin
7576          if Ekind (Pkg) = E_Package then
7577             while Nkind (Pkg_Decl) /= N_Package_Specification loop
7578                Pkg_Decl := Parent (Pkg_Decl);
7579             end loop;
7580
7581             --  It is knows that Typ has a private view, look for it in the
7582             --  visible declarations of the enclosing scope. A special case
7583             --  of this is when the two views have been exchanged - the full
7584             --  appears earlier than the private.
7585
7586             if Has_Private_Declaration (Typ) then
7587                Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
7588
7589                --  Exchanged view case, look in the private declarations
7590
7591                if No (Prev) then
7592                   Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
7593                end if;
7594
7595                return Prev;
7596
7597             --  Otherwise if this is the package body, then Typ is a potential
7598             --  Taft amendment type. The incomplete view should be located in
7599             --  the private declarations of the enclosing scope.
7600
7601             elsif In_Package_Body (Pkg) then
7602                return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
7603             end if;
7604          end if;
7605       end;
7606
7607       --  The type has no incomplete or private view
7608
7609       return Empty;
7610    end Incomplete_Or_Private_View;
7611
7612    ---------------------------------
7613    -- Insert_Explicit_Dereference --
7614    ---------------------------------
7615
7616    procedure Insert_Explicit_Dereference (N : Node_Id) is
7617       New_Prefix : constant Node_Id := Relocate_Node (N);
7618       Ent        : Entity_Id := Empty;
7619       Pref       : Node_Id;
7620       I          : Interp_Index;
7621       It         : Interp;
7622       T          : Entity_Id;
7623
7624    begin
7625       Save_Interps (N, New_Prefix);
7626
7627       Rewrite (N,
7628         Make_Explicit_Dereference (Sloc (Parent (N)),
7629           Prefix => New_Prefix));
7630
7631       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
7632
7633       if Is_Overloaded (New_Prefix) then
7634
7635          --  The dereference is also overloaded, and its interpretations are
7636          --  the designated types of the interpretations of the original node.
7637
7638          Set_Etype (N, Any_Type);
7639
7640          Get_First_Interp (New_Prefix, I, It);
7641          while Present (It.Nam) loop
7642             T := It.Typ;
7643
7644             if Is_Access_Type (T) then
7645                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
7646             end if;
7647
7648             Get_Next_Interp (I, It);
7649          end loop;
7650
7651          End_Interp_List;
7652
7653       else
7654          --  Prefix is unambiguous: mark the original prefix (which might
7655          --  Come_From_Source) as a reference, since the new (relocated) one
7656          --  won't be taken into account.
7657
7658          if Is_Entity_Name (New_Prefix) then
7659             Ent := Entity (New_Prefix);
7660             Pref := New_Prefix;
7661
7662          --  For a retrieval of a subcomponent of some composite object,
7663          --  retrieve the ultimate entity if there is one.
7664
7665          elsif Nkind (New_Prefix) = N_Selected_Component
7666            or else Nkind (New_Prefix) = N_Indexed_Component
7667          then
7668             Pref := Prefix (New_Prefix);
7669             while Present (Pref)
7670               and then
7671                 (Nkind (Pref) = N_Selected_Component
7672                   or else Nkind (Pref) = N_Indexed_Component)
7673             loop
7674                Pref := Prefix (Pref);
7675             end loop;
7676
7677             if Present (Pref) and then Is_Entity_Name (Pref) then
7678                Ent := Entity (Pref);
7679             end if;
7680          end if;
7681
7682          --  Place the reference on the entity node
7683
7684          if Present (Ent) then
7685             Generate_Reference (Ent, Pref);
7686          end if;
7687       end if;
7688    end Insert_Explicit_Dereference;
7689
7690    ------------------------------------------
7691    -- Inspect_Deferred_Constant_Completion --
7692    ------------------------------------------
7693
7694    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
7695       Decl   : Node_Id;
7696
7697    begin
7698       Decl := First (Decls);
7699       while Present (Decl) loop
7700
7701          --  Deferred constant signature
7702
7703          if Nkind (Decl) = N_Object_Declaration
7704            and then Constant_Present (Decl)
7705            and then No (Expression (Decl))
7706
7707             --  No need to check internally generated constants
7708
7709            and then Comes_From_Source (Decl)
7710
7711             --  The constant is not completed. A full object declaration or a
7712             --  pragma Import complete a deferred constant.
7713
7714            and then not Has_Completion (Defining_Identifier (Decl))
7715          then
7716             Error_Msg_N
7717               ("constant declaration requires initialization expression",
7718               Defining_Identifier (Decl));
7719          end if;
7720
7721          Decl := Next (Decl);
7722       end loop;
7723    end Inspect_Deferred_Constant_Completion;
7724
7725    -----------------------------
7726    -- Is_Actual_Out_Parameter --
7727    -----------------------------
7728
7729    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
7730       Formal : Entity_Id;
7731       Call   : Node_Id;
7732    begin
7733       Find_Actual (N, Formal, Call);
7734       return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
7735    end Is_Actual_Out_Parameter;
7736
7737    -------------------------
7738    -- Is_Actual_Parameter --
7739    -------------------------
7740
7741    function Is_Actual_Parameter (N : Node_Id) return Boolean is
7742       PK : constant Node_Kind := Nkind (Parent (N));
7743
7744    begin
7745       case PK is
7746          when N_Parameter_Association =>
7747             return N = Explicit_Actual_Parameter (Parent (N));
7748
7749          when N_Subprogram_Call =>
7750             return Is_List_Member (N)
7751               and then
7752                 List_Containing (N) = Parameter_Associations (Parent (N));
7753
7754          when others =>
7755             return False;
7756       end case;
7757    end Is_Actual_Parameter;
7758
7759    --------------------------------
7760    -- Is_Actual_Tagged_Parameter --
7761    --------------------------------
7762
7763    function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
7764       Formal : Entity_Id;
7765       Call   : Node_Id;
7766    begin
7767       Find_Actual (N, Formal, Call);
7768       return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
7769    end Is_Actual_Tagged_Parameter;
7770
7771    ---------------------
7772    -- Is_Aliased_View --
7773    ---------------------
7774
7775    function Is_Aliased_View (Obj : Node_Id) return Boolean is
7776       E : Entity_Id;
7777
7778    begin
7779       if Is_Entity_Name (Obj) then
7780          E := Entity (Obj);
7781
7782          return
7783            (Is_Object (E)
7784              and then
7785                (Is_Aliased (E)
7786                  or else (Present (Renamed_Object (E))
7787                            and then Is_Aliased_View (Renamed_Object (E)))))
7788
7789            or else ((Is_Formal (E)
7790                       or else Ekind (E) = E_Generic_In_Out_Parameter
7791                       or else Ekind (E) = E_Generic_In_Parameter)
7792                     and then Is_Tagged_Type (Etype (E)))
7793
7794            or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
7795
7796            --  Current instance of type, either directly or as rewritten
7797            --  reference to the current object.
7798
7799            or else (Is_Entity_Name (Original_Node (Obj))
7800                      and then Present (Entity (Original_Node (Obj)))
7801                      and then Is_Type (Entity (Original_Node (Obj))))
7802
7803            or else (Is_Type (E) and then E = Current_Scope)
7804
7805            or else (Is_Incomplete_Or_Private_Type (E)
7806                      and then Full_View (E) = Current_Scope)
7807
7808            --  Ada 2012 AI05-0053: the return object of an extended return
7809            --  statement is aliased if its type is immutably limited.
7810
7811            or else (Is_Return_Object (E)
7812                      and then Is_Immutably_Limited_Type (Etype (E)));
7813
7814       elsif Nkind (Obj) = N_Selected_Component then
7815          return Is_Aliased (Entity (Selector_Name (Obj)));
7816
7817       elsif Nkind (Obj) = N_Indexed_Component then
7818          return Has_Aliased_Components (Etype (Prefix (Obj)))
7819            or else
7820              (Is_Access_Type (Etype (Prefix (Obj)))
7821                and then Has_Aliased_Components
7822                           (Designated_Type (Etype (Prefix (Obj)))));
7823
7824       elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
7825          return Is_Tagged_Type (Etype (Obj))
7826            and then Is_Aliased_View (Expression (Obj));
7827
7828       elsif Nkind (Obj) = N_Explicit_Dereference then
7829          return Nkind (Original_Node (Obj)) /= N_Function_Call;
7830
7831       else
7832          return False;
7833       end if;
7834    end Is_Aliased_View;
7835
7836    -------------------------
7837    -- Is_Ancestor_Package --
7838    -------------------------
7839
7840    function Is_Ancestor_Package
7841      (E1 : Entity_Id;
7842       E2 : Entity_Id) return Boolean
7843    is
7844       Par : Entity_Id;
7845
7846    begin
7847       Par := E2;
7848       while Present (Par)
7849         and then Par /= Standard_Standard
7850       loop
7851          if Par = E1 then
7852             return True;
7853          end if;
7854
7855          Par := Scope (Par);
7856       end loop;
7857
7858       return False;
7859    end Is_Ancestor_Package;
7860
7861    ----------------------
7862    -- Is_Atomic_Object --
7863    ----------------------
7864
7865    function Is_Atomic_Object (N : Node_Id) return Boolean is
7866
7867       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
7868       --  Determines if given object has atomic components
7869
7870       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
7871       --  If prefix is an implicit dereference, examine designated type
7872
7873       ----------------------
7874       -- Is_Atomic_Prefix --
7875       ----------------------
7876
7877       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
7878       begin
7879          if Is_Access_Type (Etype (N)) then
7880             return
7881               Has_Atomic_Components (Designated_Type (Etype (N)));
7882          else
7883             return Object_Has_Atomic_Components (N);
7884          end if;
7885       end Is_Atomic_Prefix;
7886
7887       ----------------------------------
7888       -- Object_Has_Atomic_Components --
7889       ----------------------------------
7890
7891       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
7892       begin
7893          if Has_Atomic_Components (Etype (N))
7894            or else Is_Atomic (Etype (N))
7895          then
7896             return True;
7897
7898          elsif Is_Entity_Name (N)
7899            and then (Has_Atomic_Components (Entity (N))
7900                       or else Is_Atomic (Entity (N)))
7901          then
7902             return True;
7903
7904          elsif Nkind (N) = N_Selected_Component
7905            and then Is_Atomic (Entity (Selector_Name (N)))
7906          then
7907             return True;
7908
7909          elsif Nkind (N) = N_Indexed_Component
7910            or else Nkind (N) = N_Selected_Component
7911          then
7912             return Is_Atomic_Prefix (Prefix (N));
7913
7914          else
7915             return False;
7916          end if;
7917       end Object_Has_Atomic_Components;
7918
7919    --  Start of processing for Is_Atomic_Object
7920
7921    begin
7922       --  Predicate is not relevant to subprograms
7923
7924       if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
7925          return False;
7926
7927       elsif Is_Atomic (Etype (N))
7928         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
7929       then
7930          return True;
7931
7932       elsif Nkind (N) = N_Selected_Component
7933         and then Is_Atomic (Entity (Selector_Name (N)))
7934       then
7935          return True;
7936
7937       elsif Nkind (N) = N_Indexed_Component
7938         or else Nkind (N) = N_Selected_Component
7939       then
7940          return Is_Atomic_Prefix (Prefix (N));
7941
7942       else
7943          return False;
7944       end if;
7945    end Is_Atomic_Object;
7946
7947    ------------------------------------
7948    -- Is_Body_Or_Package_Declaration --
7949    ------------------------------------
7950
7951    function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
7952    begin
7953       return Nkind_In (N, N_Entry_Body,
7954                           N_Package_Body,
7955                           N_Package_Declaration,
7956                           N_Protected_Body,
7957                           N_Subprogram_Body,
7958                           N_Task_Body);
7959    end Is_Body_Or_Package_Declaration;
7960
7961    -----------------------
7962    -- Is_Bounded_String --
7963    -----------------------
7964
7965    function Is_Bounded_String (T : Entity_Id) return Boolean is
7966       Under : constant Entity_Id := Underlying_Type (Root_Type (T));
7967
7968    begin
7969       --  Check whether T is ultimately derived from Ada.Strings.Superbounded.
7970       --  Super_String, or one of the [Wide_]Wide_ versions. This will
7971       --  be True for all the Bounded_String types in instances of the
7972       --  Generic_Bounded_Length generics, and for types derived from those.
7973
7974       return Present (Under)
7975         and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
7976                   Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
7977                   Is_RTE (Root_Type (Under), RO_WW_Super_String));
7978    end Is_Bounded_String;
7979
7980    -----------------------------
7981    -- Is_Concurrent_Interface --
7982    -----------------------------
7983
7984    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
7985    begin
7986       return
7987         Is_Interface (T)
7988           and then
7989             (Is_Protected_Interface (T)
7990                or else Is_Synchronized_Interface (T)
7991                or else Is_Task_Interface (T));
7992    end Is_Concurrent_Interface;
7993
7994    -----------------------
7995    -- Is_Constant_Bound --
7996    -----------------------
7997
7998    function Is_Constant_Bound (Exp : Node_Id) return Boolean is
7999    begin
8000       if Compile_Time_Known_Value (Exp) then
8001          return True;
8002
8003       elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
8004          return Is_Constant_Object (Entity (Exp))
8005            or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
8006
8007       elsif Nkind (Exp) in N_Binary_Op then
8008          return Is_Constant_Bound (Left_Opnd (Exp))
8009            and then Is_Constant_Bound (Right_Opnd (Exp))
8010            and then Scope (Entity (Exp)) = Standard_Standard;
8011
8012       else
8013          return False;
8014       end if;
8015    end Is_Constant_Bound;
8016
8017    --------------------------------------
8018    -- Is_Controlling_Limited_Procedure --
8019    --------------------------------------
8020
8021    function Is_Controlling_Limited_Procedure
8022      (Proc_Nam : Entity_Id) return Boolean
8023    is
8024       Param_Typ : Entity_Id := Empty;
8025
8026    begin
8027       if Ekind (Proc_Nam) = E_Procedure
8028         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
8029       then
8030          Param_Typ := Etype (Parameter_Type (First (
8031                         Parameter_Specifications (Parent (Proc_Nam)))));
8032
8033       --  In this case where an Itype was created, the procedure call has been
8034       --  rewritten.
8035
8036       elsif Present (Associated_Node_For_Itype (Proc_Nam))
8037         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
8038         and then
8039           Present (Parameter_Associations
8040                      (Associated_Node_For_Itype (Proc_Nam)))
8041       then
8042          Param_Typ :=
8043            Etype (First (Parameter_Associations
8044                           (Associated_Node_For_Itype (Proc_Nam))));
8045       end if;
8046
8047       if Present (Param_Typ) then
8048          return
8049            Is_Interface (Param_Typ)
8050              and then Is_Limited_Record (Param_Typ);
8051       end if;
8052
8053       return False;
8054    end Is_Controlling_Limited_Procedure;
8055
8056    -----------------------------
8057    -- Is_CPP_Constructor_Call --
8058    -----------------------------
8059
8060    function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
8061    begin
8062       return Nkind (N) = N_Function_Call
8063         and then Is_CPP_Class (Etype (Etype (N)))
8064         and then Is_Constructor (Entity (Name (N)))
8065         and then Is_Imported (Entity (Name (N)));
8066    end Is_CPP_Constructor_Call;
8067
8068    -----------------
8069    -- Is_Delegate --
8070    -----------------
8071
8072    function Is_Delegate (T : Entity_Id) return Boolean is
8073       Desig_Type : Entity_Id;
8074
8075    begin
8076       if VM_Target /= CLI_Target then
8077          return False;
8078       end if;
8079
8080       --  Access-to-subprograms are delegates in CIL
8081
8082       if Ekind (T) = E_Access_Subprogram_Type then
8083          return True;
8084       end if;
8085
8086       if Ekind (T) not in Access_Kind then
8087
8088          --  A delegate is a managed pointer. If no designated type is defined
8089          --  it means that it's not a delegate.
8090
8091          return False;
8092       end if;
8093
8094       Desig_Type := Etype (Directly_Designated_Type (T));
8095
8096       if not Is_Tagged_Type (Desig_Type) then
8097          return False;
8098       end if;
8099
8100       --  Test if the type is inherited from [mscorlib]System.Delegate
8101
8102       while Etype (Desig_Type) /= Desig_Type loop
8103          if Chars (Scope (Desig_Type)) /= No_Name
8104            and then Is_Imported (Scope (Desig_Type))
8105            and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
8106          then
8107             return True;
8108          end if;
8109
8110          Desig_Type := Etype (Desig_Type);
8111       end loop;
8112
8113       return False;
8114    end Is_Delegate;
8115
8116    ----------------------------------------------
8117    -- Is_Dependent_Component_Of_Mutable_Object --
8118    ----------------------------------------------
8119
8120    function Is_Dependent_Component_Of_Mutable_Object
8121      (Object : Node_Id) return Boolean
8122    is
8123       P           : Node_Id;
8124       Prefix_Type : Entity_Id;
8125       P_Aliased   : Boolean := False;
8126       Comp        : Entity_Id;
8127
8128       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
8129       --  Returns True if and only if Comp is declared within a variant part
8130
8131       --------------------------------
8132       -- Is_Declared_Within_Variant --
8133       --------------------------------
8134
8135       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
8136          Comp_Decl : constant Node_Id   := Parent (Comp);
8137          Comp_List : constant Node_Id   := Parent (Comp_Decl);
8138       begin
8139          return Nkind (Parent (Comp_List)) = N_Variant;
8140       end Is_Declared_Within_Variant;
8141
8142    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
8143
8144    begin
8145       if Is_Variable (Object) then
8146
8147          if Nkind (Object) = N_Selected_Component then
8148             P := Prefix (Object);
8149             Prefix_Type := Etype (P);
8150
8151             if Is_Entity_Name (P) then
8152
8153                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
8154                   Prefix_Type := Base_Type (Prefix_Type);
8155                end if;
8156
8157                if Is_Aliased (Entity (P)) then
8158                   P_Aliased := True;
8159                end if;
8160
8161             --  A discriminant check on a selected component may be expanded
8162             --  into a dereference when removing side-effects. Recover the
8163             --  original node and its type, which may be unconstrained.
8164
8165             elsif Nkind (P) = N_Explicit_Dereference
8166               and then not (Comes_From_Source (P))
8167             then
8168                P := Original_Node (P);
8169                Prefix_Type := Etype (P);
8170
8171             else
8172                --  Check for prefix being an aliased component???
8173
8174                null;
8175
8176             end if;
8177
8178             --  A heap object is constrained by its initial value
8179
8180             --  Ada 2005 (AI-363): Always assume the object could be mutable in
8181             --  the dereferenced case, since the access value might denote an
8182             --  unconstrained aliased object, whereas in Ada 95 the designated
8183             --  object is guaranteed to be constrained. A worst-case assumption
8184             --  has to apply in Ada 2005 because we can't tell at compile time
8185             --  whether the object is "constrained by its initial value"
8186             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
8187             --  semantic rules -- these rules are acknowledged to need fixing).
8188
8189             if Ada_Version < Ada_2005 then
8190                if Is_Access_Type (Prefix_Type)
8191                  or else Nkind (P) = N_Explicit_Dereference
8192                then
8193                   return False;
8194                end if;
8195
8196             elsif Ada_Version >= Ada_2005 then
8197                if Is_Access_Type (Prefix_Type) then
8198
8199                   --  If the access type is pool-specific, and there is no
8200                   --  constrained partial view of the designated type, then the
8201                   --  designated object is known to be constrained.
8202
8203                   if Ekind (Prefix_Type) = E_Access_Type
8204                     and then not Object_Type_Has_Constrained_Partial_View
8205                                    (Typ  => Designated_Type (Prefix_Type),
8206                                     Scop => Current_Scope)
8207                   then
8208                      return False;
8209
8210                   --  Otherwise (general access type, or there is a constrained
8211                   --  partial view of the designated type), we need to check
8212                   --  based on the designated type.
8213
8214                   else
8215                      Prefix_Type := Designated_Type (Prefix_Type);
8216                   end if;
8217                end if;
8218             end if;
8219
8220             Comp :=
8221               Original_Record_Component (Entity (Selector_Name (Object)));
8222
8223             --  As per AI-0017, the renaming is illegal in a generic body, even
8224             --  if the subtype is indefinite.
8225
8226             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
8227
8228             if not Is_Constrained (Prefix_Type)
8229               and then (not Is_Indefinite_Subtype (Prefix_Type)
8230                          or else
8231                           (Is_Generic_Type (Prefix_Type)
8232                             and then Ekind (Current_Scope) = E_Generic_Package
8233                             and then In_Package_Body (Current_Scope)))
8234
8235               and then (Is_Declared_Within_Variant (Comp)
8236                           or else Has_Discriminant_Dependent_Constraint (Comp))
8237               and then (not P_Aliased or else Ada_Version >= Ada_2005)
8238             then
8239                return True;
8240
8241             --  If the prefix is of an access type at this point, then we want
8242             --  to return False, rather than calling this function recursively
8243             --  on the access object (which itself might be a discriminant-
8244             --  dependent component of some other object, but that isn't
8245             --  relevant to checking the object passed to us). This avoids
8246             --  issuing wrong errors when compiling with -gnatc, where there
8247             --  can be implicit dereferences that have not been expanded.
8248
8249             elsif Is_Access_Type (Etype (Prefix (Object))) then
8250                return False;
8251
8252             else
8253                return
8254                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
8255             end if;
8256
8257          elsif Nkind (Object) = N_Indexed_Component
8258            or else Nkind (Object) = N_Slice
8259          then
8260             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
8261
8262          --  A type conversion that Is_Variable is a view conversion:
8263          --  go back to the denoted object.
8264
8265          elsif Nkind (Object) = N_Type_Conversion then
8266             return
8267               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
8268          end if;
8269       end if;
8270
8271       return False;
8272    end Is_Dependent_Component_Of_Mutable_Object;
8273
8274    ---------------------
8275    -- Is_Dereferenced --
8276    ---------------------
8277
8278    function Is_Dereferenced (N : Node_Id) return Boolean is
8279       P : constant Node_Id := Parent (N);
8280    begin
8281       return
8282          (Nkind (P) = N_Selected_Component
8283             or else
8284           Nkind (P) = N_Explicit_Dereference
8285             or else
8286           Nkind (P) = N_Indexed_Component
8287             or else
8288           Nkind (P) = N_Slice)
8289         and then Prefix (P) = N;
8290    end Is_Dereferenced;
8291
8292    ----------------------
8293    -- Is_Descendent_Of --
8294    ----------------------
8295
8296    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
8297       T    : Entity_Id;
8298       Etyp : Entity_Id;
8299
8300    begin
8301       pragma Assert (Nkind (T1) in N_Entity);
8302       pragma Assert (Nkind (T2) in N_Entity);
8303
8304       T := Base_Type (T1);
8305
8306       --  Immediate return if the types match
8307
8308       if T = T2 then
8309          return True;
8310
8311       --  Comment needed here ???
8312
8313       elsif Ekind (T) = E_Class_Wide_Type then
8314          return Etype (T) = T2;
8315
8316       --  All other cases
8317
8318       else
8319          loop
8320             Etyp := Etype (T);
8321
8322             --  Done if we found the type we are looking for
8323
8324             if Etyp = T2 then
8325                return True;
8326
8327             --  Done if no more derivations to check
8328
8329             elsif T = T1
8330               or else T = Etyp
8331             then
8332                return False;
8333
8334             --  Following test catches error cases resulting from prev errors
8335
8336             elsif No (Etyp) then
8337                return False;
8338
8339             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
8340                return False;
8341
8342             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
8343                return False;
8344             end if;
8345
8346             T := Base_Type (Etyp);
8347          end loop;
8348       end if;
8349    end Is_Descendent_Of;
8350
8351    ----------------------------
8352    -- Is_Expression_Function --
8353    ----------------------------
8354
8355    function Is_Expression_Function (Subp : Entity_Id) return Boolean is
8356       Decl : Node_Id;
8357
8358    begin
8359       if Ekind (Subp) /= E_Function then
8360          return False;
8361
8362       else
8363          Decl := Unit_Declaration_Node (Subp);
8364          return Nkind (Decl) = N_Subprogram_Declaration
8365            and then
8366              (Nkind (Original_Node (Decl)) = N_Expression_Function
8367                or else
8368                  (Present (Corresponding_Body (Decl))
8369                    and then
8370                      Nkind (Original_Node
8371                              (Unit_Declaration_Node
8372                                (Corresponding_Body (Decl)))) =
8373                                   N_Expression_Function));
8374       end if;
8375    end Is_Expression_Function;
8376
8377    --------------
8378    -- Is_False --
8379    --------------
8380
8381    function Is_False (U : Uint) return Boolean is
8382    begin
8383       return (U = 0);
8384    end Is_False;
8385
8386    ---------------------------
8387    -- Is_Fixed_Model_Number --
8388    ---------------------------
8389
8390    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
8391       S : constant Ureal := Small_Value (T);
8392       M : Urealp.Save_Mark;
8393       R : Boolean;
8394    begin
8395       M := Urealp.Mark;
8396       R := (U = UR_Trunc (U / S) * S);
8397       Urealp.Release (M);
8398       return R;
8399    end Is_Fixed_Model_Number;
8400
8401    -------------------------------
8402    -- Is_Fully_Initialized_Type --
8403    -------------------------------
8404
8405    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
8406    begin
8407       --  In Ada2012, a scalar type with an aspect Default_Value
8408       --  is fully initialized.
8409
8410       if Is_Scalar_Type (Typ) then
8411          return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
8412
8413       elsif Is_Access_Type (Typ) then
8414          return True;
8415
8416       elsif Is_Array_Type (Typ) then
8417          if Is_Fully_Initialized_Type (Component_Type (Typ))
8418            or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
8419          then
8420             return True;
8421          end if;
8422
8423          --  An interesting case, if we have a constrained type one of whose
8424          --  bounds is known to be null, then there are no elements to be
8425          --  initialized, so all the elements are initialized!
8426
8427          if Is_Constrained (Typ) then
8428             declare
8429                Indx     : Node_Id;
8430                Indx_Typ : Entity_Id;
8431                Lbd, Hbd : Node_Id;
8432
8433             begin
8434                Indx := First_Index (Typ);
8435                while Present (Indx) loop
8436                   if Etype (Indx) = Any_Type then
8437                      return False;
8438
8439                   --  If index is a range, use directly
8440
8441                   elsif Nkind (Indx) = N_Range then
8442                      Lbd := Low_Bound  (Indx);
8443                      Hbd := High_Bound (Indx);
8444
8445                   else
8446                      Indx_Typ := Etype (Indx);
8447
8448                      if Is_Private_Type (Indx_Typ)  then
8449                         Indx_Typ := Full_View (Indx_Typ);
8450                      end if;
8451
8452                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
8453                         return False;
8454                      else
8455                         Lbd := Type_Low_Bound  (Indx_Typ);
8456                         Hbd := Type_High_Bound (Indx_Typ);
8457                      end if;
8458                   end if;
8459
8460                   if Compile_Time_Known_Value (Lbd)
8461                     and then Compile_Time_Known_Value (Hbd)
8462                   then
8463                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
8464                         return True;
8465                      end if;
8466                   end if;
8467
8468                   Next_Index (Indx);
8469                end loop;
8470             end;
8471          end if;
8472
8473          --  If no null indexes, then type is not fully initialized
8474
8475          return False;
8476
8477       --  Record types
8478
8479       elsif Is_Record_Type (Typ) then
8480          if Has_Discriminants (Typ)
8481            and then
8482              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
8483            and then Is_Fully_Initialized_Variant (Typ)
8484          then
8485             return True;
8486          end if;
8487
8488          --  We consider bounded string types to be fully initialized, because
8489          --  otherwise we get false alarms when the Data component is not
8490          --  default-initialized.
8491
8492          if Is_Bounded_String (Typ) then
8493             return True;
8494          end if;
8495
8496          --  Controlled records are considered to be fully initialized if
8497          --  there is a user defined Initialize routine. This may not be
8498          --  entirely correct, but as the spec notes, we are guessing here
8499          --  what is best from the point of view of issuing warnings.
8500
8501          if Is_Controlled (Typ) then
8502             declare
8503                Utyp : constant Entity_Id := Underlying_Type (Typ);
8504
8505             begin
8506                if Present (Utyp) then
8507                   declare
8508                      Init : constant Entity_Id :=
8509                               (Find_Prim_Op
8510                                  (Underlying_Type (Typ), Name_Initialize));
8511
8512                   begin
8513                      if Present (Init)
8514                        and then Comes_From_Source (Init)
8515                        and then not
8516                          Is_Predefined_File_Name
8517                            (File_Name (Get_Source_File_Index (Sloc (Init))))
8518                      then
8519                         return True;
8520
8521                      elsif Has_Null_Extension (Typ)
8522                         and then
8523                           Is_Fully_Initialized_Type
8524                             (Etype (Base_Type (Typ)))
8525                      then
8526                         return True;
8527                      end if;
8528                   end;
8529                end if;
8530             end;
8531          end if;
8532
8533          --  Otherwise see if all record components are initialized
8534
8535          declare
8536             Ent : Entity_Id;
8537
8538          begin
8539             Ent := First_Entity (Typ);
8540             while Present (Ent) loop
8541                if Ekind (Ent) = E_Component
8542                  and then (No (Parent (Ent))
8543                              or else No (Expression (Parent (Ent))))
8544                  and then not Is_Fully_Initialized_Type (Etype (Ent))
8545
8546                   --  Special VM case for tag components, which need to be
8547                   --  defined in this case, but are never initialized as VMs
8548                   --  are using other dispatching mechanisms. Ignore this
8549                   --  uninitialized case. Note that this applies both to the
8550                   --  uTag entry and the main vtable pointer (CPP_Class case).
8551
8552                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
8553                then
8554                   return False;
8555                end if;
8556
8557                Next_Entity (Ent);
8558             end loop;
8559          end;
8560
8561          --  No uninitialized components, so type is fully initialized.
8562          --  Note that this catches the case of no components as well.
8563
8564          return True;
8565
8566       elsif Is_Concurrent_Type (Typ) then
8567          return True;
8568
8569       elsif Is_Private_Type (Typ) then
8570          declare
8571             U : constant Entity_Id := Underlying_Type (Typ);
8572
8573          begin
8574             if No (U) then
8575                return False;
8576             else
8577                return Is_Fully_Initialized_Type (U);
8578             end if;
8579          end;
8580
8581       else
8582          return False;
8583       end if;
8584    end Is_Fully_Initialized_Type;
8585
8586    ----------------------------------
8587    -- Is_Fully_Initialized_Variant --
8588    ----------------------------------
8589
8590    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
8591       Loc           : constant Source_Ptr := Sloc (Typ);
8592       Constraints   : constant List_Id    := New_List;
8593       Components    : constant Elist_Id   := New_Elmt_List;
8594       Comp_Elmt     : Elmt_Id;
8595       Comp_Id       : Node_Id;
8596       Comp_List     : Node_Id;
8597       Discr         : Entity_Id;
8598       Discr_Val     : Node_Id;
8599
8600       Report_Errors : Boolean;
8601       pragma Warnings (Off, Report_Errors);
8602
8603    begin
8604       if Serious_Errors_Detected > 0 then
8605          return False;
8606       end if;
8607
8608       if Is_Record_Type (Typ)
8609         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
8610         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
8611       then
8612          Comp_List := Component_List (Type_Definition (Parent (Typ)));
8613
8614          Discr := First_Discriminant (Typ);
8615          while Present (Discr) loop
8616             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
8617                Discr_Val := Expression (Parent (Discr));
8618
8619                if Present (Discr_Val)
8620                  and then Is_OK_Static_Expression (Discr_Val)
8621                then
8622                   Append_To (Constraints,
8623                     Make_Component_Association (Loc,
8624                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
8625                       Expression => New_Copy (Discr_Val)));
8626                else
8627                   return False;
8628                end if;
8629             else
8630                return False;
8631             end if;
8632
8633             Next_Discriminant (Discr);
8634          end loop;
8635
8636          Gather_Components
8637            (Typ           => Typ,
8638             Comp_List     => Comp_List,
8639             Governed_By   => Constraints,
8640             Into          => Components,
8641             Report_Errors => Report_Errors);
8642
8643          --  Check that each component present is fully initialized
8644
8645          Comp_Elmt := First_Elmt (Components);
8646          while Present (Comp_Elmt) loop
8647             Comp_Id := Node (Comp_Elmt);
8648
8649             if Ekind (Comp_Id) = E_Component
8650               and then (No (Parent (Comp_Id))
8651                          or else No (Expression (Parent (Comp_Id))))
8652               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
8653             then
8654                return False;
8655             end if;
8656
8657             Next_Elmt (Comp_Elmt);
8658          end loop;
8659
8660          return True;
8661
8662       elsif Is_Private_Type (Typ) then
8663          declare
8664             U : constant Entity_Id := Underlying_Type (Typ);
8665
8666          begin
8667             if No (U) then
8668                return False;
8669             else
8670                return Is_Fully_Initialized_Variant (U);
8671             end if;
8672          end;
8673
8674       else
8675          return False;
8676       end if;
8677    end Is_Fully_Initialized_Variant;
8678
8679    ----------------------------
8680    -- Is_Inherited_Operation --
8681    ----------------------------
8682
8683    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
8684       pragma Assert (Is_Overloadable (E));
8685       Kind : constant Node_Kind := Nkind (Parent (E));
8686    begin
8687       return Kind = N_Full_Type_Declaration
8688         or else Kind = N_Private_Extension_Declaration
8689         or else Kind = N_Subtype_Declaration
8690         or else (Ekind (E) = E_Enumeration_Literal
8691                   and then Is_Derived_Type (Etype (E)));
8692    end Is_Inherited_Operation;
8693
8694    -------------------------------------
8695    -- Is_Inherited_Operation_For_Type --
8696    -------------------------------------
8697
8698    function Is_Inherited_Operation_For_Type
8699      (E   : Entity_Id;
8700       Typ : Entity_Id) return Boolean
8701    is
8702    begin
8703       --  Check that the operation has been created by the type declaration
8704
8705       return Is_Inherited_Operation (E)
8706         and then Defining_Identifier (Parent (E)) = Typ;
8707    end Is_Inherited_Operation_For_Type;
8708
8709    -----------------
8710    -- Is_Iterator --
8711    -----------------
8712
8713    function Is_Iterator (Typ : Entity_Id) return Boolean is
8714       Ifaces_List : Elist_Id;
8715       Iface_Elmt  : Elmt_Id;
8716       Iface       : Entity_Id;
8717
8718    begin
8719       if Is_Class_Wide_Type (Typ)
8720         and then
8721           Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator,
8722                                        Name_Reversible_Iterator)
8723         and then
8724           Is_Predefined_File_Name
8725             (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
8726       then
8727          return True;
8728
8729       elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
8730          return False;
8731
8732       else
8733          Collect_Interfaces (Typ, Ifaces_List);
8734
8735          Iface_Elmt := First_Elmt (Ifaces_List);
8736          while Present (Iface_Elmt) loop
8737             Iface := Node (Iface_Elmt);
8738             if Chars (Iface) = Name_Forward_Iterator
8739               and then
8740                 Is_Predefined_File_Name
8741                   (Unit_File_Name (Get_Source_Unit (Iface)))
8742             then
8743                return True;
8744             end if;
8745
8746             Next_Elmt (Iface_Elmt);
8747          end loop;
8748
8749          return False;
8750       end if;
8751    end Is_Iterator;
8752
8753    ------------
8754    -- Is_LHS --
8755    ------------
8756
8757    --  We seem to have a lot of overlapping functions that do similar things
8758    --  (testing for left hand sides or lvalues???). Anyway, since this one is
8759    --  purely syntactic, it should be in Sem_Aux I would think???
8760
8761    function Is_LHS (N : Node_Id) return Boolean is
8762       P : constant Node_Id := Parent (N);
8763
8764    begin
8765       if Nkind (P) = N_Assignment_Statement then
8766          return Name (P) = N;
8767
8768       elsif
8769         Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
8770       then
8771          return N = Prefix (P) and then Is_LHS (P);
8772
8773       else
8774          return False;
8775       end if;
8776    end Is_LHS;
8777
8778    -----------------------------
8779    -- Is_Library_Level_Entity --
8780    -----------------------------
8781
8782    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
8783    begin
8784       --  The following is a small optimization, and it also properly handles
8785       --  discriminals, which in task bodies might appear in expressions before
8786       --  the corresponding procedure has been created, and which therefore do
8787       --  not have an assigned scope.
8788
8789       if Is_Formal (E) then
8790          return False;
8791       end if;
8792
8793       --  Normal test is simply that the enclosing dynamic scope is Standard
8794
8795       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
8796    end Is_Library_Level_Entity;
8797
8798    --------------------------------
8799    -- Is_Limited_Class_Wide_Type --
8800    --------------------------------
8801
8802    function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
8803    begin
8804       return
8805         Is_Class_Wide_Type (Typ)
8806           and then (Is_Limited_Type (Typ) or else From_With_Type (Typ));
8807    end Is_Limited_Class_Wide_Type;
8808
8809    ---------------------------------
8810    -- Is_Local_Variable_Reference --
8811    ---------------------------------
8812
8813    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
8814    begin
8815       if not Is_Entity_Name (Expr) then
8816          return False;
8817
8818       else
8819          declare
8820             Ent : constant Entity_Id := Entity (Expr);
8821             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
8822          begin
8823             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
8824                return False;
8825             else
8826                return Present (Sub) and then Sub = Current_Subprogram;
8827             end if;
8828          end;
8829       end if;
8830    end Is_Local_Variable_Reference;
8831
8832    -------------------------
8833    -- Is_Object_Reference --
8834    -------------------------
8835
8836    function Is_Object_Reference (N : Node_Id) return Boolean is
8837
8838       function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
8839       --  Determine whether N is the name of an internally-generated renaming
8840
8841       --------------------------------------
8842       -- Is_Internally_Generated_Renaming --
8843       --------------------------------------
8844
8845       function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
8846          P : Node_Id;
8847
8848       begin
8849          P := N;
8850          while Present (P) loop
8851             if Nkind (P) = N_Object_Renaming_Declaration then
8852                return not Comes_From_Source (P);
8853             elsif Is_List_Member (P) then
8854                return False;
8855             end if;
8856
8857             P := Parent (P);
8858          end loop;
8859
8860          return False;
8861       end Is_Internally_Generated_Renaming;
8862
8863    --  Start of processing for Is_Object_Reference
8864
8865    begin
8866       if Is_Entity_Name (N) then
8867          return Present (Entity (N)) and then Is_Object (Entity (N));
8868
8869       else
8870          case Nkind (N) is
8871             when N_Indexed_Component | N_Slice =>
8872                return
8873                  Is_Object_Reference (Prefix (N))
8874                    or else Is_Access_Type (Etype (Prefix (N)));
8875
8876             --  In Ada 95, a function call is a constant object; a procedure
8877             --  call is not.
8878
8879             when N_Function_Call =>
8880                return Etype (N) /= Standard_Void_Type;
8881
8882             --  Attributes 'Input, 'Old and 'Result produce objects
8883
8884             when N_Attribute_Reference =>
8885                return
8886                  Nam_In
8887                    (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
8888
8889             when N_Selected_Component =>
8890                return
8891                  Is_Object_Reference (Selector_Name (N))
8892                    and then
8893                      (Is_Object_Reference (Prefix (N))
8894                         or else Is_Access_Type (Etype (Prefix (N))));
8895
8896             when N_Explicit_Dereference =>
8897                return True;
8898
8899             --  A view conversion of a tagged object is an object reference
8900
8901             when N_Type_Conversion =>
8902                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
8903                  and then Is_Tagged_Type (Etype (Expression (N)))
8904                  and then Is_Object_Reference (Expression (N));
8905
8906             --  An unchecked type conversion is considered to be an object if
8907             --  the operand is an object (this construction arises only as a
8908             --  result of expansion activities).
8909
8910             when N_Unchecked_Type_Conversion =>
8911                return True;
8912
8913             --  Allow string literals to act as objects as long as they appear
8914             --  in internally-generated renamings. The expansion of iterators
8915             --  may generate such renamings when the range involves a string
8916             --  literal.
8917
8918             when N_String_Literal =>
8919                return Is_Internally_Generated_Renaming (Parent (N));
8920
8921             --  AI05-0003: In Ada 2012 a qualified expression is a name.
8922             --  This allows disambiguation of function calls and the use
8923             --  of aggregates in more contexts.
8924
8925             when N_Qualified_Expression =>
8926                if Ada_Version <  Ada_2012 then
8927                   return False;
8928                else
8929                   return Is_Object_Reference (Expression (N))
8930                     or else Nkind (Expression (N)) = N_Aggregate;
8931                end if;
8932
8933             when others =>
8934                return False;
8935          end case;
8936       end if;
8937    end Is_Object_Reference;
8938
8939    -----------------------------------
8940    -- Is_OK_Variable_For_Out_Formal --
8941    -----------------------------------
8942
8943    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
8944    begin
8945       Note_Possible_Modification (AV, Sure => True);
8946
8947       --  We must reject parenthesized variable names. Comes_From_Source is
8948       --  checked because there are currently cases where the compiler violates
8949       --  this rule (e.g. passing a task object to its controlled Initialize
8950       --  routine). This should be properly documented in sinfo???
8951
8952       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
8953          return False;
8954
8955       --  A variable is always allowed
8956
8957       elsif Is_Variable (AV) then
8958          return True;
8959
8960       --  Unchecked conversions are allowed only if they come from the
8961       --  generated code, which sometimes uses unchecked conversions for out
8962       --  parameters in cases where code generation is unaffected. We tell
8963       --  source unchecked conversions by seeing if they are rewrites of
8964       --  an original Unchecked_Conversion function call, or of an explicit
8965       --  conversion of a function call or an aggregate (as may happen in the
8966       --  expansion of a packed array aggregate).
8967
8968       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
8969          if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
8970             return False;
8971
8972          elsif Comes_From_Source (AV)
8973            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
8974          then
8975             return False;
8976
8977          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
8978             return Is_OK_Variable_For_Out_Formal (Expression (AV));
8979
8980          else
8981             return True;
8982          end if;
8983
8984       --  Normal type conversions are allowed if argument is a variable
8985
8986       elsif Nkind (AV) = N_Type_Conversion then
8987          if Is_Variable (Expression (AV))
8988            and then Paren_Count (Expression (AV)) = 0
8989          then
8990             Note_Possible_Modification (Expression (AV), Sure => True);
8991             return True;
8992
8993          --  We also allow a non-parenthesized expression that raises
8994          --  constraint error if it rewrites what used to be a variable
8995
8996          elsif Raises_Constraint_Error (Expression (AV))
8997             and then Paren_Count (Expression (AV)) = 0
8998             and then Is_Variable (Original_Node (Expression (AV)))
8999          then
9000             return True;
9001
9002          --  Type conversion of something other than a variable
9003
9004          else
9005             return False;
9006          end if;
9007
9008       --  If this node is rewritten, then test the original form, if that is
9009       --  OK, then we consider the rewritten node OK (for example, if the
9010       --  original node is a conversion, then Is_Variable will not be true
9011       --  but we still want to allow the conversion if it converts a variable).
9012
9013       elsif Original_Node (AV) /= AV then
9014
9015          --  In Ada 2012, the explicit dereference may be a rewritten call to a
9016          --  Reference function.
9017
9018          if Ada_Version >= Ada_2012
9019            and then Nkind (Original_Node (AV)) = N_Function_Call
9020            and then
9021              Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
9022          then
9023             return True;
9024
9025          else
9026             return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
9027          end if;
9028
9029       --  All other non-variables are rejected
9030
9031       else
9032          return False;
9033       end if;
9034    end Is_OK_Variable_For_Out_Formal;
9035
9036    -----------------------------------
9037    -- Is_Partially_Initialized_Type --
9038    -----------------------------------
9039
9040    function Is_Partially_Initialized_Type
9041      (Typ              : Entity_Id;
9042       Include_Implicit : Boolean := True) return Boolean
9043    is
9044    begin
9045       if Is_Scalar_Type (Typ) then
9046          return False;
9047
9048       elsif Is_Access_Type (Typ) then
9049          return Include_Implicit;
9050
9051       elsif Is_Array_Type (Typ) then
9052
9053          --  If component type is partially initialized, so is array type
9054
9055          if Is_Partially_Initialized_Type
9056               (Component_Type (Typ), Include_Implicit)
9057          then
9058             return True;
9059
9060          --  Otherwise we are only partially initialized if we are fully
9061          --  initialized (this is the empty array case, no point in us
9062          --  duplicating that code here).
9063
9064          else
9065             return Is_Fully_Initialized_Type (Typ);
9066          end if;
9067
9068       elsif Is_Record_Type (Typ) then
9069
9070          --  A discriminated type is always partially initialized if in
9071          --  all mode
9072
9073          if Has_Discriminants (Typ) and then Include_Implicit then
9074             return True;
9075
9076          --  A tagged type is always partially initialized
9077
9078          elsif Is_Tagged_Type (Typ) then
9079             return True;
9080
9081          --  Case of non-discriminated record
9082
9083          else
9084             declare
9085                Ent : Entity_Id;
9086
9087                Component_Present : Boolean := False;
9088                --  Set True if at least one component is present. If no
9089                --  components are present, then record type is fully
9090                --  initialized (another odd case, like the null array).
9091
9092             begin
9093                --  Loop through components
9094
9095                Ent := First_Entity (Typ);
9096                while Present (Ent) loop
9097                   if Ekind (Ent) = E_Component then
9098                      Component_Present := True;
9099
9100                      --  If a component has an initialization expression then
9101                      --  the enclosing record type is partially initialized
9102
9103                      if Present (Parent (Ent))
9104                        and then Present (Expression (Parent (Ent)))
9105                      then
9106                         return True;
9107
9108                      --  If a component is of a type which is itself partially
9109                      --  initialized, then the enclosing record type is also.
9110
9111                      elsif Is_Partially_Initialized_Type
9112                              (Etype (Ent), Include_Implicit)
9113                      then
9114                         return True;
9115                      end if;
9116                   end if;
9117
9118                   Next_Entity (Ent);
9119                end loop;
9120
9121                --  No initialized components found. If we found any components
9122                --  they were all uninitialized so the result is false.
9123
9124                if Component_Present then
9125                   return False;
9126
9127                --  But if we found no components, then all the components are
9128                --  initialized so we consider the type to be initialized.
9129
9130                else
9131                   return True;
9132                end if;
9133             end;
9134          end if;
9135
9136       --  Concurrent types are always fully initialized
9137
9138       elsif Is_Concurrent_Type (Typ) then
9139          return True;
9140
9141       --  For a private type, go to underlying type. If there is no underlying
9142       --  type then just assume this partially initialized. Not clear if this
9143       --  can happen in a non-error case, but no harm in testing for this.
9144
9145       elsif Is_Private_Type (Typ) then
9146          declare
9147             U : constant Entity_Id := Underlying_Type (Typ);
9148          begin
9149             if No (U) then
9150                return True;
9151             else
9152                return Is_Partially_Initialized_Type (U, Include_Implicit);
9153             end if;
9154          end;
9155
9156       --  For any other type (are there any?) assume partially initialized
9157
9158       else
9159          return True;
9160       end if;
9161    end Is_Partially_Initialized_Type;
9162
9163    ------------------------------------
9164    -- Is_Potentially_Persistent_Type --
9165    ------------------------------------
9166
9167    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
9168       Comp : Entity_Id;
9169       Indx : Node_Id;
9170
9171    begin
9172       --  For private type, test corresponding full type
9173
9174       if Is_Private_Type (T) then
9175          return Is_Potentially_Persistent_Type (Full_View (T));
9176
9177       --  Scalar types are potentially persistent
9178
9179       elsif Is_Scalar_Type (T) then
9180          return True;
9181
9182       --  Record type is potentially persistent if not tagged and the types of
9183       --  all it components are potentially persistent, and no component has
9184       --  an initialization expression.
9185
9186       elsif Is_Record_Type (T)
9187         and then not Is_Tagged_Type (T)
9188         and then not Is_Partially_Initialized_Type (T)
9189       then
9190          Comp := First_Component (T);
9191          while Present (Comp) loop
9192             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
9193                return False;
9194             else
9195                Next_Entity (Comp);
9196             end if;
9197          end loop;
9198
9199          return True;
9200
9201       --  Array type is potentially persistent if its component type is
9202       --  potentially persistent and if all its constraints are static.
9203
9204       elsif Is_Array_Type (T) then
9205          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
9206             return False;
9207          end if;
9208
9209          Indx := First_Index (T);
9210          while Present (Indx) loop
9211             if not Is_OK_Static_Subtype (Etype (Indx)) then
9212                return False;
9213             else
9214                Next_Index (Indx);
9215             end if;
9216          end loop;
9217
9218          return True;
9219
9220       --  All other types are not potentially persistent
9221
9222       else
9223          return False;
9224       end if;
9225    end Is_Potentially_Persistent_Type;
9226
9227    ---------------------------------
9228    -- Is_Protected_Self_Reference --
9229    ---------------------------------
9230
9231    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
9232
9233       function In_Access_Definition (N : Node_Id) return Boolean;
9234       --  Returns true if N belongs to an access definition
9235
9236       --------------------------
9237       -- In_Access_Definition --
9238       --------------------------
9239
9240       function In_Access_Definition (N : Node_Id) return Boolean is
9241          P : Node_Id;
9242
9243       begin
9244          P := Parent (N);
9245          while Present (P) loop
9246             if Nkind (P) = N_Access_Definition then
9247                return True;
9248             end if;
9249
9250             P := Parent (P);
9251          end loop;
9252
9253          return False;
9254       end In_Access_Definition;
9255
9256    --  Start of processing for Is_Protected_Self_Reference
9257
9258    begin
9259       --  Verify that prefix is analyzed and has the proper form. Note that
9260       --  the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
9261       --  which also produce the address of an entity, do not analyze their
9262       --  prefix because they denote entities that are not necessarily visible.
9263       --  Neither of them can apply to a protected type.
9264
9265       return Ada_Version >= Ada_2005
9266         and then Is_Entity_Name (N)
9267         and then Present (Entity (N))
9268         and then Is_Protected_Type (Entity (N))
9269         and then In_Open_Scopes (Entity (N))
9270         and then not In_Access_Definition (N);
9271    end Is_Protected_Self_Reference;
9272
9273    -----------------------------
9274    -- Is_RCI_Pkg_Spec_Or_Body --
9275    -----------------------------
9276
9277    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
9278
9279       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
9280       --  Return True if the unit of Cunit is an RCI package declaration
9281
9282       ---------------------------
9283       -- Is_RCI_Pkg_Decl_Cunit --
9284       ---------------------------
9285
9286       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
9287          The_Unit : constant Node_Id := Unit (Cunit);
9288
9289       begin
9290          if Nkind (The_Unit) /= N_Package_Declaration then
9291             return False;
9292          end if;
9293
9294          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
9295       end Is_RCI_Pkg_Decl_Cunit;
9296
9297    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
9298
9299    begin
9300       return Is_RCI_Pkg_Decl_Cunit (Cunit)
9301         or else
9302          (Nkind (Unit (Cunit)) = N_Package_Body
9303            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
9304    end Is_RCI_Pkg_Spec_Or_Body;
9305
9306    -----------------------------------------
9307    -- Is_Remote_Access_To_Class_Wide_Type --
9308    -----------------------------------------
9309
9310    function Is_Remote_Access_To_Class_Wide_Type
9311      (E : Entity_Id) return Boolean
9312    is
9313    begin
9314       --  A remote access to class-wide type is a general access to object type
9315       --  declared in the visible part of a Remote_Types or Remote_Call_
9316       --  Interface unit.
9317
9318       return Ekind (E) = E_General_Access_Type
9319         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
9320    end Is_Remote_Access_To_Class_Wide_Type;
9321
9322    -----------------------------------------
9323    -- Is_Remote_Access_To_Subprogram_Type --
9324    -----------------------------------------
9325
9326    function Is_Remote_Access_To_Subprogram_Type
9327      (E : Entity_Id) return Boolean
9328    is
9329    begin
9330       return (Ekind (E) = E_Access_Subprogram_Type
9331                 or else (Ekind (E) = E_Record_Type
9332                            and then Present (Corresponding_Remote_Type (E))))
9333         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
9334    end Is_Remote_Access_To_Subprogram_Type;
9335
9336    --------------------
9337    -- Is_Remote_Call --
9338    --------------------
9339
9340    function Is_Remote_Call (N : Node_Id) return Boolean is
9341    begin
9342       if Nkind (N) not in N_Subprogram_Call then
9343
9344          --  An entry call cannot be remote
9345
9346          return False;
9347
9348       elsif Nkind (Name (N)) in N_Has_Entity
9349         and then Is_Remote_Call_Interface (Entity (Name (N)))
9350       then
9351          --  A subprogram declared in the spec of a RCI package is remote
9352
9353          return True;
9354
9355       elsif Nkind (Name (N)) = N_Explicit_Dereference
9356         and then Is_Remote_Access_To_Subprogram_Type
9357                    (Etype (Prefix (Name (N))))
9358       then
9359          --  The dereference of a RAS is a remote call
9360
9361          return True;
9362
9363       elsif Present (Controlling_Argument (N))
9364         and then Is_Remote_Access_To_Class_Wide_Type
9365           (Etype (Controlling_Argument (N)))
9366       then
9367          --  Any primitive operation call with a controlling argument of
9368          --  a RACW type is a remote call.
9369
9370          return True;
9371       end if;
9372
9373       --  All other calls are local calls
9374
9375       return False;
9376    end Is_Remote_Call;
9377
9378    ----------------------
9379    -- Is_Renamed_Entry --
9380    ----------------------
9381
9382    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
9383       Orig_Node : Node_Id := Empty;
9384       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
9385
9386       function Is_Entry (Nam : Node_Id) return Boolean;
9387       --  Determine whether Nam is an entry. Traverse selectors if there are
9388       --  nested selected components.
9389
9390       --------------
9391       -- Is_Entry --
9392       --------------
9393
9394       function Is_Entry (Nam : Node_Id) return Boolean is
9395       begin
9396          if Nkind (Nam) = N_Selected_Component then
9397             return Is_Entry (Selector_Name (Nam));
9398          end if;
9399
9400          return Ekind (Entity (Nam)) = E_Entry;
9401       end Is_Entry;
9402
9403    --  Start of processing for Is_Renamed_Entry
9404
9405    begin
9406       if Present (Alias (Proc_Nam)) then
9407          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
9408       end if;
9409
9410       --  Look for a rewritten subprogram renaming declaration
9411
9412       if Nkind (Subp_Decl) = N_Subprogram_Declaration
9413         and then Present (Original_Node (Subp_Decl))
9414       then
9415          Orig_Node := Original_Node (Subp_Decl);
9416       end if;
9417
9418       --  The rewritten subprogram is actually an entry
9419
9420       if Present (Orig_Node)
9421         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
9422         and then Is_Entry (Name (Orig_Node))
9423       then
9424          return True;
9425       end if;
9426
9427       return False;
9428    end Is_Renamed_Entry;
9429
9430    ----------------------------
9431    -- Is_Reversible_Iterator --
9432    ----------------------------
9433
9434    function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
9435       Ifaces_List : Elist_Id;
9436       Iface_Elmt  : Elmt_Id;
9437       Iface       : Entity_Id;
9438
9439    begin
9440       if Is_Class_Wide_Type (Typ)
9441         and then  Chars (Etype (Typ)) = Name_Reversible_Iterator
9442         and then
9443           Is_Predefined_File_Name
9444             (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
9445       then
9446          return True;
9447
9448       elsif not Is_Tagged_Type (Typ)
9449         or else not Is_Derived_Type (Typ)
9450       then
9451          return False;
9452
9453       else
9454          Collect_Interfaces (Typ, Ifaces_List);
9455
9456          Iface_Elmt := First_Elmt (Ifaces_List);
9457          while Present (Iface_Elmt) loop
9458             Iface := Node (Iface_Elmt);
9459             if Chars (Iface) = Name_Reversible_Iterator
9460               and then
9461                 Is_Predefined_File_Name
9462                   (Unit_File_Name (Get_Source_Unit (Iface)))
9463             then
9464                return True;
9465             end if;
9466
9467             Next_Elmt (Iface_Elmt);
9468          end loop;
9469       end if;
9470
9471       return False;
9472    end Is_Reversible_Iterator;
9473
9474    ----------------------
9475    -- Is_Selector_Name --
9476    ----------------------
9477
9478    function Is_Selector_Name (N : Node_Id) return Boolean is
9479    begin
9480       if not Is_List_Member (N) then
9481          declare
9482             P : constant Node_Id   := Parent (N);
9483             K : constant Node_Kind := Nkind (P);
9484          begin
9485             return
9486               (K = N_Expanded_Name          or else
9487                K = N_Generic_Association    or else
9488                K = N_Parameter_Association  or else
9489                K = N_Selected_Component)
9490               and then Selector_Name (P) = N;
9491          end;
9492
9493       else
9494          declare
9495             L : constant List_Id := List_Containing (N);
9496             P : constant Node_Id := Parent (L);
9497          begin
9498             return (Nkind (P) = N_Discriminant_Association
9499                      and then Selector_Names (P) = L)
9500               or else
9501                    (Nkind (P) = N_Component_Association
9502                      and then Choices (P) = L);
9503          end;
9504       end if;
9505    end Is_Selector_Name;
9506
9507    ----------------------------------
9508    -- Is_SPARK_Initialization_Expr --
9509    ----------------------------------
9510
9511    function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
9512       Is_Ok     : Boolean;
9513       Expr      : Node_Id;
9514       Comp_Assn : Node_Id;
9515       Orig_N    : constant Node_Id := Original_Node (N);
9516
9517    begin
9518       Is_Ok := True;
9519
9520       if not Comes_From_Source (Orig_N) then
9521          goto Done;
9522       end if;
9523
9524       pragma Assert (Nkind (Orig_N) in N_Subexpr);
9525
9526       case Nkind (Orig_N) is
9527          when N_Character_Literal |
9528               N_Integer_Literal   |
9529               N_Real_Literal      |
9530               N_String_Literal    =>
9531             null;
9532
9533          when N_Identifier    |
9534               N_Expanded_Name =>
9535             if Is_Entity_Name (Orig_N)
9536               and then Present (Entity (Orig_N))  --  needed in some cases
9537             then
9538                case Ekind (Entity (Orig_N)) is
9539                   when E_Constant            |
9540                        E_Enumeration_Literal |
9541                        E_Named_Integer       |
9542                        E_Named_Real          =>
9543                      null;
9544                   when others =>
9545                      if Is_Type (Entity (Orig_N)) then
9546                         null;
9547                      else
9548                         Is_Ok := False;
9549                      end if;
9550                end case;
9551             end if;
9552
9553          when N_Qualified_Expression |
9554               N_Type_Conversion      =>
9555             Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
9556
9557          when N_Unary_Op =>
9558             Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
9559
9560          when N_Binary_Op       |
9561               N_Short_Circuit   |
9562               N_Membership_Test =>
9563             Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
9564               and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
9565
9566          when N_Aggregate           |
9567               N_Extension_Aggregate =>
9568             if Nkind (Orig_N) = N_Extension_Aggregate then
9569                Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
9570             end if;
9571
9572             Expr := First (Expressions (Orig_N));
9573             while Present (Expr) loop
9574                if not Is_SPARK_Initialization_Expr (Expr) then
9575                   Is_Ok := False;
9576                   goto Done;
9577                end if;
9578
9579                Next (Expr);
9580             end loop;
9581
9582             Comp_Assn := First (Component_Associations (Orig_N));
9583             while Present (Comp_Assn) loop
9584                Expr := Expression (Comp_Assn);
9585                if Present (Expr)  --  needed for box association
9586                  and then not Is_SPARK_Initialization_Expr (Expr)
9587                then
9588                   Is_Ok := False;
9589                   goto Done;
9590                end if;
9591
9592                Next (Comp_Assn);
9593             end loop;
9594
9595          when N_Attribute_Reference =>
9596             if Nkind (Prefix (Orig_N)) in N_Subexpr then
9597                Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
9598             end if;
9599
9600             Expr := First (Expressions (Orig_N));
9601             while Present (Expr) loop
9602                if not Is_SPARK_Initialization_Expr (Expr) then
9603                   Is_Ok := False;
9604                   goto Done;
9605                end if;
9606
9607                Next (Expr);
9608             end loop;
9609
9610          --  Selected components might be expanded named not yet resolved, so
9611          --  default on the safe side. (Eg on sparklex.ads)
9612
9613          when N_Selected_Component =>
9614             null;
9615
9616          when others =>
9617             Is_Ok := False;
9618       end case;
9619
9620    <<Done>>
9621       return Is_Ok;
9622    end Is_SPARK_Initialization_Expr;
9623
9624    -------------------------------
9625    -- Is_SPARK_Object_Reference --
9626    -------------------------------
9627
9628    function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
9629    begin
9630       if Is_Entity_Name (N) then
9631          return Present (Entity (N))
9632            and then
9633              (Ekind_In (Entity (N), E_Constant, E_Variable)
9634               or else Ekind (Entity (N)) in Formal_Kind);
9635
9636       else
9637          case Nkind (N) is
9638             when N_Selected_Component =>
9639                return Is_SPARK_Object_Reference (Prefix (N));
9640
9641             when others =>
9642                return False;
9643          end case;
9644       end if;
9645    end Is_SPARK_Object_Reference;
9646
9647    ------------------
9648    -- Is_Statement --
9649    ------------------
9650
9651    function Is_Statement (N : Node_Id) return Boolean is
9652    begin
9653       return
9654         Nkind (N) in N_Statement_Other_Than_Procedure_Call
9655           or else Nkind (N) = N_Procedure_Call_Statement;
9656    end Is_Statement;
9657
9658    --------------------------------------------------
9659    -- Is_Subprogram_Stub_Without_Prior_Declaration --
9660    --------------------------------------------------
9661
9662    function Is_Subprogram_Stub_Without_Prior_Declaration
9663      (N : Node_Id) return Boolean
9664    is
9665    begin
9666       --  A subprogram stub without prior declaration serves as declaration for
9667       --  the actual subprogram body. As such, it has an attached defining
9668       --  entity of E_[Generic_]Function or E_[Generic_]Procedure.
9669
9670       return Nkind (N) = N_Subprogram_Body_Stub
9671         and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
9672    end Is_Subprogram_Stub_Without_Prior_Declaration;
9673
9674    ---------------------------------
9675    -- Is_Synchronized_Tagged_Type --
9676    ---------------------------------
9677
9678    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
9679       Kind : constant Entity_Kind := Ekind (Base_Type (E));
9680
9681    begin
9682       --  A task or protected type derived from an interface is a tagged type.
9683       --  Such a tagged type is called a synchronized tagged type, as are
9684       --  synchronized interfaces and private extensions whose declaration
9685       --  includes the reserved word synchronized.
9686
9687       return (Is_Tagged_Type (E)
9688                 and then (Kind = E_Task_Type
9689                            or else Kind = E_Protected_Type))
9690             or else
9691              (Is_Interface (E)
9692                 and then Is_Synchronized_Interface (E))
9693             or else
9694              (Ekind (E) = E_Record_Type_With_Private
9695                 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
9696                 and then (Synchronized_Present (Parent (E))
9697                            or else Is_Synchronized_Interface (Etype (E))));
9698    end Is_Synchronized_Tagged_Type;
9699
9700    -----------------
9701    -- Is_Transfer --
9702    -----------------
9703
9704    function Is_Transfer (N : Node_Id) return Boolean is
9705       Kind : constant Node_Kind := Nkind (N);
9706
9707    begin
9708       if Kind = N_Simple_Return_Statement
9709            or else
9710          Kind = N_Extended_Return_Statement
9711            or else
9712          Kind = N_Goto_Statement
9713            or else
9714          Kind = N_Raise_Statement
9715            or else
9716          Kind = N_Requeue_Statement
9717       then
9718          return True;
9719
9720       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
9721         and then No (Condition (N))
9722       then
9723          return True;
9724
9725       elsif Kind = N_Procedure_Call_Statement
9726         and then Is_Entity_Name (Name (N))
9727         and then Present (Entity (Name (N)))
9728         and then No_Return (Entity (Name (N)))
9729       then
9730          return True;
9731
9732       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
9733          return True;
9734
9735       else
9736          return False;
9737       end if;
9738    end Is_Transfer;
9739
9740    -------------
9741    -- Is_True --
9742    -------------
9743
9744    function Is_True (U : Uint) return Boolean is
9745    begin
9746       return (U /= 0);
9747    end Is_True;
9748
9749    -------------------------------
9750    -- Is_Universal_Numeric_Type --
9751    -------------------------------
9752
9753    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
9754    begin
9755       return T = Universal_Integer or else T = Universal_Real;
9756    end Is_Universal_Numeric_Type;
9757
9758    -------------------
9759    -- Is_Value_Type --
9760    -------------------
9761
9762    function Is_Value_Type (T : Entity_Id) return Boolean is
9763    begin
9764       return VM_Target = CLI_Target
9765         and then Nkind (T) in N_Has_Chars
9766         and then Chars (T) /= No_Name
9767         and then Get_Name_String (Chars (T)) = "valuetype";
9768    end Is_Value_Type;
9769
9770    ----------------------------
9771    -- Is_Variable_Size_Array --
9772    ----------------------------
9773
9774    function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
9775       Idx : Node_Id;
9776
9777    begin
9778       pragma Assert (Is_Array_Type (E));
9779
9780       --  Check if some index is initialized with a non-constant value
9781
9782       Idx := First_Index (E);
9783       while Present (Idx) loop
9784          if Nkind (Idx) = N_Range then
9785             if not Is_Constant_Bound (Low_Bound (Idx))
9786               or else not Is_Constant_Bound (High_Bound (Idx))
9787             then
9788                return True;
9789             end if;
9790          end if;
9791
9792          Idx := Next_Index (Idx);
9793       end loop;
9794
9795       return False;
9796    end Is_Variable_Size_Array;
9797
9798    -----------------------------
9799    -- Is_Variable_Size_Record --
9800    -----------------------------
9801
9802    function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
9803       Comp     : Entity_Id;
9804       Comp_Typ : Entity_Id;
9805
9806    begin
9807       pragma Assert (Is_Record_Type (E));
9808
9809       Comp := First_Entity (E);
9810       while Present (Comp) loop
9811          Comp_Typ := Etype (Comp);
9812
9813          --  Recursive call if the record type has discriminants
9814
9815          if Is_Record_Type (Comp_Typ)
9816            and then Has_Discriminants (Comp_Typ)
9817            and then Is_Variable_Size_Record (Comp_Typ)
9818          then
9819             return True;
9820
9821          elsif Is_Array_Type (Comp_Typ)
9822            and then Is_Variable_Size_Array (Comp_Typ)
9823          then
9824             return True;
9825          end if;
9826
9827          Next_Entity (Comp);
9828       end loop;
9829
9830       return False;
9831    end Is_Variable_Size_Record;
9832
9833    ---------------------
9834    -- Is_VMS_Operator --
9835    ---------------------
9836
9837    function Is_VMS_Operator (Op : Entity_Id) return Boolean is
9838    begin
9839       --  The VMS operators are declared in a child of System that is loaded
9840       --  through pragma Extend_System. In some rare cases a program is run
9841       --  with this extension but without indicating that the target is VMS.
9842
9843       return Ekind (Op) = E_Function
9844         and then Is_Intrinsic_Subprogram (Op)
9845         and then
9846           ((Present_System_Aux and then Scope (Op) = System_Aux_Id)
9847              or else
9848               (True_VMS_Target
9849                 and then Scope (Scope (Op)) = RTU_Entity (System)));
9850    end Is_VMS_Operator;
9851
9852    -----------------
9853    -- Is_Variable --
9854    -----------------
9855
9856    function Is_Variable
9857      (N                 : Node_Id;
9858       Use_Original_Node : Boolean := True) return Boolean
9859    is
9860       Orig_Node : Node_Id;
9861
9862       function In_Protected_Function (E : Entity_Id) return Boolean;
9863       --  Within a protected function, the private components of the enclosing
9864       --  protected type are constants. A function nested within a (protected)
9865       --  procedure is not itself protected.
9866
9867       function Is_Variable_Prefix (P : Node_Id) return Boolean;
9868       --  Prefixes can involve implicit dereferences, in which case we must
9869       --  test for the case of a reference of a constant access type, which can
9870       --  can never be a variable.
9871
9872       ---------------------------
9873       -- In_Protected_Function --
9874       ---------------------------
9875
9876       function In_Protected_Function (E : Entity_Id) return Boolean is
9877          Prot : constant Entity_Id := Scope (E);
9878          S    : Entity_Id;
9879
9880       begin
9881          if not Is_Protected_Type (Prot) then
9882             return False;
9883          else
9884             S := Current_Scope;
9885             while Present (S) and then S /= Prot loop
9886                if Ekind (S) = E_Function and then Scope (S) = Prot then
9887                   return True;
9888                end if;
9889
9890                S := Scope (S);
9891             end loop;
9892
9893             return False;
9894          end if;
9895       end In_Protected_Function;
9896
9897       ------------------------
9898       -- Is_Variable_Prefix --
9899       ------------------------
9900
9901       function Is_Variable_Prefix (P : Node_Id) return Boolean is
9902       begin
9903          if Is_Access_Type (Etype (P)) then
9904             return not Is_Access_Constant (Root_Type (Etype (P)));
9905
9906          --  For the case of an indexed component whose prefix has a packed
9907          --  array type, the prefix has been rewritten into a type conversion.
9908          --  Determine variable-ness from the converted expression.
9909
9910          elsif Nkind (P) = N_Type_Conversion
9911            and then not Comes_From_Source (P)
9912            and then Is_Array_Type (Etype (P))
9913            and then Is_Packed (Etype (P))
9914          then
9915             return Is_Variable (Expression (P));
9916
9917          else
9918             return Is_Variable (P);
9919          end if;
9920       end Is_Variable_Prefix;
9921
9922    --  Start of processing for Is_Variable
9923
9924    begin
9925       --  Check if we perform the test on the original node since this may be a
9926       --  test of syntactic categories which must not be disturbed by whatever
9927       --  rewriting might have occurred. For example, an aggregate, which is
9928       --  certainly NOT a variable, could be turned into a variable by
9929       --  expansion.
9930
9931       if Use_Original_Node then
9932          Orig_Node := Original_Node (N);
9933       else
9934          Orig_Node := N;
9935       end if;
9936
9937       --  Definitely OK if Assignment_OK is set. Since this is something that
9938       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
9939
9940       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
9941          return True;
9942
9943       --  Normally we go to the original node, but there is one exception where
9944       --  we use the rewritten node, namely when it is an explicit dereference.
9945       --  The generated code may rewrite a prefix which is an access type with
9946       --  an explicit dereference. The dereference is a variable, even though
9947       --  the original node may not be (since it could be a constant of the
9948       --  access type).
9949
9950       --  In Ada 2005 we have a further case to consider: the prefix may be a
9951       --  function call given in prefix notation. The original node appears to
9952       --  be a selected component, but we need to examine the call.
9953
9954       elsif Nkind (N) = N_Explicit_Dereference
9955         and then Nkind (Orig_Node) /= N_Explicit_Dereference
9956         and then Present (Etype (Orig_Node))
9957         and then Is_Access_Type (Etype (Orig_Node))
9958       then
9959          --  Note that if the prefix is an explicit dereference that does not
9960          --  come from source, we must check for a rewritten function call in
9961          --  prefixed notation before other forms of rewriting, to prevent a
9962          --  compiler crash.
9963
9964          return
9965            (Nkind (Orig_Node) = N_Function_Call
9966              and then not Is_Access_Constant (Etype (Prefix (N))))
9967            or else
9968              Is_Variable_Prefix (Original_Node (Prefix (N)));
9969
9970       --  in Ada 2012, the dereference may have been added for a type with
9971       --  a declared implicit dereference aspect.
9972
9973       elsif Nkind (N) = N_Explicit_Dereference
9974         and then Present (Etype (Orig_Node))
9975         and then  Ada_Version >= Ada_2012
9976         and then Has_Implicit_Dereference (Etype (Orig_Node))
9977       then
9978          return True;
9979
9980       --  A function call is never a variable
9981
9982       elsif Nkind (N) = N_Function_Call then
9983          return False;
9984
9985       --  All remaining checks use the original node
9986
9987       elsif Is_Entity_Name (Orig_Node)
9988         and then Present (Entity (Orig_Node))
9989       then
9990          declare
9991             E : constant Entity_Id := Entity (Orig_Node);
9992             K : constant Entity_Kind := Ekind (E);
9993
9994          begin
9995             return (K = E_Variable
9996                       and then Nkind (Parent (E)) /= N_Exception_Handler)
9997               or else  (K = E_Component
9998                           and then not In_Protected_Function (E))
9999               or else  K = E_Out_Parameter
10000               or else  K = E_In_Out_Parameter
10001               or else  K = E_Generic_In_Out_Parameter
10002
10003                --  Current instance of type
10004
10005               or else (Is_Type (E) and then In_Open_Scopes (E))
10006               or else (Is_Incomplete_Or_Private_Type (E)
10007                         and then In_Open_Scopes (Full_View (E)));
10008          end;
10009
10010       else
10011          case Nkind (Orig_Node) is
10012             when N_Indexed_Component | N_Slice =>
10013                return Is_Variable_Prefix (Prefix (Orig_Node));
10014
10015             when N_Selected_Component =>
10016                return Is_Variable_Prefix (Prefix (Orig_Node))
10017                  and then Is_Variable (Selector_Name (Orig_Node));
10018
10019             --  For an explicit dereference, the type of the prefix cannot
10020             --  be an access to constant or an access to subprogram.
10021
10022             when N_Explicit_Dereference =>
10023                declare
10024                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
10025                begin
10026                   return Is_Access_Type (Typ)
10027                     and then not Is_Access_Constant (Root_Type (Typ))
10028                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
10029                end;
10030
10031             --  The type conversion is the case where we do not deal with the
10032             --  context dependent special case of an actual parameter. Thus
10033             --  the type conversion is only considered a variable for the
10034             --  purposes of this routine if the target type is tagged. However,
10035             --  a type conversion is considered to be a variable if it does not
10036             --  come from source (this deals for example with the conversions
10037             --  of expressions to their actual subtypes).
10038
10039             when N_Type_Conversion =>
10040                return Is_Variable (Expression (Orig_Node))
10041                  and then
10042                    (not Comes_From_Source (Orig_Node)
10043                       or else
10044                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
10045                           and then
10046                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
10047
10048             --  GNAT allows an unchecked type conversion as a variable. This
10049             --  only affects the generation of internal expanded code, since
10050             --  calls to instantiations of Unchecked_Conversion are never
10051             --  considered variables (since they are function calls).
10052
10053             when N_Unchecked_Type_Conversion =>
10054                return Is_Variable (Expression (Orig_Node));
10055
10056             when others =>
10057                return False;
10058          end case;
10059       end if;
10060    end Is_Variable;
10061
10062    ---------------------------
10063    -- Is_Visibly_Controlled --
10064    ---------------------------
10065
10066    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
10067       Root : constant Entity_Id := Root_Type (T);
10068    begin
10069       return Chars (Scope (Root)) = Name_Finalization
10070         and then Chars (Scope (Scope (Root))) = Name_Ada
10071         and then Scope (Scope (Scope (Root))) = Standard_Standard;
10072    end Is_Visibly_Controlled;
10073
10074    ------------------------
10075    -- Is_Volatile_Object --
10076    ------------------------
10077
10078    function Is_Volatile_Object (N : Node_Id) return Boolean is
10079
10080       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
10081       --  Determines if given object has volatile components
10082
10083       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
10084       --  If prefix is an implicit dereference, examine designated type
10085
10086       ------------------------
10087       -- Is_Volatile_Prefix --
10088       ------------------------
10089
10090       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
10091          Typ  : constant Entity_Id := Etype (N);
10092
10093       begin
10094          if Is_Access_Type (Typ) then
10095             declare
10096                Dtyp : constant Entity_Id := Designated_Type (Typ);
10097
10098             begin
10099                return Is_Volatile (Dtyp)
10100                  or else Has_Volatile_Components (Dtyp);
10101             end;
10102
10103          else
10104             return Object_Has_Volatile_Components (N);
10105          end if;
10106       end Is_Volatile_Prefix;
10107
10108       ------------------------------------
10109       -- Object_Has_Volatile_Components --
10110       ------------------------------------
10111
10112       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
10113          Typ : constant Entity_Id := Etype (N);
10114
10115       begin
10116          if Is_Volatile (Typ)
10117            or else Has_Volatile_Components (Typ)
10118          then
10119             return True;
10120
10121          elsif Is_Entity_Name (N)
10122            and then (Has_Volatile_Components (Entity (N))
10123                       or else Is_Volatile (Entity (N)))
10124          then
10125             return True;
10126
10127          elsif Nkind (N) = N_Indexed_Component
10128            or else Nkind (N) = N_Selected_Component
10129          then
10130             return Is_Volatile_Prefix (Prefix (N));
10131
10132          else
10133             return False;
10134          end if;
10135       end Object_Has_Volatile_Components;
10136
10137    --  Start of processing for Is_Volatile_Object
10138
10139    begin
10140       if Is_Volatile (Etype (N))
10141         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
10142       then
10143          return True;
10144
10145       elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
10146         and then Is_Volatile_Prefix (Prefix (N))
10147       then
10148          return True;
10149
10150       elsif Nkind (N) = N_Selected_Component
10151         and then Is_Volatile (Entity (Selector_Name (N)))
10152       then
10153          return True;
10154
10155       else
10156          return False;
10157       end if;
10158    end Is_Volatile_Object;
10159
10160    ---------------------------
10161    -- Itype_Has_Declaration --
10162    ---------------------------
10163
10164    function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
10165    begin
10166       pragma Assert (Is_Itype (Id));
10167       return Present (Parent (Id))
10168         and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
10169                                         N_Subtype_Declaration)
10170         and then Defining_Entity (Parent (Id)) = Id;
10171    end Itype_Has_Declaration;
10172
10173    -------------------------
10174    -- Kill_Current_Values --
10175    -------------------------
10176
10177    procedure Kill_Current_Values
10178      (Ent                  : Entity_Id;
10179       Last_Assignment_Only : Boolean := False)
10180    is
10181    begin
10182       --  ??? do we have to worry about clearing cached checks?
10183
10184       if Is_Assignable (Ent) then
10185          Set_Last_Assignment (Ent, Empty);
10186       end if;
10187
10188       if Is_Object (Ent) then
10189          if not Last_Assignment_Only then
10190             Kill_Checks (Ent);
10191             Set_Current_Value (Ent, Empty);
10192
10193             if not Can_Never_Be_Null (Ent) then
10194                Set_Is_Known_Non_Null (Ent, False);
10195             end if;
10196
10197             Set_Is_Known_Null (Ent, False);
10198
10199             --  Reset Is_Known_Valid unless type is always valid, or if we have
10200             --  a loop parameter (loop parameters are always valid, since their
10201             --  bounds are defined by the bounds given in the loop header).
10202
10203             if not Is_Known_Valid (Etype (Ent))
10204               and then Ekind (Ent) /= E_Loop_Parameter
10205             then
10206                Set_Is_Known_Valid (Ent, False);
10207             end if;
10208          end if;
10209       end if;
10210    end Kill_Current_Values;
10211
10212    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
10213       S : Entity_Id;
10214
10215       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
10216       --  Clear current value for entity E and all entities chained to E
10217
10218       ------------------------------------------
10219       -- Kill_Current_Values_For_Entity_Chain --
10220       ------------------------------------------
10221
10222       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
10223          Ent : Entity_Id;
10224       begin
10225          Ent := E;
10226          while Present (Ent) loop
10227             Kill_Current_Values (Ent, Last_Assignment_Only);
10228             Next_Entity (Ent);
10229          end loop;
10230       end Kill_Current_Values_For_Entity_Chain;
10231
10232    --  Start of processing for Kill_Current_Values
10233
10234    begin
10235       --  Kill all saved checks, a special case of killing saved values
10236
10237       if not Last_Assignment_Only then
10238          Kill_All_Checks;
10239       end if;
10240
10241       --  Loop through relevant scopes, which includes the current scope and
10242       --  any parent scopes if the current scope is a block or a package.
10243
10244       S := Current_Scope;
10245       Scope_Loop : loop
10246
10247          --  Clear current values of all entities in current scope
10248
10249          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
10250
10251          --  If scope is a package, also clear current values of all private
10252          --  entities in the scope.
10253
10254          if Is_Package_Or_Generic_Package (S)
10255            or else Is_Concurrent_Type (S)
10256          then
10257             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
10258          end if;
10259
10260          --  If this is a not a subprogram, deal with parents
10261
10262          if not Is_Subprogram (S) then
10263             S := Scope (S);
10264             exit Scope_Loop when S = Standard_Standard;
10265          else
10266             exit Scope_Loop;
10267          end if;
10268       end loop Scope_Loop;
10269    end Kill_Current_Values;
10270
10271    --------------------------
10272    -- Kill_Size_Check_Code --
10273    --------------------------
10274
10275    procedure Kill_Size_Check_Code (E : Entity_Id) is
10276    begin
10277       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
10278         and then Present (Size_Check_Code (E))
10279       then
10280          Remove (Size_Check_Code (E));
10281          Set_Size_Check_Code (E, Empty);
10282       end if;
10283    end Kill_Size_Check_Code;
10284
10285    --------------------------
10286    -- Known_To_Be_Assigned --
10287    --------------------------
10288
10289    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
10290       P : constant Node_Id := Parent (N);
10291
10292    begin
10293       case Nkind (P) is
10294
10295          --  Test left side of assignment
10296
10297          when N_Assignment_Statement =>
10298             return N = Name (P);
10299
10300             --  Function call arguments are never lvalues
10301
10302          when N_Function_Call =>
10303             return False;
10304
10305          --  Positional parameter for procedure or accept call
10306
10307          when N_Procedure_Call_Statement |
10308               N_Accept_Statement
10309           =>
10310             declare
10311                Proc : Entity_Id;
10312                Form : Entity_Id;
10313                Act  : Node_Id;
10314
10315             begin
10316                Proc := Get_Subprogram_Entity (P);
10317
10318                if No (Proc) then
10319                   return False;
10320                end if;
10321
10322                --  If we are not a list member, something is strange, so
10323                --  be conservative and return False.
10324
10325                if not Is_List_Member (N) then
10326                   return False;
10327                end if;
10328
10329                --  We are going to find the right formal by stepping forward
10330                --  through the formals, as we step backwards in the actuals.
10331
10332                Form := First_Formal (Proc);
10333                Act  := N;
10334                loop
10335                   --  If no formal, something is weird, so be conservative
10336                   --  and return False.
10337
10338                   if No (Form) then
10339                      return False;
10340                   end if;
10341
10342                   Prev (Act);
10343                   exit when No (Act);
10344                   Next_Formal (Form);
10345                end loop;
10346
10347                return Ekind (Form) /= E_In_Parameter;
10348             end;
10349
10350          --  Named parameter for procedure or accept call
10351
10352          when N_Parameter_Association =>
10353             declare
10354                Proc : Entity_Id;
10355                Form : Entity_Id;
10356
10357             begin
10358                Proc := Get_Subprogram_Entity (Parent (P));
10359
10360                if No (Proc) then
10361                   return False;
10362                end if;
10363
10364                --  Loop through formals to find the one that matches
10365
10366                Form := First_Formal (Proc);
10367                loop
10368                   --  If no matching formal, that's peculiar, some kind of
10369                   --  previous error, so return False to be conservative.
10370                   --  Actually this also happens in legal code in the case
10371                   --  where P is a parameter association for an Extra_Formal???
10372
10373                   if No (Form) then
10374                      return False;
10375                   end if;
10376
10377                   --  Else test for match
10378
10379                   if Chars (Form) = Chars (Selector_Name (P)) then
10380                      return Ekind (Form) /= E_In_Parameter;
10381                   end if;
10382
10383                   Next_Formal (Form);
10384                end loop;
10385             end;
10386
10387          --  Test for appearing in a conversion that itself appears
10388          --  in an lvalue context, since this should be an lvalue.
10389
10390          when N_Type_Conversion =>
10391             return Known_To_Be_Assigned (P);
10392
10393          --  All other references are definitely not known to be modifications
10394
10395          when others =>
10396             return False;
10397
10398       end case;
10399    end Known_To_Be_Assigned;
10400
10401    ---------------------------
10402    -- Last_Source_Statement --
10403    ---------------------------
10404
10405    function Last_Source_Statement (HSS : Node_Id) return Node_Id is
10406       N : Node_Id;
10407
10408    begin
10409       N := Last (Statements (HSS));
10410       while Present (N) loop
10411          exit when Comes_From_Source (N);
10412          Prev (N);
10413       end loop;
10414
10415       return N;
10416    end Last_Source_Statement;
10417
10418    ----------------------------------
10419    -- Matching_Static_Array_Bounds --
10420    ----------------------------------
10421
10422    function Matching_Static_Array_Bounds
10423      (L_Typ : Node_Id;
10424       R_Typ : Node_Id) return Boolean
10425    is
10426       L_Ndims : constant Nat := Number_Dimensions (L_Typ);
10427       R_Ndims : constant Nat := Number_Dimensions (R_Typ);
10428
10429       L_Index : Node_Id;
10430       R_Index : Node_Id;
10431       L_Low   : Node_Id;
10432       L_High  : Node_Id;
10433       L_Len   : Uint;
10434       R_Low   : Node_Id;
10435       R_High  : Node_Id;
10436       R_Len   : Uint;
10437
10438    begin
10439       if L_Ndims /= R_Ndims then
10440          return False;
10441       end if;
10442
10443       --  Unconstrained types do not have static bounds
10444
10445       if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
10446          return False;
10447       end if;
10448
10449       --  First treat specially the first dimension, as the lower bound and
10450       --  length of string literals are not stored like those of arrays.
10451
10452       if Ekind (L_Typ) = E_String_Literal_Subtype then
10453          L_Low := String_Literal_Low_Bound (L_Typ);
10454          L_Len := String_Literal_Length (L_Typ);
10455       else
10456          L_Index := First_Index (L_Typ);
10457          Get_Index_Bounds (L_Index, L_Low, L_High);
10458
10459          if         Is_OK_Static_Expression (L_Low)
10460            and then Is_OK_Static_Expression (L_High)
10461          then
10462             if Expr_Value (L_High) < Expr_Value (L_Low) then
10463                L_Len := Uint_0;
10464             else
10465                L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
10466             end if;
10467          else
10468             return False;
10469          end if;
10470       end if;
10471
10472       if Ekind (R_Typ) = E_String_Literal_Subtype then
10473          R_Low := String_Literal_Low_Bound (R_Typ);
10474          R_Len := String_Literal_Length (R_Typ);
10475       else
10476          R_Index := First_Index (R_Typ);
10477          Get_Index_Bounds (R_Index, R_Low, R_High);
10478
10479          if         Is_OK_Static_Expression (R_Low)
10480            and then Is_OK_Static_Expression (R_High)
10481          then
10482             if Expr_Value (R_High) < Expr_Value (R_Low) then
10483                R_Len := Uint_0;
10484             else
10485                R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
10486             end if;
10487          else
10488             return False;
10489          end if;
10490       end if;
10491
10492       if         Is_OK_Static_Expression (L_Low)
10493         and then Is_OK_Static_Expression (R_Low)
10494         and then Expr_Value (L_Low) = Expr_Value (R_Low)
10495         and then L_Len = R_Len
10496       then
10497          null;
10498       else
10499          return False;
10500       end if;
10501
10502       --  Then treat all other dimensions
10503
10504       for Indx in 2 .. L_Ndims loop
10505          Next (L_Index);
10506          Next (R_Index);
10507
10508          Get_Index_Bounds (L_Index, L_Low, L_High);
10509          Get_Index_Bounds (R_Index, R_Low, R_High);
10510
10511          if         Is_OK_Static_Expression (L_Low)
10512            and then Is_OK_Static_Expression (L_High)
10513            and then Is_OK_Static_Expression (R_Low)
10514            and then Is_OK_Static_Expression (R_High)
10515            and then Expr_Value (L_Low)  = Expr_Value (R_Low)
10516            and then Expr_Value (L_High) = Expr_Value (R_High)
10517          then
10518             null;
10519          else
10520             return False;
10521          end if;
10522       end loop;
10523
10524       --  If we fall through the loop, all indexes matched
10525
10526       return True;
10527    end Matching_Static_Array_Bounds;
10528
10529    -------------------
10530    -- May_Be_Lvalue --
10531    -------------------
10532
10533    function May_Be_Lvalue (N : Node_Id) return Boolean is
10534       P : constant Node_Id := Parent (N);
10535
10536    begin
10537       case Nkind (P) is
10538
10539          --  Test left side of assignment
10540
10541          when N_Assignment_Statement =>
10542             return N = Name (P);
10543
10544          --  Test prefix of component or attribute. Note that the prefix of an
10545          --  explicit or implicit dereference cannot be an l-value.
10546
10547          when N_Attribute_Reference =>
10548             return N = Prefix (P)
10549               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
10550
10551          --  For an expanded name, the name is an lvalue if the expanded name
10552          --  is an lvalue, but the prefix is never an lvalue, since it is just
10553          --  the scope where the name is found.
10554
10555          when N_Expanded_Name =>
10556             if N = Prefix (P) then
10557                return May_Be_Lvalue (P);
10558             else
10559                return False;
10560             end if;
10561
10562          --  For a selected component A.B, A is certainly an lvalue if A.B is.
10563          --  B is a little interesting, if we have A.B := 3, there is some
10564          --  discussion as to whether B is an lvalue or not, we choose to say
10565          --  it is. Note however that A is not an lvalue if it is of an access
10566          --  type since this is an implicit dereference.
10567
10568          when N_Selected_Component =>
10569             if N = Prefix (P)
10570               and then Present (Etype (N))
10571               and then Is_Access_Type (Etype (N))
10572             then
10573                return False;
10574             else
10575                return May_Be_Lvalue (P);
10576             end if;
10577
10578          --  For an indexed component or slice, the index or slice bounds is
10579          --  never an lvalue. The prefix is an lvalue if the indexed component
10580          --  or slice is an lvalue, except if it is an access type, where we
10581          --  have an implicit dereference.
10582
10583          when N_Indexed_Component | N_Slice =>
10584             if N /= Prefix (P)
10585               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
10586             then
10587                return False;
10588             else
10589                return May_Be_Lvalue (P);
10590             end if;
10591
10592          --  Prefix of a reference is an lvalue if the reference is an lvalue
10593
10594          when N_Reference =>
10595             return May_Be_Lvalue (P);
10596
10597          --  Prefix of explicit dereference is never an lvalue
10598
10599          when N_Explicit_Dereference =>
10600             return False;
10601
10602          --  Positional parameter for subprogram, entry, or accept call.
10603          --  In older versions of Ada function call arguments are never
10604          --  lvalues. In Ada 2012 functions can have in-out parameters.
10605
10606          when N_Subprogram_Call      |
10607               N_Entry_Call_Statement |
10608               N_Accept_Statement
10609          =>
10610             if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
10611                return False;
10612             end if;
10613
10614             --  The following mechanism is clumsy and fragile. A single flag
10615             --  set in Resolve_Actuals would be preferable ???
10616
10617             declare
10618                Proc : Entity_Id;
10619                Form : Entity_Id;
10620                Act  : Node_Id;
10621
10622             begin
10623                Proc := Get_Subprogram_Entity (P);
10624
10625                if No (Proc) then
10626                   return True;
10627                end if;
10628
10629                --  If we are not a list member, something is strange, so be
10630                --  conservative and return True.
10631
10632                if not Is_List_Member (N) then
10633                   return True;
10634                end if;
10635
10636                --  We are going to find the right formal by stepping forward
10637                --  through the formals, as we step backwards in the actuals.
10638
10639                Form := First_Formal (Proc);
10640                Act  := N;
10641                loop
10642                   --  If no formal, something is weird, so be conservative and
10643                   --  return True.
10644
10645                   if No (Form) then
10646                      return True;
10647                   end if;
10648
10649                   Prev (Act);
10650                   exit when No (Act);
10651                   Next_Formal (Form);
10652                end loop;
10653
10654                return Ekind (Form) /= E_In_Parameter;
10655             end;
10656
10657          --  Named parameter for procedure or accept call
10658
10659          when N_Parameter_Association =>
10660             declare
10661                Proc : Entity_Id;
10662                Form : Entity_Id;
10663
10664             begin
10665                Proc := Get_Subprogram_Entity (Parent (P));
10666
10667                if No (Proc) then
10668                   return True;
10669                end if;
10670
10671                --  Loop through formals to find the one that matches
10672
10673                Form := First_Formal (Proc);
10674                loop
10675                   --  If no matching formal, that's peculiar, some kind of
10676                   --  previous error, so return True to be conservative.
10677                   --  Actually happens with legal code for an unresolved call
10678                   --  where we may get the wrong homonym???
10679
10680                   if No (Form) then
10681                      return True;
10682                   end if;
10683
10684                   --  Else test for match
10685
10686                   if Chars (Form) = Chars (Selector_Name (P)) then
10687                      return Ekind (Form) /= E_In_Parameter;
10688                   end if;
10689
10690                   Next_Formal (Form);
10691                end loop;
10692             end;
10693
10694          --  Test for appearing in a conversion that itself appears in an
10695          --  lvalue context, since this should be an lvalue.
10696
10697          when N_Type_Conversion =>
10698             return May_Be_Lvalue (P);
10699
10700          --  Test for appearance in object renaming declaration
10701
10702          when N_Object_Renaming_Declaration =>
10703             return True;
10704
10705          --  All other references are definitely not lvalues
10706
10707          when others =>
10708             return False;
10709
10710       end case;
10711    end May_Be_Lvalue;
10712
10713    -----------------------
10714    -- Mark_Coextensions --
10715    -----------------------
10716
10717    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
10718       Is_Dynamic : Boolean;
10719       --  Indicates whether the context causes nested coextensions to be
10720       --  dynamic or static
10721
10722       function Mark_Allocator (N : Node_Id) return Traverse_Result;
10723       --  Recognize an allocator node and label it as a dynamic coextension
10724
10725       --------------------
10726       -- Mark_Allocator --
10727       --------------------
10728
10729       function Mark_Allocator (N : Node_Id) return Traverse_Result is
10730       begin
10731          if Nkind (N) = N_Allocator then
10732             if Is_Dynamic then
10733                Set_Is_Dynamic_Coextension (N);
10734
10735             --  If the allocator expression is potentially dynamic, it may
10736             --  be expanded out of order and require dynamic allocation
10737             --  anyway, so we treat the coextension itself as dynamic.
10738             --  Potential optimization ???
10739
10740             elsif Nkind (Expression (N)) = N_Qualified_Expression
10741               and then Nkind (Expression (Expression (N))) = N_Op_Concat
10742             then
10743                Set_Is_Dynamic_Coextension (N);
10744             else
10745                Set_Is_Static_Coextension (N);
10746             end if;
10747          end if;
10748
10749          return OK;
10750       end Mark_Allocator;
10751
10752       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
10753
10754    --  Start of processing Mark_Coextensions
10755
10756    begin
10757       case Nkind (Context_Nod) is
10758
10759          --  Comment here ???
10760
10761          when N_Assignment_Statement    =>
10762             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
10763
10764          --  An allocator that is a component of a returned aggregate
10765          --  must be dynamic.
10766
10767          when N_Simple_Return_Statement =>
10768             declare
10769                Expr : constant Node_Id := Expression (Context_Nod);
10770             begin
10771                Is_Dynamic :=
10772                  Nkind (Expr) = N_Allocator
10773                    or else
10774                      (Nkind (Expr) = N_Qualified_Expression
10775                        and then Nkind (Expression (Expr)) = N_Aggregate);
10776             end;
10777
10778          --  An alloctor within an object declaration in an extended return
10779          --  statement is of necessity dynamic.
10780
10781          when N_Object_Declaration =>
10782             Is_Dynamic := Nkind (Root_Nod) = N_Allocator
10783               or else
10784                 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
10785
10786          --  This routine should not be called for constructs which may not
10787          --  contain coextensions.
10788
10789          when others =>
10790             raise Program_Error;
10791       end case;
10792
10793       Mark_Allocators (Root_Nod);
10794    end Mark_Coextensions;
10795
10796    -----------------
10797    -- Must_Inline --
10798    -----------------
10799
10800    function Must_Inline (Subp : Entity_Id) return Boolean is
10801    begin
10802       return
10803         (Optimization_Level = 0
10804
10805           --  AAMP and VM targets have no support for inlining in the backend.
10806           --  Hence we do as much inlining as possible in the front end.
10807
10808           or else AAMP_On_Target
10809           or else VM_Target /= No_VM)
10810         and then Has_Pragma_Inline (Subp)
10811         and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
10812    end Must_Inline;
10813
10814    ----------------------
10815    -- Needs_One_Actual --
10816    ----------------------
10817
10818    function Needs_One_Actual (E : Entity_Id) return Boolean is
10819       Formal : Entity_Id;
10820
10821    begin
10822       --  Ada 2005 or later, and formals present
10823
10824       if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
10825          Formal := Next_Formal (First_Formal (E));
10826          while Present (Formal) loop
10827             if No (Default_Value (Formal)) then
10828                return False;
10829             end if;
10830
10831             Next_Formal (Formal);
10832          end loop;
10833
10834          return True;
10835
10836       --  Ada 83/95 or no formals
10837
10838       else
10839          return False;
10840       end if;
10841    end Needs_One_Actual;
10842
10843    ------------------------
10844    -- New_Copy_List_Tree --
10845    ------------------------
10846
10847    function New_Copy_List_Tree (List : List_Id) return List_Id is
10848       NL : List_Id;
10849       E  : Node_Id;
10850
10851    begin
10852       if List = No_List then
10853          return No_List;
10854
10855       else
10856          NL := New_List;
10857          E := First (List);
10858
10859          while Present (E) loop
10860             Append (New_Copy_Tree (E), NL);
10861             E := Next (E);
10862          end loop;
10863
10864          return NL;
10865       end if;
10866    end New_Copy_List_Tree;
10867
10868    -------------------
10869    -- New_Copy_Tree --
10870    -------------------
10871
10872    use Atree.Unchecked_Access;
10873    use Atree_Private_Part;
10874
10875    --  Our approach here requires a two pass traversal of the tree. The
10876    --  first pass visits all nodes that eventually will be copied looking
10877    --  for defining Itypes. If any defining Itypes are found, then they are
10878    --  copied, and an entry is added to the replacement map. In the second
10879    --  phase, the tree is copied, using the replacement map to replace any
10880    --  Itype references within the copied tree.
10881
10882    --  The following hash tables are used if the Map supplied has more
10883    --  than hash threshold entries to speed up access to the map. If
10884    --  there are fewer entries, then the map is searched sequentially
10885    --  (because setting up a hash table for only a few entries takes
10886    --  more time than it saves.
10887
10888    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
10889    --  Hash function used for hash operations
10890
10891    -------------------
10892    -- New_Copy_Hash --
10893    -------------------
10894
10895    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
10896    begin
10897       return Nat (E) mod (NCT_Header_Num'Last + 1);
10898    end New_Copy_Hash;
10899
10900    ---------------
10901    -- NCT_Assoc --
10902    ---------------
10903
10904    --  The hash table NCT_Assoc associates old entities in the table
10905    --  with their corresponding new entities (i.e. the pairs of entries
10906    --  presented in the original Map argument are Key-Element pairs).
10907
10908    package NCT_Assoc is new Simple_HTable (
10909      Header_Num => NCT_Header_Num,
10910      Element    => Entity_Id,
10911      No_Element => Empty,
10912      Key        => Entity_Id,
10913      Hash       => New_Copy_Hash,
10914      Equal      => Types."=");
10915
10916    ---------------------
10917    -- NCT_Itype_Assoc --
10918    ---------------------
10919
10920    --  The hash table NCT_Itype_Assoc contains entries only for those
10921    --  old nodes which have a non-empty Associated_Node_For_Itype set.
10922    --  The key is the associated node, and the element is the new node
10923    --  itself (NOT the associated node for the new node).
10924
10925    package NCT_Itype_Assoc is new Simple_HTable (
10926      Header_Num => NCT_Header_Num,
10927      Element    => Entity_Id,
10928      No_Element => Empty,
10929      Key        => Entity_Id,
10930      Hash       => New_Copy_Hash,
10931      Equal      => Types."=");
10932
10933    --  Start of processing for New_Copy_Tree function
10934
10935    function New_Copy_Tree
10936      (Source    : Node_Id;
10937       Map       : Elist_Id := No_Elist;
10938       New_Sloc  : Source_Ptr := No_Location;
10939       New_Scope : Entity_Id := Empty) return Node_Id
10940    is
10941       Actual_Map : Elist_Id := Map;
10942       --  This is the actual map for the copy. It is initialized with the
10943       --  given elements, and then enlarged as required for Itypes that are
10944       --  copied during the first phase of the copy operation. The visit
10945       --  procedures add elements to this map as Itypes are encountered.
10946       --  The reason we cannot use Map directly, is that it may well be
10947       --  (and normally is) initialized to No_Elist, and if we have mapped
10948       --  entities, we have to reset it to point to a real Elist.
10949
10950       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
10951       --  Called during second phase to map entities into their corresponding
10952       --  copies using Actual_Map. If the argument is not an entity, or is not
10953       --  in Actual_Map, then it is returned unchanged.
10954
10955       procedure Build_NCT_Hash_Tables;
10956       --  Builds hash tables (number of elements >= threshold value)
10957
10958       function Copy_Elist_With_Replacement
10959         (Old_Elist : Elist_Id) return Elist_Id;
10960       --  Called during second phase to copy element list doing replacements
10961
10962       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
10963       --  Called during the second phase to process a copied Itype. The actual
10964       --  copy happened during the first phase (so that we could make the entry
10965       --  in the mapping), but we still have to deal with the descendents of
10966       --  the copied Itype and copy them where necessary.
10967
10968       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
10969       --  Called during second phase to copy list doing replacements
10970
10971       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
10972       --  Called during second phase to copy node doing replacements
10973
10974       procedure Visit_Elist (E : Elist_Id);
10975       --  Called during first phase to visit all elements of an Elist
10976
10977       procedure Visit_Field (F : Union_Id; N : Node_Id);
10978       --  Visit a single field, recursing to call Visit_Node or Visit_List
10979       --  if the field is a syntactic descendent of the current node (i.e.
10980       --  its parent is Node N).
10981
10982       procedure Visit_Itype (Old_Itype : Entity_Id);
10983       --  Called during first phase to visit subsidiary fields of a defining
10984       --  Itype, and also create a copy and make an entry in the replacement
10985       --  map for the new copy.
10986
10987       procedure Visit_List (L : List_Id);
10988       --  Called during first phase to visit all elements of a List
10989
10990       procedure Visit_Node (N : Node_Or_Entity_Id);
10991       --  Called during first phase to visit a node and all its subtrees
10992
10993       -----------
10994       -- Assoc --
10995       -----------
10996
10997       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
10998          E   : Elmt_Id;
10999          Ent : Entity_Id;
11000
11001       begin
11002          if not Has_Extension (N) or else No (Actual_Map) then
11003             return N;
11004
11005          elsif NCT_Hash_Tables_Used then
11006             Ent := NCT_Assoc.Get (Entity_Id (N));
11007
11008             if Present (Ent) then
11009                return Ent;
11010             else
11011                return N;
11012             end if;
11013
11014          --  No hash table used, do serial search
11015
11016          else
11017             E := First_Elmt (Actual_Map);
11018             while Present (E) loop
11019                if Node (E) = N then
11020                   return Node (Next_Elmt (E));
11021                else
11022                   E := Next_Elmt (Next_Elmt (E));
11023                end if;
11024             end loop;
11025          end if;
11026
11027          return N;
11028       end Assoc;
11029
11030       ---------------------------
11031       -- Build_NCT_Hash_Tables --
11032       ---------------------------
11033
11034       procedure Build_NCT_Hash_Tables is
11035          Elmt : Elmt_Id;
11036          Ent  : Entity_Id;
11037       begin
11038          if NCT_Hash_Table_Setup then
11039             NCT_Assoc.Reset;
11040             NCT_Itype_Assoc.Reset;
11041          end if;
11042
11043          Elmt := First_Elmt (Actual_Map);
11044          while Present (Elmt) loop
11045             Ent := Node (Elmt);
11046
11047             --  Get new entity, and associate old and new
11048
11049             Next_Elmt (Elmt);
11050             NCT_Assoc.Set (Ent, Node (Elmt));
11051
11052             if Is_Type (Ent) then
11053                declare
11054                   Anode : constant Entity_Id :=
11055                             Associated_Node_For_Itype (Ent);
11056
11057                begin
11058                   if Present (Anode) then
11059
11060                      --  Enter a link between the associated node of the
11061                      --  old Itype and the new Itype, for updating later
11062                      --  when node is copied.
11063
11064                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
11065                   end if;
11066                end;
11067             end if;
11068
11069             Next_Elmt (Elmt);
11070          end loop;
11071
11072          NCT_Hash_Tables_Used := True;
11073          NCT_Hash_Table_Setup := True;
11074       end Build_NCT_Hash_Tables;
11075
11076       ---------------------------------
11077       -- Copy_Elist_With_Replacement --
11078       ---------------------------------
11079
11080       function Copy_Elist_With_Replacement
11081         (Old_Elist : Elist_Id) return Elist_Id
11082       is
11083          M         : Elmt_Id;
11084          New_Elist : Elist_Id;
11085
11086       begin
11087          if No (Old_Elist) then
11088             return No_Elist;
11089
11090          else
11091             New_Elist := New_Elmt_List;
11092
11093             M := First_Elmt (Old_Elist);
11094             while Present (M) loop
11095                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
11096                Next_Elmt (M);
11097             end loop;
11098          end if;
11099
11100          return New_Elist;
11101       end Copy_Elist_With_Replacement;
11102
11103       ---------------------------------
11104       -- Copy_Itype_With_Replacement --
11105       ---------------------------------
11106
11107       --  This routine exactly parallels its phase one analog Visit_Itype,
11108
11109       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
11110       begin
11111          --  Translate Next_Entity, Scope and Etype fields, in case they
11112          --  reference entities that have been mapped into copies.
11113
11114          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
11115          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
11116
11117          if Present (New_Scope) then
11118             Set_Scope    (New_Itype, New_Scope);
11119          else
11120             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
11121          end if;
11122
11123          --  Copy referenced fields
11124
11125          if Is_Discrete_Type (New_Itype) then
11126             Set_Scalar_Range (New_Itype,
11127               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
11128
11129          elsif Has_Discriminants (Base_Type (New_Itype)) then
11130             Set_Discriminant_Constraint (New_Itype,
11131               Copy_Elist_With_Replacement
11132                 (Discriminant_Constraint (New_Itype)));
11133
11134          elsif Is_Array_Type (New_Itype) then
11135             if Present (First_Index (New_Itype)) then
11136                Set_First_Index (New_Itype,
11137                  First (Copy_List_With_Replacement
11138                          (List_Containing (First_Index (New_Itype)))));
11139             end if;
11140
11141             if Is_Packed (New_Itype) then
11142                Set_Packed_Array_Type (New_Itype,
11143                  Copy_Node_With_Replacement
11144                    (Packed_Array_Type (New_Itype)));
11145             end if;
11146          end if;
11147       end Copy_Itype_With_Replacement;
11148
11149       --------------------------------
11150       -- Copy_List_With_Replacement --
11151       --------------------------------
11152
11153       function Copy_List_With_Replacement
11154         (Old_List : List_Id) return List_Id
11155       is
11156          New_List : List_Id;
11157          E        : Node_Id;
11158
11159       begin
11160          if Old_List = No_List then
11161             return No_List;
11162
11163          else
11164             New_List := Empty_List;
11165
11166             E := First (Old_List);
11167             while Present (E) loop
11168                Append (Copy_Node_With_Replacement (E), New_List);
11169                Next (E);
11170             end loop;
11171
11172             return New_List;
11173          end if;
11174       end Copy_List_With_Replacement;
11175
11176       --------------------------------
11177       -- Copy_Node_With_Replacement --
11178       --------------------------------
11179
11180       function Copy_Node_With_Replacement
11181         (Old_Node : Node_Id) return Node_Id
11182       is
11183          New_Node : Node_Id;
11184
11185          procedure Adjust_Named_Associations
11186            (Old_Node : Node_Id;
11187             New_Node : Node_Id);
11188          --  If a call node has named associations, these are chained through
11189          --  the First_Named_Actual, Next_Named_Actual links. These must be
11190          --  propagated separately to the new parameter list, because these
11191          --  are not syntactic fields.
11192
11193          function Copy_Field_With_Replacement
11194            (Field : Union_Id) return Union_Id;
11195          --  Given Field, which is a field of Old_Node, return a copy of it
11196          --  if it is a syntactic field (i.e. its parent is Node), setting
11197          --  the parent of the copy to poit to New_Node. Otherwise returns
11198          --  the field (possibly mapped if it is an entity).
11199
11200          -------------------------------
11201          -- Adjust_Named_Associations --
11202          -------------------------------
11203
11204          procedure Adjust_Named_Associations
11205            (Old_Node : Node_Id;
11206             New_Node : Node_Id)
11207          is
11208             Old_E : Node_Id;
11209             New_E : Node_Id;
11210
11211             Old_Next : Node_Id;
11212             New_Next : Node_Id;
11213
11214          begin
11215             Old_E := First (Parameter_Associations (Old_Node));
11216             New_E := First (Parameter_Associations (New_Node));
11217             while Present (Old_E) loop
11218                if Nkind (Old_E) = N_Parameter_Association
11219                  and then Present (Next_Named_Actual (Old_E))
11220                then
11221                   if First_Named_Actual (Old_Node)
11222                     =  Explicit_Actual_Parameter (Old_E)
11223                   then
11224                      Set_First_Named_Actual
11225                        (New_Node, Explicit_Actual_Parameter (New_E));
11226                   end if;
11227
11228                   --  Now scan parameter list from the beginning,to locate
11229                   --  next named actual, which can be out of order.
11230
11231                   Old_Next := First (Parameter_Associations (Old_Node));
11232                   New_Next := First (Parameter_Associations (New_Node));
11233
11234                   while Nkind (Old_Next) /= N_Parameter_Association
11235                     or else  Explicit_Actual_Parameter (Old_Next)
11236                       /= Next_Named_Actual (Old_E)
11237                   loop
11238                      Next (Old_Next);
11239                      Next (New_Next);
11240                   end loop;
11241
11242                   Set_Next_Named_Actual
11243                     (New_E, Explicit_Actual_Parameter (New_Next));
11244                end if;
11245
11246                Next (Old_E);
11247                Next (New_E);
11248             end loop;
11249          end Adjust_Named_Associations;
11250
11251          ---------------------------------
11252          -- Copy_Field_With_Replacement --
11253          ---------------------------------
11254
11255          function Copy_Field_With_Replacement
11256            (Field : Union_Id) return Union_Id
11257          is
11258          begin
11259             if Field = Union_Id (Empty) then
11260                return Field;
11261
11262             elsif Field in Node_Range then
11263                declare
11264                   Old_N : constant Node_Id := Node_Id (Field);
11265                   New_N : Node_Id;
11266
11267                begin
11268                   --  If syntactic field, as indicated by the parent pointer
11269                   --  being set, then copy the referenced node recursively.
11270
11271                   if Parent (Old_N) = Old_Node then
11272                      New_N := Copy_Node_With_Replacement (Old_N);
11273
11274                      if New_N /= Old_N then
11275                         Set_Parent (New_N, New_Node);
11276                      end if;
11277
11278                   --  For semantic fields, update possible entity reference
11279                   --  from the replacement map.
11280
11281                   else
11282                      New_N := Assoc (Old_N);
11283                   end if;
11284
11285                   return Union_Id (New_N);
11286                end;
11287
11288             elsif Field in List_Range then
11289                declare
11290                   Old_L : constant List_Id := List_Id (Field);
11291                   New_L : List_Id;
11292
11293                begin
11294                   --  If syntactic field, as indicated by the parent pointer,
11295                   --  then recursively copy the entire referenced list.
11296
11297                   if Parent (Old_L) = Old_Node then
11298                      New_L := Copy_List_With_Replacement (Old_L);
11299                      Set_Parent (New_L, New_Node);
11300
11301                   --  For semantic list, just returned unchanged
11302
11303                   else
11304                      New_L := Old_L;
11305                   end if;
11306
11307                   return Union_Id (New_L);
11308                end;
11309
11310             --  Anything other than a list or a node is returned unchanged
11311
11312             else
11313                return Field;
11314             end if;
11315          end Copy_Field_With_Replacement;
11316
11317       --  Start of processing for Copy_Node_With_Replacement
11318
11319       begin
11320          if Old_Node <= Empty_Or_Error then
11321             return Old_Node;
11322
11323          elsif Has_Extension (Old_Node) then
11324             return Assoc (Old_Node);
11325
11326          else
11327             New_Node := New_Copy (Old_Node);
11328
11329             --  If the node we are copying is the associated node of a
11330             --  previously copied Itype, then adjust the associated node
11331             --  of the copy of that Itype accordingly.
11332
11333             if Present (Actual_Map) then
11334                declare
11335                   E   : Elmt_Id;
11336                   Ent : Entity_Id;
11337
11338                begin
11339                   --  Case of hash table used
11340
11341                   if NCT_Hash_Tables_Used then
11342                      Ent := NCT_Itype_Assoc.Get (Old_Node);
11343
11344                      if Present (Ent) then
11345                         Set_Associated_Node_For_Itype (Ent, New_Node);
11346                      end if;
11347
11348                   --  Case of no hash table used
11349
11350                   else
11351                      E := First_Elmt (Actual_Map);
11352                      while Present (E) loop
11353                         if Is_Itype (Node (E))
11354                           and then
11355                             Old_Node = Associated_Node_For_Itype (Node (E))
11356                         then
11357                            Set_Associated_Node_For_Itype
11358                              (Node (Next_Elmt (E)), New_Node);
11359                         end if;
11360
11361                         E := Next_Elmt (Next_Elmt (E));
11362                      end loop;
11363                   end if;
11364                end;
11365             end if;
11366
11367             --  Recursively copy descendents
11368
11369             Set_Field1
11370               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
11371             Set_Field2
11372               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
11373             Set_Field3
11374               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
11375             Set_Field4
11376               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
11377             Set_Field5
11378               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
11379
11380             --  Adjust Sloc of new node if necessary
11381
11382             if New_Sloc /= No_Location then
11383                Set_Sloc (New_Node, New_Sloc);
11384
11385                --  If we adjust the Sloc, then we are essentially making
11386                --  a completely new node, so the Comes_From_Source flag
11387                --  should be reset to the proper default value.
11388
11389                Nodes.Table (New_Node).Comes_From_Source :=
11390                  Default_Node.Comes_From_Source;
11391             end if;
11392
11393             --  If the node is call and has named associations,
11394             --  set the corresponding links in the copy.
11395
11396             if (Nkind (Old_Node) = N_Function_Call
11397                  or else Nkind (Old_Node) = N_Entry_Call_Statement
11398                  or else
11399                    Nkind (Old_Node) = N_Procedure_Call_Statement)
11400               and then Present (First_Named_Actual (Old_Node))
11401             then
11402                Adjust_Named_Associations (Old_Node, New_Node);
11403             end if;
11404
11405             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
11406             --  The replacement mechanism applies to entities, and is not used
11407             --  here. Eventually we may need a more general graph-copying
11408             --  routine. For now, do a sequential search to find desired node.
11409
11410             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
11411               and then Present (First_Real_Statement (Old_Node))
11412             then
11413                declare
11414                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
11415                   N1, N2 : Node_Id;
11416
11417                begin
11418                   N1 := First (Statements (Old_Node));
11419                   N2 := First (Statements (New_Node));
11420
11421                   while N1 /= Old_F loop
11422                      Next (N1);
11423                      Next (N2);
11424                   end loop;
11425
11426                   Set_First_Real_Statement (New_Node, N2);
11427                end;
11428             end if;
11429          end if;
11430
11431          --  All done, return copied node
11432
11433          return New_Node;
11434       end Copy_Node_With_Replacement;
11435
11436       -----------------
11437       -- Visit_Elist --
11438       -----------------
11439
11440       procedure Visit_Elist (E : Elist_Id) is
11441          Elmt : Elmt_Id;
11442       begin
11443          if Present (E) then
11444             Elmt := First_Elmt (E);
11445
11446             while Elmt /= No_Elmt loop
11447                Visit_Node (Node (Elmt));
11448                Next_Elmt (Elmt);
11449             end loop;
11450          end if;
11451       end Visit_Elist;
11452
11453       -----------------
11454       -- Visit_Field --
11455       -----------------
11456
11457       procedure Visit_Field (F : Union_Id; N : Node_Id) is
11458       begin
11459          if F = Union_Id (Empty) then
11460             return;
11461
11462          elsif F in Node_Range then
11463
11464             --  Copy node if it is syntactic, i.e. its parent pointer is
11465             --  set to point to the field that referenced it (certain
11466             --  Itypes will also meet this criterion, which is fine, since
11467             --  these are clearly Itypes that do need to be copied, since
11468             --  we are copying their parent.)
11469
11470             if Parent (Node_Id (F)) = N then
11471                Visit_Node (Node_Id (F));
11472                return;
11473
11474             --  Another case, if we are pointing to an Itype, then we want
11475             --  to copy it if its associated node is somewhere in the tree
11476             --  being copied.
11477
11478             --  Note: the exclusion of self-referential copies is just an
11479             --  optimization, since the search of the already copied list
11480             --  would catch it, but it is a common case (Etype pointing
11481             --  to itself for an Itype that is a base type).
11482
11483             elsif Has_Extension (Node_Id (F))
11484               and then Is_Itype (Entity_Id (F))
11485               and then Node_Id (F) /= N
11486             then
11487                declare
11488                   P : Node_Id;
11489
11490                begin
11491                   P := Associated_Node_For_Itype (Node_Id (F));
11492                   while Present (P) loop
11493                      if P = Source then
11494                         Visit_Node (Node_Id (F));
11495                         return;
11496                      else
11497                         P := Parent (P);
11498                      end if;
11499                   end loop;
11500
11501                   --  An Itype whose parent is not being copied definitely
11502                   --  should NOT be copied, since it does not belong in any
11503                   --  sense to the copied subtree.
11504
11505                   return;
11506                end;
11507             end if;
11508
11509          elsif F in List_Range
11510            and then Parent (List_Id (F)) = N
11511          then
11512             Visit_List (List_Id (F));
11513             return;
11514          end if;
11515       end Visit_Field;
11516
11517       -----------------
11518       -- Visit_Itype --
11519       -----------------
11520
11521       procedure Visit_Itype (Old_Itype : Entity_Id) is
11522          New_Itype : Entity_Id;
11523          E         : Elmt_Id;
11524          Ent       : Entity_Id;
11525
11526       begin
11527          --  Itypes that describe the designated type of access to subprograms
11528          --  have the structure of subprogram declarations, with signatures,
11529          --  etc. Either we duplicate the signatures completely, or choose to
11530          --  share such itypes, which is fine because their elaboration will
11531          --  have no side effects.
11532
11533          if Ekind (Old_Itype) = E_Subprogram_Type then
11534             return;
11535          end if;
11536
11537          New_Itype := New_Copy (Old_Itype);
11538
11539          --  The new Itype has all the attributes of the old one, and
11540          --  we just copy the contents of the entity. However, the back-end
11541          --  needs different names for debugging purposes, so we create a
11542          --  new internal name for it in all cases.
11543
11544          Set_Chars (New_Itype, New_Internal_Name ('T'));
11545
11546          --  If our associated node is an entity that has already been copied,
11547          --  then set the associated node of the copy to point to the right
11548          --  copy. If we have copied an Itype that is itself the associated
11549          --  node of some previously copied Itype, then we set the right
11550          --  pointer in the other direction.
11551
11552          if Present (Actual_Map) then
11553
11554             --  Case of hash tables used
11555
11556             if NCT_Hash_Tables_Used then
11557
11558                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
11559
11560                if Present (Ent) then
11561                   Set_Associated_Node_For_Itype (New_Itype, Ent);
11562                end if;
11563
11564                Ent := NCT_Itype_Assoc.Get (Old_Itype);
11565                if Present (Ent) then
11566                   Set_Associated_Node_For_Itype (Ent, New_Itype);
11567
11568                --  If the hash table has no association for this Itype and
11569                --  its associated node, enter one now.
11570
11571                else
11572                   NCT_Itype_Assoc.Set
11573                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
11574                end if;
11575
11576             --  Case of hash tables not used
11577
11578             else
11579                E := First_Elmt (Actual_Map);
11580                while Present (E) loop
11581                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
11582                      Set_Associated_Node_For_Itype
11583                        (New_Itype, Node (Next_Elmt (E)));
11584                   end if;
11585
11586                   if Is_Type (Node (E))
11587                     and then
11588                       Old_Itype = Associated_Node_For_Itype (Node (E))
11589                   then
11590                      Set_Associated_Node_For_Itype
11591                        (Node (Next_Elmt (E)), New_Itype);
11592                   end if;
11593
11594                   E := Next_Elmt (Next_Elmt (E));
11595                end loop;
11596             end if;
11597          end if;
11598
11599          if Present (Freeze_Node (New_Itype)) then
11600             Set_Is_Frozen (New_Itype, False);
11601             Set_Freeze_Node (New_Itype, Empty);
11602          end if;
11603
11604          --  Add new association to map
11605
11606          if No (Actual_Map) then
11607             Actual_Map := New_Elmt_List;
11608          end if;
11609
11610          Append_Elmt (Old_Itype, Actual_Map);
11611          Append_Elmt (New_Itype, Actual_Map);
11612
11613          if NCT_Hash_Tables_Used then
11614             NCT_Assoc.Set (Old_Itype, New_Itype);
11615
11616          else
11617             NCT_Table_Entries := NCT_Table_Entries + 1;
11618
11619             if NCT_Table_Entries > NCT_Hash_Threshold then
11620                Build_NCT_Hash_Tables;
11621             end if;
11622          end if;
11623
11624          --  If a record subtype is simply copied, the entity list will be
11625          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
11626
11627          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
11628             Set_Cloned_Subtype (New_Itype, Old_Itype);
11629          end if;
11630
11631          --  Visit descendents that eventually get copied
11632
11633          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
11634
11635          if Is_Discrete_Type (Old_Itype) then
11636             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
11637
11638          elsif Has_Discriminants (Base_Type (Old_Itype)) then
11639             --  ??? This should involve call to Visit_Field
11640             Visit_Elist (Discriminant_Constraint (Old_Itype));
11641
11642          elsif Is_Array_Type (Old_Itype) then
11643             if Present (First_Index (Old_Itype)) then
11644                Visit_Field (Union_Id (List_Containing
11645                                 (First_Index (Old_Itype))),
11646                             Old_Itype);
11647             end if;
11648
11649             if Is_Packed (Old_Itype) then
11650                Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
11651                             Old_Itype);
11652             end if;
11653          end if;
11654       end Visit_Itype;
11655
11656       ----------------
11657       -- Visit_List --
11658       ----------------
11659
11660       procedure Visit_List (L : List_Id) is
11661          N : Node_Id;
11662       begin
11663          if L /= No_List then
11664             N := First (L);
11665
11666             while Present (N) loop
11667                Visit_Node (N);
11668                Next (N);
11669             end loop;
11670          end if;
11671       end Visit_List;
11672
11673       ----------------
11674       -- Visit_Node --
11675       ----------------
11676
11677       procedure Visit_Node (N : Node_Or_Entity_Id) is
11678
11679       --  Start of processing for Visit_Node
11680
11681       begin
11682          --  Handle case of an Itype, which must be copied
11683
11684          if Has_Extension (N)
11685            and then Is_Itype (N)
11686          then
11687             --  Nothing to do if already in the list. This can happen with an
11688             --  Itype entity that appears more than once in the tree.
11689             --  Note that we do not want to visit descendents in this case.
11690
11691             --  Test for already in list when hash table is used
11692
11693             if NCT_Hash_Tables_Used then
11694                if Present (NCT_Assoc.Get (Entity_Id (N))) then
11695                   return;
11696                end if;
11697
11698             --  Test for already in list when hash table not used
11699
11700             else
11701                declare
11702                   E : Elmt_Id;
11703                begin
11704                   if Present (Actual_Map) then
11705                      E := First_Elmt (Actual_Map);
11706                      while Present (E) loop
11707                         if Node (E) = N then
11708                            return;
11709                         else
11710                            E := Next_Elmt (Next_Elmt (E));
11711                         end if;
11712                      end loop;
11713                   end if;
11714                end;
11715             end if;
11716
11717             Visit_Itype (N);
11718          end if;
11719
11720          --  Visit descendents
11721
11722          Visit_Field (Field1 (N), N);
11723          Visit_Field (Field2 (N), N);
11724          Visit_Field (Field3 (N), N);
11725          Visit_Field (Field4 (N), N);
11726          Visit_Field (Field5 (N), N);
11727       end Visit_Node;
11728
11729    --  Start of processing for New_Copy_Tree
11730
11731    begin
11732       Actual_Map := Map;
11733
11734       --  See if we should use hash table
11735
11736       if No (Actual_Map) then
11737          NCT_Hash_Tables_Used := False;
11738
11739       else
11740          declare
11741             Elmt : Elmt_Id;
11742
11743          begin
11744             NCT_Table_Entries := 0;
11745
11746             Elmt := First_Elmt (Actual_Map);
11747             while Present (Elmt) loop
11748                NCT_Table_Entries := NCT_Table_Entries + 1;
11749                Next_Elmt (Elmt);
11750                Next_Elmt (Elmt);
11751             end loop;
11752
11753             if NCT_Table_Entries > NCT_Hash_Threshold then
11754                Build_NCT_Hash_Tables;
11755             else
11756                NCT_Hash_Tables_Used := False;
11757             end if;
11758          end;
11759       end if;
11760
11761       --  Hash table set up if required, now start phase one by visiting
11762       --  top node (we will recursively visit the descendents).
11763
11764       Visit_Node (Source);
11765
11766       --  Now the second phase of the copy can start. First we process
11767       --  all the mapped entities, copying their descendents.
11768
11769       if Present (Actual_Map) then
11770          declare
11771             Elmt      : Elmt_Id;
11772             New_Itype : Entity_Id;
11773          begin
11774             Elmt := First_Elmt (Actual_Map);
11775             while Present (Elmt) loop
11776                Next_Elmt (Elmt);
11777                New_Itype := Node (Elmt);
11778                Copy_Itype_With_Replacement (New_Itype);
11779                Next_Elmt (Elmt);
11780             end loop;
11781          end;
11782       end if;
11783
11784       --  Now we can copy the actual tree
11785
11786       return Copy_Node_With_Replacement (Source);
11787    end New_Copy_Tree;
11788
11789    -------------------------
11790    -- New_External_Entity --
11791    -------------------------
11792
11793    function New_External_Entity
11794      (Kind         : Entity_Kind;
11795       Scope_Id     : Entity_Id;
11796       Sloc_Value   : Source_Ptr;
11797       Related_Id   : Entity_Id;
11798       Suffix       : Character;
11799       Suffix_Index : Nat := 0;
11800       Prefix       : Character := ' ') return Entity_Id
11801    is
11802       N : constant Entity_Id :=
11803             Make_Defining_Identifier (Sloc_Value,
11804               New_External_Name
11805                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
11806
11807    begin
11808       Set_Ekind          (N, Kind);
11809       Set_Is_Internal    (N, True);
11810       Append_Entity      (N, Scope_Id);
11811       Set_Public_Status  (N);
11812
11813       if Kind in Type_Kind then
11814          Init_Size_Align (N);
11815       end if;
11816
11817       return N;
11818    end New_External_Entity;
11819
11820    -------------------------
11821    -- New_Internal_Entity --
11822    -------------------------
11823
11824    function New_Internal_Entity
11825      (Kind       : Entity_Kind;
11826       Scope_Id   : Entity_Id;
11827       Sloc_Value : Source_Ptr;
11828       Id_Char    : Character) return Entity_Id
11829    is
11830       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
11831
11832    begin
11833       Set_Ekind          (N, Kind);
11834       Set_Is_Internal    (N, True);
11835       Append_Entity      (N, Scope_Id);
11836
11837       if Kind in Type_Kind then
11838          Init_Size_Align (N);
11839       end if;
11840
11841       return N;
11842    end New_Internal_Entity;
11843
11844    -----------------
11845    -- Next_Actual --
11846    -----------------
11847
11848    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
11849       N  : Node_Id;
11850
11851    begin
11852       --  If we are pointing at a positional parameter, it is a member of a
11853       --  node list (the list of parameters), and the next parameter is the
11854       --  next node on the list, unless we hit a parameter association, then
11855       --  we shift to using the chain whose head is the First_Named_Actual in
11856       --  the parent, and then is threaded using the Next_Named_Actual of the
11857       --  Parameter_Association. All this fiddling is because the original node
11858       --  list is in the textual call order, and what we need is the
11859       --  declaration order.
11860
11861       if Is_List_Member (Actual_Id) then
11862          N := Next (Actual_Id);
11863
11864          if Nkind (N) = N_Parameter_Association then
11865             return First_Named_Actual (Parent (Actual_Id));
11866          else
11867             return N;
11868          end if;
11869
11870       else
11871          return Next_Named_Actual (Parent (Actual_Id));
11872       end if;
11873    end Next_Actual;
11874
11875    procedure Next_Actual (Actual_Id : in out Node_Id) is
11876    begin
11877       Actual_Id := Next_Actual (Actual_Id);
11878    end Next_Actual;
11879
11880    ---------------------
11881    -- No_Scalar_Parts --
11882    ---------------------
11883
11884    function No_Scalar_Parts (T : Entity_Id) return Boolean is
11885       C : Entity_Id;
11886
11887    begin
11888       if Is_Scalar_Type (T) then
11889          return False;
11890
11891       elsif Is_Array_Type (T) then
11892          return No_Scalar_Parts (Component_Type (T));
11893
11894       elsif Is_Record_Type (T) or else Has_Discriminants (T) then
11895          C := First_Component_Or_Discriminant (T);
11896          while Present (C) loop
11897             if not No_Scalar_Parts (Etype (C)) then
11898                return False;
11899             else
11900                Next_Component_Or_Discriminant (C);
11901             end if;
11902          end loop;
11903       end if;
11904
11905       return True;
11906    end No_Scalar_Parts;
11907
11908    -----------------------
11909    -- Normalize_Actuals --
11910    -----------------------
11911
11912    --  Chain actuals according to formals of subprogram. If there are no named
11913    --  associations, the chain is simply the list of Parameter Associations,
11914    --  since the order is the same as the declaration order. If there are named
11915    --  associations, then the First_Named_Actual field in the N_Function_Call
11916    --  or N_Procedure_Call_Statement node points to the Parameter_Association
11917    --  node for the parameter that comes first in declaration order. The
11918    --  remaining named parameters are then chained in declaration order using
11919    --  Next_Named_Actual.
11920
11921    --  This routine also verifies that the number of actuals is compatible with
11922    --  the number and default values of formals, but performs no type checking
11923    --  (type checking is done by the caller).
11924
11925    --  If the matching succeeds, Success is set to True and the caller proceeds
11926    --  with type-checking. If the match is unsuccessful, then Success is set to
11927    --  False, and the caller attempts a different interpretation, if there is
11928    --  one.
11929
11930    --  If the flag Report is on, the call is not overloaded, and a failure to
11931    --  match can be reported here, rather than in the caller.
11932
11933    procedure Normalize_Actuals
11934      (N       : Node_Id;
11935       S       : Entity_Id;
11936       Report  : Boolean;
11937       Success : out Boolean)
11938    is
11939       Actuals     : constant List_Id := Parameter_Associations (N);
11940       Actual      : Node_Id := Empty;
11941       Formal      : Entity_Id;
11942       Last        : Node_Id := Empty;
11943       First_Named : Node_Id := Empty;
11944       Found       : Boolean;
11945
11946       Formals_To_Match : Integer := 0;
11947       Actuals_To_Match : Integer := 0;
11948
11949       procedure Chain (A : Node_Id);
11950       --  Add named actual at the proper place in the list, using the
11951       --  Next_Named_Actual link.
11952
11953       function Reporting return Boolean;
11954       --  Determines if an error is to be reported. To report an error, we
11955       --  need Report to be True, and also we do not report errors caused
11956       --  by calls to init procs that occur within other init procs. Such
11957       --  errors must always be cascaded errors, since if all the types are
11958       --  declared correctly, the compiler will certainly build decent calls!
11959
11960       -----------
11961       -- Chain --
11962       -----------
11963
11964       procedure Chain (A : Node_Id) is
11965       begin
11966          if No (Last) then
11967
11968             --  Call node points to first actual in list
11969
11970             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
11971
11972          else
11973             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
11974          end if;
11975
11976          Last := A;
11977          Set_Next_Named_Actual (Last, Empty);
11978       end Chain;
11979
11980       ---------------
11981       -- Reporting --
11982       ---------------
11983
11984       function Reporting return Boolean is
11985       begin
11986          if not Report then
11987             return False;
11988
11989          elsif not Within_Init_Proc then
11990             return True;
11991
11992          elsif Is_Init_Proc (Entity (Name (N))) then
11993             return False;
11994
11995          else
11996             return True;
11997          end if;
11998       end Reporting;
11999
12000    --  Start of processing for Normalize_Actuals
12001
12002    begin
12003       if Is_Access_Type (S) then
12004
12005          --  The name in the call is a function call that returns an access
12006          --  to subprogram. The designated type has the list of formals.
12007
12008          Formal := First_Formal (Designated_Type (S));
12009       else
12010          Formal := First_Formal (S);
12011       end if;
12012
12013       while Present (Formal) loop
12014          Formals_To_Match := Formals_To_Match + 1;
12015          Next_Formal (Formal);
12016       end loop;
12017
12018       --  Find if there is a named association, and verify that no positional
12019       --  associations appear after named ones.
12020
12021       if Present (Actuals) then
12022          Actual := First (Actuals);
12023       end if;
12024
12025       while Present (Actual)
12026         and then Nkind (Actual) /= N_Parameter_Association
12027       loop
12028          Actuals_To_Match := Actuals_To_Match + 1;
12029          Next (Actual);
12030       end loop;
12031
12032       if No (Actual) and Actuals_To_Match = Formals_To_Match then
12033
12034          --  Most common case: positional notation, no defaults
12035
12036          Success := True;
12037          return;
12038
12039       elsif Actuals_To_Match > Formals_To_Match then
12040
12041          --  Too many actuals: will not work
12042
12043          if Reporting then
12044             if Is_Entity_Name (Name (N)) then
12045                Error_Msg_N ("too many arguments in call to&", Name (N));
12046             else
12047                Error_Msg_N ("too many arguments in call", N);
12048             end if;
12049          end if;
12050
12051          Success := False;
12052          return;
12053       end if;
12054
12055       First_Named := Actual;
12056
12057       while Present (Actual) loop
12058          if Nkind (Actual) /= N_Parameter_Association then
12059             Error_Msg_N
12060               ("positional parameters not allowed after named ones", Actual);
12061             Success := False;
12062             return;
12063
12064          else
12065             Actuals_To_Match := Actuals_To_Match + 1;
12066          end if;
12067
12068          Next (Actual);
12069       end loop;
12070
12071       if Present (Actuals) then
12072          Actual := First (Actuals);
12073       end if;
12074
12075       Formal := First_Formal (S);
12076       while Present (Formal) loop
12077
12078          --  Match the formals in order. If the corresponding actual is
12079          --  positional, nothing to do. Else scan the list of named actuals
12080          --  to find the one with the right name.
12081
12082          if Present (Actual)
12083            and then Nkind (Actual) /= N_Parameter_Association
12084          then
12085             Next (Actual);
12086             Actuals_To_Match := Actuals_To_Match - 1;
12087             Formals_To_Match := Formals_To_Match - 1;
12088
12089          else
12090             --  For named parameters, search the list of actuals to find
12091             --  one that matches the next formal name.
12092
12093             Actual := First_Named;
12094             Found  := False;
12095             while Present (Actual) loop
12096                if Chars (Selector_Name (Actual)) = Chars (Formal) then
12097                   Found := True;
12098                   Chain (Actual);
12099                   Actuals_To_Match := Actuals_To_Match - 1;
12100                   Formals_To_Match := Formals_To_Match - 1;
12101                   exit;
12102                end if;
12103
12104                Next (Actual);
12105             end loop;
12106
12107             if not Found then
12108                if Ekind (Formal) /= E_In_Parameter
12109                  or else No (Default_Value (Formal))
12110                then
12111                   if Reporting then
12112                      if (Comes_From_Source (S)
12113                           or else Sloc (S) = Standard_Location)
12114                        and then Is_Overloadable (S)
12115                      then
12116                         if No (Actuals)
12117                           and then
12118                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
12119                              or else
12120                            (Nkind (Parent (N)) = N_Function_Call
12121                              or else
12122                             Nkind (Parent (N)) = N_Parameter_Association))
12123                           and then Ekind (S) /= E_Function
12124                         then
12125                            Set_Etype (N, Etype (S));
12126                         else
12127                            Error_Msg_Name_1 := Chars (S);
12128                            Error_Msg_Sloc := Sloc (S);
12129                            Error_Msg_NE
12130                              ("missing argument for parameter & " &
12131                                 "in call to % declared #", N, Formal);
12132                         end if;
12133
12134                      elsif Is_Overloadable (S) then
12135                         Error_Msg_Name_1 := Chars (S);
12136
12137                         --  Point to type derivation that generated the
12138                         --  operation.
12139
12140                         Error_Msg_Sloc := Sloc (Parent (S));
12141
12142                         Error_Msg_NE
12143                           ("missing argument for parameter & " &
12144                              "in call to % (inherited) #", N, Formal);
12145
12146                      else
12147                         Error_Msg_NE
12148                           ("missing argument for parameter &", N, Formal);
12149                      end if;
12150                   end if;
12151
12152                   Success := False;
12153                   return;
12154
12155                else
12156                   Formals_To_Match := Formals_To_Match - 1;
12157                end if;
12158             end if;
12159          end if;
12160
12161          Next_Formal (Formal);
12162       end loop;
12163
12164       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
12165          Success := True;
12166          return;
12167
12168       else
12169          if Reporting then
12170
12171             --  Find some superfluous named actual that did not get
12172             --  attached to the list of associations.
12173
12174             Actual := First (Actuals);
12175             while Present (Actual) loop
12176                if Nkind (Actual) = N_Parameter_Association
12177                  and then Actual /= Last
12178                  and then No (Next_Named_Actual (Actual))
12179                then
12180                   Error_Msg_N ("unmatched actual & in call",
12181                     Selector_Name (Actual));
12182                   exit;
12183                end if;
12184
12185                Next (Actual);
12186             end loop;
12187          end if;
12188
12189          Success := False;
12190          return;
12191       end if;
12192    end Normalize_Actuals;
12193
12194    --------------------------------
12195    -- Note_Possible_Modification --
12196    --------------------------------
12197
12198    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
12199       Modification_Comes_From_Source : constant Boolean :=
12200                                          Comes_From_Source (Parent (N));
12201
12202       Ent : Entity_Id;
12203       Exp : Node_Id;
12204
12205    begin
12206       --  Loop to find referenced entity, if there is one
12207
12208       Exp := N;
12209       loop
12210          <<Continue>>
12211          Ent := Empty;
12212
12213          if Is_Entity_Name (Exp) then
12214             Ent := Entity (Exp);
12215
12216             --  If the entity is missing, it is an undeclared identifier,
12217             --  and there is nothing to annotate.
12218
12219             if No (Ent) then
12220                return;
12221             end if;
12222
12223          elsif Nkind (Exp) = N_Explicit_Dereference then
12224             declare
12225                P : constant Node_Id := Prefix (Exp);
12226
12227             begin
12228                --  In formal verification mode, keep track of all reads and
12229                --  writes through explicit dereferences.
12230
12231                if SPARK_Mode then
12232                   SPARK_Specific.Generate_Dereference (N, 'm');
12233                end if;
12234
12235                if Nkind (P) = N_Selected_Component
12236                  and then
12237                    Present (Entry_Formal (Entity (Selector_Name (P))))
12238                then
12239                   --  Case of a reference to an entry formal
12240
12241                   Ent := Entry_Formal (Entity (Selector_Name (P)));
12242
12243                elsif Nkind (P) = N_Identifier
12244                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
12245                  and then Present (Expression (Parent (Entity (P))))
12246                  and then Nkind (Expression (Parent (Entity (P))))
12247                    = N_Reference
12248                then
12249                   --  Case of a reference to a value on which side effects have
12250                   --  been removed.
12251
12252                   Exp := Prefix (Expression (Parent (Entity (P))));
12253                   goto Continue;
12254
12255                else
12256                   return;
12257
12258                end if;
12259             end;
12260
12261          elsif Nkind_In (Exp, N_Type_Conversion,
12262                               N_Unchecked_Type_Conversion)
12263          then
12264             Exp := Expression (Exp);
12265             goto Continue;
12266
12267          elsif Nkind_In (Exp, N_Slice,
12268                               N_Indexed_Component,
12269                               N_Selected_Component)
12270          then
12271             Exp := Prefix (Exp);
12272             goto Continue;
12273
12274          else
12275             return;
12276          end if;
12277
12278          --  Now look for entity being referenced
12279
12280          if Present (Ent) then
12281             if Is_Object (Ent) then
12282                if Comes_From_Source (Exp)
12283                  or else Modification_Comes_From_Source
12284                then
12285                   --  Give warning if pragma unmodified given and we are
12286                   --  sure this is a modification.
12287
12288                   if Has_Pragma_Unmodified (Ent) and then Sure then
12289                      Error_Msg_NE
12290                        ("??pragma Unmodified given for &!", N, Ent);
12291                   end if;
12292
12293                   Set_Never_Set_In_Source (Ent, False);
12294                end if;
12295
12296                Set_Is_True_Constant (Ent, False);
12297                Set_Current_Value    (Ent, Empty);
12298                Set_Is_Known_Null    (Ent, False);
12299
12300                if not Can_Never_Be_Null (Ent) then
12301                   Set_Is_Known_Non_Null (Ent, False);
12302                end if;
12303
12304                --  Follow renaming chain
12305
12306                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
12307                  and then Present (Renamed_Object (Ent))
12308                then
12309                   Exp := Renamed_Object (Ent);
12310                   goto Continue;
12311
12312                --  The expression may be the renaming of a subcomponent of an
12313                --  array or container. The assignment to the subcomponent is
12314                --  a modification of the container.
12315
12316                elsif Comes_From_Source (Original_Node (Exp))
12317                  and then Nkind_In (Original_Node (Exp), N_Selected_Component,
12318                                                          N_Indexed_Component)
12319                then
12320                   Exp := Prefix (Original_Node (Exp));
12321                   goto Continue;
12322                end if;
12323
12324                --  Generate a reference only if the assignment comes from
12325                --  source. This excludes, for example, calls to a dispatching
12326                --  assignment operation when the left-hand side is tagged.
12327
12328                --  Why is SPARK mode different here ???
12329
12330                if Modification_Comes_From_Source or SPARK_Mode then
12331                   Generate_Reference (Ent, Exp, 'm');
12332
12333                   --  If the target of the assignment is the bound variable
12334                   --  in an iterator, indicate that the corresponding array
12335                   --  or container is also modified.
12336
12337                   if Ada_Version >= Ada_2012
12338                     and then
12339                       Nkind (Parent (Ent)) = N_Iterator_Specification
12340                   then
12341                      declare
12342                         Domain : constant Node_Id := Name (Parent (Ent));
12343
12344                      begin
12345                         --  TBD : in the full version of the construct, the
12346                         --  domain of iteration can be given by an expression.
12347
12348                         if Is_Entity_Name (Domain) then
12349                            Generate_Reference      (Entity (Domain), Exp, 'm');
12350                            Set_Is_True_Constant    (Entity (Domain), False);
12351                            Set_Never_Set_In_Source (Entity (Domain), False);
12352                         end if;
12353                      end;
12354                   end if;
12355                end if;
12356
12357                Check_Nested_Access (Ent);
12358             end if;
12359
12360             Kill_Checks (Ent);
12361
12362             --  If we are sure this is a modification from source, and we know
12363             --  this modifies a constant, then give an appropriate warning.
12364
12365             if Overlays_Constant (Ent)
12366               and then Modification_Comes_From_Source
12367               and then Sure
12368             then
12369                declare
12370                   A : constant Node_Id := Address_Clause (Ent);
12371                begin
12372                   if Present (A) then
12373                      declare
12374                         Exp : constant Node_Id := Expression (A);
12375                      begin
12376                         if Nkind (Exp) = N_Attribute_Reference
12377                           and then Attribute_Name (Exp) = Name_Address
12378                           and then Is_Entity_Name (Prefix (Exp))
12379                         then
12380                            Error_Msg_Sloc := Sloc (A);
12381                            Error_Msg_NE
12382                              ("constant& may be modified via address "
12383                               & "clause#??", N, Entity (Prefix (Exp)));
12384                         end if;
12385                      end;
12386                   end if;
12387                end;
12388             end if;
12389
12390             return;
12391          end if;
12392       end loop;
12393    end Note_Possible_Modification;
12394
12395    -------------------------
12396    -- Object_Access_Level --
12397    -------------------------
12398
12399    --  Returns the static accessibility level of the view denoted by Obj. Note
12400    --  that the value returned is the result of a call to Scope_Depth. Only
12401    --  scope depths associated with dynamic scopes can actually be returned.
12402    --  Since only relative levels matter for accessibility checking, the fact
12403    --  that the distance between successive levels of accessibility is not
12404    --  always one is immaterial (invariant: if level(E2) is deeper than
12405    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
12406
12407    function Object_Access_Level (Obj : Node_Id) return Uint is
12408       function Is_Interface_Conversion (N : Node_Id) return Boolean;
12409       --  Determine whether N is a construct of the form
12410       --    Some_Type (Operand._tag'Address)
12411       --  This construct appears in the context of dispatching calls.
12412
12413       function Reference_To (Obj : Node_Id) return Node_Id;
12414       --  An explicit dereference is created when removing side-effects from
12415       --  expressions for constraint checking purposes. In this case a local
12416       --  access type is created for it. The correct access level is that of
12417       --  the original source node. We detect this case by noting that the
12418       --  prefix of the dereference is created by an object declaration whose
12419       --  initial expression is a reference.
12420
12421       -----------------------------
12422       -- Is_Interface_Conversion --
12423       -----------------------------
12424
12425       function Is_Interface_Conversion (N : Node_Id) return Boolean is
12426       begin
12427          return
12428            Nkind (N) = N_Unchecked_Type_Conversion
12429              and then Nkind (Expression (N)) = N_Attribute_Reference
12430              and then Attribute_Name (Expression (N)) = Name_Address;
12431       end Is_Interface_Conversion;
12432
12433       ------------------
12434       -- Reference_To --
12435       ------------------
12436
12437       function Reference_To (Obj : Node_Id) return Node_Id is
12438          Pref : constant Node_Id := Prefix (Obj);
12439       begin
12440          if Is_Entity_Name (Pref)
12441            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
12442            and then Present (Expression (Parent (Entity (Pref))))
12443            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
12444          then
12445             return (Prefix (Expression (Parent (Entity (Pref)))));
12446          else
12447             return Empty;
12448          end if;
12449       end Reference_To;
12450
12451       --  Local variables
12452
12453       E : Entity_Id;
12454
12455    --  Start of processing for Object_Access_Level
12456
12457    begin
12458       if Nkind (Obj) = N_Defining_Identifier
12459         or else Is_Entity_Name (Obj)
12460       then
12461          if Nkind (Obj) = N_Defining_Identifier then
12462             E := Obj;
12463          else
12464             E := Entity (Obj);
12465          end if;
12466
12467          if Is_Prival (E) then
12468             E := Prival_Link (E);
12469          end if;
12470
12471          --  If E is a type then it denotes a current instance. For this case
12472          --  we add one to the normal accessibility level of the type to ensure
12473          --  that current instances are treated as always being deeper than
12474          --  than the level of any visible named access type (see 3.10.2(21)).
12475
12476          if Is_Type (E) then
12477             return Type_Access_Level (E) +  1;
12478
12479          elsif Present (Renamed_Object (E)) then
12480             return Object_Access_Level (Renamed_Object (E));
12481
12482          --  Similarly, if E is a component of the current instance of a
12483          --  protected type, any instance of it is assumed to be at a deeper
12484          --  level than the type. For a protected object (whose type is an
12485          --  anonymous protected type) its components are at the same level
12486          --  as the type itself.
12487
12488          elsif not Is_Overloadable (E)
12489            and then Ekind (Scope (E)) = E_Protected_Type
12490            and then Comes_From_Source (Scope (E))
12491          then
12492             return Type_Access_Level (Scope (E)) + 1;
12493
12494          else
12495             return Scope_Depth (Enclosing_Dynamic_Scope (E));
12496          end if;
12497
12498       elsif Nkind (Obj) = N_Selected_Component then
12499          if Is_Access_Type (Etype (Prefix (Obj))) then
12500             return Type_Access_Level (Etype (Prefix (Obj)));
12501          else
12502             return Object_Access_Level (Prefix (Obj));
12503          end if;
12504
12505       elsif Nkind (Obj) = N_Indexed_Component then
12506          if Is_Access_Type (Etype (Prefix (Obj))) then
12507             return Type_Access_Level (Etype (Prefix (Obj)));
12508          else
12509             return Object_Access_Level (Prefix (Obj));
12510          end if;
12511
12512       elsif Nkind (Obj) = N_Explicit_Dereference then
12513
12514          --  If the prefix is a selected access discriminant then we make a
12515          --  recursive call on the prefix, which will in turn check the level
12516          --  of the prefix object of the selected discriminant.
12517
12518          if Nkind (Prefix (Obj)) = N_Selected_Component
12519            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
12520            and then
12521              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
12522          then
12523             return Object_Access_Level (Prefix (Obj));
12524
12525          --  Detect an interface conversion in the context of a dispatching
12526          --  call. Use the original form of the conversion to find the access
12527          --  level of the operand.
12528
12529          elsif Is_Interface (Etype (Obj))
12530            and then Is_Interface_Conversion (Prefix (Obj))
12531            and then Nkind (Original_Node (Obj)) = N_Type_Conversion
12532          then
12533             return Object_Access_Level (Original_Node (Obj));
12534
12535          elsif not Comes_From_Source (Obj) then
12536             declare
12537                Ref : constant Node_Id := Reference_To (Obj);
12538             begin
12539                if Present (Ref) then
12540                   return Object_Access_Level (Ref);
12541                else
12542                   return Type_Access_Level (Etype (Prefix (Obj)));
12543                end if;
12544             end;
12545
12546          else
12547             return Type_Access_Level (Etype (Prefix (Obj)));
12548          end if;
12549
12550       elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
12551          return Object_Access_Level (Expression (Obj));
12552
12553       elsif Nkind (Obj) = N_Function_Call then
12554
12555          --  Function results are objects, so we get either the access level of
12556          --  the function or, in the case of an indirect call, the level of the
12557          --  access-to-subprogram type. (This code is used for Ada 95, but it
12558          --  looks wrong, because it seems that we should be checking the level
12559          --  of the call itself, even for Ada 95. However, using the Ada 2005
12560          --  version of the code causes regressions in several tests that are
12561          --  compiled with -gnat95. ???)
12562
12563          if Ada_Version < Ada_2005 then
12564             if Is_Entity_Name (Name (Obj)) then
12565                return Subprogram_Access_Level (Entity (Name (Obj)));
12566             else
12567                return Type_Access_Level (Etype (Prefix (Name (Obj))));
12568             end if;
12569
12570          --  For Ada 2005, the level of the result object of a function call is
12571          --  defined to be the level of the call's innermost enclosing master.
12572          --  We determine that by querying the depth of the innermost enclosing
12573          --  dynamic scope.
12574
12575          else
12576             Return_Master_Scope_Depth_Of_Call : declare
12577
12578                function Innermost_Master_Scope_Depth
12579                  (N : Node_Id) return Uint;
12580                --  Returns the scope depth of the given node's innermost
12581                --  enclosing dynamic scope (effectively the accessibility
12582                --  level of the innermost enclosing master).
12583
12584                ----------------------------------
12585                -- Innermost_Master_Scope_Depth --
12586                ----------------------------------
12587
12588                function Innermost_Master_Scope_Depth
12589                  (N : Node_Id) return Uint
12590                is
12591                   Node_Par : Node_Id := Parent (N);
12592
12593                begin
12594                   --  Locate the nearest enclosing node (by traversing Parents)
12595                   --  that Defining_Entity can be applied to, and return the
12596                   --  depth of that entity's nearest enclosing dynamic scope.
12597
12598                   while Present (Node_Par) loop
12599                      case Nkind (Node_Par) is
12600                         when N_Component_Declaration           |
12601                              N_Entry_Declaration               |
12602                              N_Formal_Object_Declaration       |
12603                              N_Formal_Type_Declaration         |
12604                              N_Full_Type_Declaration           |
12605                              N_Incomplete_Type_Declaration     |
12606                              N_Loop_Parameter_Specification    |
12607                              N_Object_Declaration              |
12608                              N_Protected_Type_Declaration      |
12609                              N_Private_Extension_Declaration   |
12610                              N_Private_Type_Declaration        |
12611                              N_Subtype_Declaration             |
12612                              N_Function_Specification          |
12613                              N_Procedure_Specification         |
12614                              N_Task_Type_Declaration           |
12615                              N_Body_Stub                       |
12616                              N_Generic_Instantiation           |
12617                              N_Proper_Body                     |
12618                              N_Implicit_Label_Declaration      |
12619                              N_Package_Declaration             |
12620                              N_Single_Task_Declaration         |
12621                              N_Subprogram_Declaration          |
12622                              N_Generic_Declaration             |
12623                              N_Renaming_Declaration            |
12624                              N_Block_Statement                 |
12625                              N_Formal_Subprogram_Declaration   |
12626                              N_Abstract_Subprogram_Declaration |
12627                              N_Entry_Body                      |
12628                              N_Exception_Declaration           |
12629                              N_Formal_Package_Declaration      |
12630                              N_Number_Declaration              |
12631                              N_Package_Specification           |
12632                              N_Parameter_Specification         |
12633                              N_Single_Protected_Declaration    |
12634                              N_Subunit                         =>
12635
12636                            return Scope_Depth
12637                                     (Nearest_Dynamic_Scope
12638                                        (Defining_Entity (Node_Par)));
12639
12640                         when others =>
12641                            null;
12642                      end case;
12643
12644                      Node_Par := Parent (Node_Par);
12645                   end loop;
12646
12647                   pragma Assert (False);
12648
12649                   --  Should never reach the following return
12650
12651                   return Scope_Depth (Current_Scope) + 1;
12652                end Innermost_Master_Scope_Depth;
12653
12654             --  Start of processing for Return_Master_Scope_Depth_Of_Call
12655
12656             begin
12657                return Innermost_Master_Scope_Depth (Obj);
12658             end Return_Master_Scope_Depth_Of_Call;
12659          end if;
12660
12661       --  For convenience we handle qualified expressions, even though they
12662       --  aren't technically object names.
12663
12664       elsif Nkind (Obj) = N_Qualified_Expression then
12665          return Object_Access_Level (Expression (Obj));
12666
12667       --  Otherwise return the scope level of Standard. (If there are cases
12668       --  that fall through to this point they will be treated as having
12669       --  global accessibility for now. ???)
12670
12671       else
12672          return Scope_Depth (Standard_Standard);
12673       end if;
12674    end Object_Access_Level;
12675
12676    --------------------------------------
12677    -- Original_Corresponding_Operation --
12678    --------------------------------------
12679
12680    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
12681    is
12682       Typ : constant Entity_Id := Find_Dispatching_Type (S);
12683
12684    begin
12685       --  If S is an inherited primitive S2 the original corresponding
12686       --  operation of S is the original corresponding operation of S2
12687
12688       if Present (Alias (S))
12689         and then Find_Dispatching_Type (Alias (S)) /= Typ
12690       then
12691          return Original_Corresponding_Operation (Alias (S));
12692
12693       --  If S overrides an inherited subprogram S2 the original corresponding
12694       --  operation of S is the original corresponding operation of S2
12695
12696       elsif Present (Overridden_Operation (S)) then
12697          return Original_Corresponding_Operation (Overridden_Operation (S));
12698
12699       --  otherwise it is S itself
12700
12701       else
12702          return S;
12703       end if;
12704    end Original_Corresponding_Operation;
12705
12706    -----------------------
12707    -- Private_Component --
12708    -----------------------
12709
12710    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
12711       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
12712
12713       function Trace_Components
12714         (T     : Entity_Id;
12715          Check : Boolean) return Entity_Id;
12716       --  Recursive function that does the work, and checks against circular
12717       --  definition for each subcomponent type.
12718
12719       ----------------------
12720       -- Trace_Components --
12721       ----------------------
12722
12723       function Trace_Components
12724          (T     : Entity_Id;
12725           Check : Boolean) return Entity_Id
12726        is
12727          Btype     : constant Entity_Id := Base_Type (T);
12728          Component : Entity_Id;
12729          P         : Entity_Id;
12730          Candidate : Entity_Id := Empty;
12731
12732       begin
12733          if Check and then Btype = Ancestor then
12734             Error_Msg_N ("circular type definition", Type_Id);
12735             return Any_Type;
12736          end if;
12737
12738          if Is_Private_Type (Btype)
12739            and then not Is_Generic_Type (Btype)
12740          then
12741             if Present (Full_View (Btype))
12742               and then Is_Record_Type (Full_View (Btype))
12743               and then not Is_Frozen (Btype)
12744             then
12745                --  To indicate that the ancestor depends on a private type, the
12746                --  current Btype is sufficient. However, to check for circular
12747                --  definition we must recurse on the full view.
12748
12749                Candidate := Trace_Components (Full_View (Btype), True);
12750
12751                if Candidate = Any_Type then
12752                   return Any_Type;
12753                else
12754                   return Btype;
12755                end if;
12756
12757             else
12758                return Btype;
12759             end if;
12760
12761          elsif Is_Array_Type (Btype) then
12762             return Trace_Components (Component_Type (Btype), True);
12763
12764          elsif Is_Record_Type (Btype) then
12765             Component := First_Entity (Btype);
12766             while Present (Component)
12767               and then Comes_From_Source (Component)
12768             loop
12769                --  Skip anonymous types generated by constrained components
12770
12771                if not Is_Type (Component) then
12772                   P := Trace_Components (Etype (Component), True);
12773
12774                   if Present (P) then
12775                      if P = Any_Type then
12776                         return P;
12777                      else
12778                         Candidate := P;
12779                      end if;
12780                   end if;
12781                end if;
12782
12783                Next_Entity (Component);
12784             end loop;
12785
12786             return Candidate;
12787
12788          else
12789             return Empty;
12790          end if;
12791       end Trace_Components;
12792
12793    --  Start of processing for Private_Component
12794
12795    begin
12796       return Trace_Components (Type_Id, False);
12797    end Private_Component;
12798
12799    ---------------------------
12800    -- Primitive_Names_Match --
12801    ---------------------------
12802
12803    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
12804
12805       function Non_Internal_Name (E : Entity_Id) return Name_Id;
12806       --  Given an internal name, returns the corresponding non-internal name
12807
12808       ------------------------
12809       --  Non_Internal_Name --
12810       ------------------------
12811
12812       function Non_Internal_Name (E : Entity_Id) return Name_Id is
12813       begin
12814          Get_Name_String (Chars (E));
12815          Name_Len := Name_Len - 1;
12816          return Name_Find;
12817       end Non_Internal_Name;
12818
12819    --  Start of processing for Primitive_Names_Match
12820
12821    begin
12822       pragma Assert (Present (E1) and then Present (E2));
12823
12824       return Chars (E1) = Chars (E2)
12825         or else
12826            (not Is_Internal_Name (Chars (E1))
12827               and then Is_Internal_Name (Chars (E2))
12828               and then Non_Internal_Name (E2) = Chars (E1))
12829         or else
12830            (not Is_Internal_Name (Chars (E2))
12831               and then Is_Internal_Name (Chars (E1))
12832               and then Non_Internal_Name (E1) = Chars (E2))
12833         or else
12834            (Is_Predefined_Dispatching_Operation (E1)
12835               and then Is_Predefined_Dispatching_Operation (E2)
12836               and then Same_TSS (E1, E2))
12837         or else
12838            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
12839    end Primitive_Names_Match;
12840
12841    -----------------------
12842    -- Process_End_Label --
12843    -----------------------
12844
12845    procedure Process_End_Label
12846      (N   : Node_Id;
12847       Typ : Character;
12848       Ent : Entity_Id)
12849    is
12850       Loc  : Source_Ptr;
12851       Nam  : Node_Id;
12852       Scop : Entity_Id;
12853
12854       Label_Ref : Boolean;
12855       --  Set True if reference to end label itself is required
12856
12857       Endl : Node_Id;
12858       --  Gets set to the operator symbol or identifier that references the
12859       --  entity Ent. For the child unit case, this is the identifier from the
12860       --  designator. For other cases, this is simply Endl.
12861
12862       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
12863       --  N is an identifier node that appears as a parent unit reference in
12864       --  the case where Ent is a child unit. This procedure generates an
12865       --  appropriate cross-reference entry. E is the corresponding entity.
12866
12867       -------------------------
12868       -- Generate_Parent_Ref --
12869       -------------------------
12870
12871       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
12872       begin
12873          --  If names do not match, something weird, skip reference
12874
12875          if Chars (E) = Chars (N) then
12876
12877             --  Generate the reference. We do NOT consider this as a reference
12878             --  for unreferenced symbol purposes.
12879
12880             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
12881
12882             if Style_Check then
12883                Style.Check_Identifier (N, E);
12884             end if;
12885          end if;
12886       end Generate_Parent_Ref;
12887
12888    --  Start of processing for Process_End_Label
12889
12890    begin
12891       --  If no node, ignore. This happens in some error situations, and
12892       --  also for some internally generated structures where no end label
12893       --  references are required in any case.
12894
12895       if No (N) then
12896          return;
12897       end if;
12898
12899       --  Nothing to do if no End_Label, happens for internally generated
12900       --  constructs where we don't want an end label reference anyway. Also
12901       --  nothing to do if Endl is a string literal, which means there was
12902       --  some prior error (bad operator symbol)
12903
12904       Endl := End_Label (N);
12905
12906       if No (Endl) or else Nkind (Endl) = N_String_Literal then
12907          return;
12908       end if;
12909
12910       --  Reference node is not in extended main source unit
12911
12912       if not In_Extended_Main_Source_Unit (N) then
12913
12914          --  Generally we do not collect references except for the extended
12915          --  main source unit. The one exception is the 'e' entry for a
12916          --  package spec, where it is useful for a client to have the
12917          --  ending information to define scopes.
12918
12919          if Typ /= 'e' then
12920             return;
12921
12922          else
12923             Label_Ref := False;
12924
12925             --  For this case, we can ignore any parent references, but we
12926             --  need the package name itself for the 'e' entry.
12927
12928             if Nkind (Endl) = N_Designator then
12929                Endl := Identifier (Endl);
12930             end if;
12931          end if;
12932
12933       --  Reference is in extended main source unit
12934
12935       else
12936          Label_Ref := True;
12937
12938          --  For designator, generate references for the parent entries
12939
12940          if Nkind (Endl) = N_Designator then
12941
12942             --  Generate references for the prefix if the END line comes from
12943             --  source (otherwise we do not need these references) We climb the
12944             --  scope stack to find the expected entities.
12945
12946             if Comes_From_Source (Endl) then
12947                Nam  := Name (Endl);
12948                Scop := Current_Scope;
12949                while Nkind (Nam) = N_Selected_Component loop
12950                   Scop := Scope (Scop);
12951                   exit when No (Scop);
12952                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
12953                   Nam := Prefix (Nam);
12954                end loop;
12955
12956                if Present (Scop) then
12957                   Generate_Parent_Ref (Nam, Scope (Scop));
12958                end if;
12959             end if;
12960
12961             Endl := Identifier (Endl);
12962          end if;
12963       end if;
12964
12965       --  If the end label is not for the given entity, then either we have
12966       --  some previous error, or this is a generic instantiation for which
12967       --  we do not need to make a cross-reference in this case anyway. In
12968       --  either case we simply ignore the call.
12969
12970       if Chars (Ent) /= Chars (Endl) then
12971          return;
12972       end if;
12973
12974       --  If label was really there, then generate a normal reference and then
12975       --  adjust the location in the end label to point past the name (which
12976       --  should almost always be the semicolon).
12977
12978       Loc := Sloc (Endl);
12979
12980       if Comes_From_Source (Endl) then
12981
12982          --  If a label reference is required, then do the style check and
12983          --  generate an l-type cross-reference entry for the label
12984
12985          if Label_Ref then
12986             if Style_Check then
12987                Style.Check_Identifier (Endl, Ent);
12988             end if;
12989
12990             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
12991          end if;
12992
12993          --  Set the location to point past the label (normally this will
12994          --  mean the semicolon immediately following the label). This is
12995          --  done for the sake of the 'e' or 't' entry generated below.
12996
12997          Get_Decoded_Name_String (Chars (Endl));
12998          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
12999
13000       else
13001          --  In SPARK mode, no missing label is allowed for packages and
13002          --  subprogram bodies. Detect those cases by testing whether
13003          --  Process_End_Label was called for a body (Typ = 't') or a package.
13004
13005          if Restriction_Check_Required (SPARK_05)
13006            and then (Typ = 't' or else Ekind (Ent) = E_Package)
13007          then
13008             Error_Msg_Node_1 := Endl;
13009             Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
13010          end if;
13011       end if;
13012
13013       --  Now generate the e/t reference
13014
13015       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
13016
13017       --  Restore Sloc, in case modified above, since we have an identifier
13018       --  and the normal Sloc should be left set in the tree.
13019
13020       Set_Sloc (Endl, Loc);
13021    end Process_End_Label;
13022
13023    ----------------
13024    -- Referenced --
13025    ----------------
13026
13027    function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
13028       Seen : Boolean := False;
13029
13030       function Is_Reference (N : Node_Id) return Traverse_Result;
13031       --  Determine whether node N denotes a reference to Id. If this is the
13032       --  case, set global flag Seen to True and stop the traversal.
13033
13034       ------------------
13035       -- Is_Reference --
13036       ------------------
13037
13038       function Is_Reference (N : Node_Id) return Traverse_Result is
13039       begin
13040          if Is_Entity_Name (N)
13041            and then Present (Entity (N))
13042            and then Entity (N) = Id
13043          then
13044             Seen := True;
13045             return Abandon;
13046          else
13047             return OK;
13048          end if;
13049       end Is_Reference;
13050
13051       procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
13052
13053    --  Start of processing for Referenced
13054
13055    begin
13056       Inspect_Expression (Expr);
13057       return Seen;
13058    end Referenced;
13059
13060    ------------------------------------
13061    -- References_Generic_Formal_Type --
13062    ------------------------------------
13063
13064    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
13065
13066       function Process (N : Node_Id) return Traverse_Result;
13067       --  Process one node in search for generic formal type
13068
13069       -------------
13070       -- Process --
13071       -------------
13072
13073       function Process (N : Node_Id) return Traverse_Result is
13074       begin
13075          if Nkind (N) in N_Has_Entity then
13076             declare
13077                E : constant Entity_Id := Entity (N);
13078             begin
13079                if Present (E) then
13080                   if Is_Generic_Type (E) then
13081                      return Abandon;
13082                   elsif Present (Etype (E))
13083                     and then Is_Generic_Type (Etype (E))
13084                   then
13085                      return Abandon;
13086                   end if;
13087                end if;
13088             end;
13089          end if;
13090
13091          return Atree.OK;
13092       end Process;
13093
13094       function Traverse is new Traverse_Func (Process);
13095       --  Traverse tree to look for generic type
13096
13097    begin
13098       if Inside_A_Generic then
13099          return Traverse (N) = Abandon;
13100       else
13101          return False;
13102       end if;
13103    end References_Generic_Formal_Type;
13104
13105    --------------------
13106    -- Remove_Homonym --
13107    --------------------
13108
13109    procedure Remove_Homonym (E : Entity_Id) is
13110       Prev  : Entity_Id := Empty;
13111       H     : Entity_Id;
13112
13113    begin
13114       if E = Current_Entity (E) then
13115          if Present (Homonym (E)) then
13116             Set_Current_Entity (Homonym (E));
13117          else
13118             Set_Name_Entity_Id (Chars (E), Empty);
13119          end if;
13120
13121       else
13122          H := Current_Entity (E);
13123          while Present (H) and then H /= E loop
13124             Prev := H;
13125             H    := Homonym (H);
13126          end loop;
13127
13128          --  If E is not on the homonym chain, nothing to do
13129
13130          if Present (H) then
13131             Set_Homonym (Prev, Homonym (E));
13132          end if;
13133       end if;
13134    end Remove_Homonym;
13135
13136    ---------------------
13137    -- Rep_To_Pos_Flag --
13138    ---------------------
13139
13140    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
13141    begin
13142       return New_Occurrence_Of
13143                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
13144    end Rep_To_Pos_Flag;
13145
13146    --------------------
13147    -- Require_Entity --
13148    --------------------
13149
13150    procedure Require_Entity (N : Node_Id) is
13151    begin
13152       if Is_Entity_Name (N) and then No (Entity (N)) then
13153          if Total_Errors_Detected /= 0 then
13154             Set_Entity (N, Any_Id);
13155          else
13156             raise Program_Error;
13157          end if;
13158       end if;
13159    end Require_Entity;
13160
13161    ------------------------------
13162    -- Requires_Transient_Scope --
13163    ------------------------------
13164
13165    --  A transient scope is required when variable-sized temporaries are
13166    --  allocated in the primary or secondary stack, or when finalization
13167    --  actions must be generated before the next instruction.
13168
13169    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
13170       Typ : constant Entity_Id := Underlying_Type (Id);
13171
13172    --  Start of processing for Requires_Transient_Scope
13173
13174    begin
13175       --  This is a private type which is not completed yet. This can only
13176       --  happen in a default expression (of a formal parameter or of a
13177       --  record component). Do not expand transient scope in this case
13178
13179       if No (Typ) then
13180          return False;
13181
13182       --  Do not expand transient scope for non-existent procedure return
13183
13184       elsif Typ = Standard_Void_Type then
13185          return False;
13186
13187       --  Elementary types do not require a transient scope
13188
13189       elsif Is_Elementary_Type (Typ) then
13190          return False;
13191
13192       --  Generally, indefinite subtypes require a transient scope, since the
13193       --  back end cannot generate temporaries, since this is not a valid type
13194       --  for declaring an object. It might be possible to relax this in the
13195       --  future, e.g. by declaring the maximum possible space for the type.
13196
13197       elsif Is_Indefinite_Subtype (Typ) then
13198          return True;
13199
13200       --  Functions returning tagged types may dispatch on result so their
13201       --  returned value is allocated on the secondary stack. Controlled
13202       --  type temporaries need finalization.
13203
13204       elsif Is_Tagged_Type (Typ)
13205         or else Has_Controlled_Component (Typ)
13206       then
13207          return not Is_Value_Type (Typ);
13208
13209       --  Record type
13210
13211       elsif Is_Record_Type (Typ) then
13212          declare
13213             Comp : Entity_Id;
13214          begin
13215             Comp := First_Entity (Typ);
13216             while Present (Comp) loop
13217                if Ekind (Comp) = E_Component
13218                   and then Requires_Transient_Scope (Etype (Comp))
13219                then
13220                   return True;
13221                else
13222                   Next_Entity (Comp);
13223                end if;
13224             end loop;
13225          end;
13226
13227          return False;
13228
13229       --  String literal types never require transient scope
13230
13231       elsif Ekind (Typ) = E_String_Literal_Subtype then
13232          return False;
13233
13234       --  Array type. Note that we already know that this is a constrained
13235       --  array, since unconstrained arrays will fail the indefinite test.
13236
13237       elsif Is_Array_Type (Typ) then
13238
13239          --  If component type requires a transient scope, the array does too
13240
13241          if Requires_Transient_Scope (Component_Type (Typ)) then
13242             return True;
13243
13244          --  Otherwise, we only need a transient scope if the size depends on
13245          --  the value of one or more discriminants.
13246
13247          else
13248             return Size_Depends_On_Discriminant (Typ);
13249          end if;
13250
13251       --  All other cases do not require a transient scope
13252
13253       else
13254          return False;
13255       end if;
13256    end Requires_Transient_Scope;
13257
13258    --------------------------
13259    -- Reset_Analyzed_Flags --
13260    --------------------------
13261
13262    procedure Reset_Analyzed_Flags (N : Node_Id) is
13263
13264       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
13265       --  Function used to reset Analyzed flags in tree. Note that we do
13266       --  not reset Analyzed flags in entities, since there is no need to
13267       --  reanalyze entities, and indeed, it is wrong to do so, since it
13268       --  can result in generating auxiliary stuff more than once.
13269
13270       --------------------
13271       -- Clear_Analyzed --
13272       --------------------
13273
13274       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
13275       begin
13276          if not Has_Extension (N) then
13277             Set_Analyzed (N, False);
13278          end if;
13279
13280          return OK;
13281       end Clear_Analyzed;
13282
13283       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
13284
13285    --  Start of processing for Reset_Analyzed_Flags
13286
13287    begin
13288       Reset_Analyzed (N);
13289    end Reset_Analyzed_Flags;
13290
13291    --------------------------------
13292    -- Returns_Unconstrained_Type --
13293    --------------------------------
13294
13295    function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
13296    begin
13297       return Ekind (Subp) = E_Function
13298         and then not Is_Scalar_Type (Etype (Subp))
13299         and then not Is_Access_Type (Etype (Subp))
13300         and then not Is_Constrained (Etype (Subp));
13301    end Returns_Unconstrained_Type;
13302
13303    ---------------------------
13304    -- Safe_To_Capture_Value --
13305    ---------------------------
13306
13307    function Safe_To_Capture_Value
13308      (N    : Node_Id;
13309       Ent  : Entity_Id;
13310       Cond : Boolean := False) return Boolean
13311    is
13312    begin
13313       --  The only entities for which we track constant values are variables
13314       --  which are not renamings, constants, out parameters, and in out
13315       --  parameters, so check if we have this case.
13316
13317       --  Note: it may seem odd to track constant values for constants, but in
13318       --  fact this routine is used for other purposes than simply capturing
13319       --  the value. In particular, the setting of Known[_Non]_Null.
13320
13321       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
13322             or else
13323           Ekind (Ent) = E_Constant
13324             or else
13325           Ekind (Ent) = E_Out_Parameter
13326             or else
13327           Ekind (Ent) = E_In_Out_Parameter
13328       then
13329          null;
13330
13331       --  For conditionals, we also allow loop parameters and all formals,
13332       --  including in parameters.
13333
13334       elsif Cond
13335         and then
13336           (Ekind (Ent) = E_Loop_Parameter
13337              or else
13338            Ekind (Ent) = E_In_Parameter)
13339       then
13340          null;
13341
13342       --  For all other cases, not just unsafe, but impossible to capture
13343       --  Current_Value, since the above are the only entities which have
13344       --  Current_Value fields.
13345
13346       else
13347          return False;
13348       end if;
13349
13350       --  Skip if volatile or aliased, since funny things might be going on in
13351       --  these cases which we cannot necessarily track. Also skip any variable
13352       --  for which an address clause is given, or whose address is taken. Also
13353       --  never capture value of library level variables (an attempt to do so
13354       --  can occur in the case of package elaboration code).
13355
13356       if Treat_As_Volatile (Ent)
13357         or else Is_Aliased (Ent)
13358         or else Present (Address_Clause (Ent))
13359         or else Address_Taken (Ent)
13360         or else (Is_Library_Level_Entity (Ent)
13361                    and then Ekind (Ent) = E_Variable)
13362       then
13363          return False;
13364       end if;
13365
13366       --  OK, all above conditions are met. We also require that the scope of
13367       --  the reference be the same as the scope of the entity, not counting
13368       --  packages and blocks and loops.
13369
13370       declare
13371          E_Scope : constant Entity_Id := Scope (Ent);
13372          R_Scope : Entity_Id;
13373
13374       begin
13375          R_Scope := Current_Scope;
13376          while R_Scope /= Standard_Standard loop
13377             exit when R_Scope = E_Scope;
13378
13379             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
13380                return False;
13381             else
13382                R_Scope := Scope (R_Scope);
13383             end if;
13384          end loop;
13385       end;
13386
13387       --  We also require that the reference does not appear in a context
13388       --  where it is not sure to be executed (i.e. a conditional context
13389       --  or an exception handler). We skip this if Cond is True, since the
13390       --  capturing of values from conditional tests handles this ok.
13391
13392       if Cond then
13393          return True;
13394       end if;
13395
13396       declare
13397          Desc : Node_Id;
13398          P    : Node_Id;
13399
13400       begin
13401          Desc := N;
13402
13403          --  Seems dubious that case expressions are not handled here ???
13404
13405          P := Parent (N);
13406          while Present (P) loop
13407             if         Nkind (P) = N_If_Statement
13408               or else  Nkind (P) = N_Case_Statement
13409               or else (Nkind (P) in N_Short_Circuit
13410                          and then Desc = Right_Opnd (P))
13411               or else (Nkind (P) = N_If_Expression
13412                          and then Desc /= First (Expressions (P)))
13413               or else  Nkind (P) = N_Exception_Handler
13414               or else  Nkind (P) = N_Selective_Accept
13415               or else  Nkind (P) = N_Conditional_Entry_Call
13416               or else  Nkind (P) = N_Timed_Entry_Call
13417               or else  Nkind (P) = N_Asynchronous_Select
13418             then
13419                return False;
13420             else
13421                Desc := P;
13422                P    := Parent (P);
13423
13424                --  A special Ada 2012 case: the original node may be part
13425                --  of the else_actions of a conditional expression, in which
13426                --  case it might not have been expanded yet, and appears in
13427                --  a non-syntactic list of actions. In that case it is clearly
13428                --  not safe to save a value.
13429
13430                if No (P)
13431                  and then Is_List_Member (Desc)
13432                  and then No (Parent (List_Containing (Desc)))
13433                then
13434                   return False;
13435                end if;
13436             end if;
13437          end loop;
13438       end;
13439
13440       --  OK, looks safe to set value
13441
13442       return True;
13443    end Safe_To_Capture_Value;
13444
13445    ---------------
13446    -- Same_Name --
13447    ---------------
13448
13449    function Same_Name (N1, N2 : Node_Id) return Boolean is
13450       K1 : constant Node_Kind := Nkind (N1);
13451       K2 : constant Node_Kind := Nkind (N2);
13452
13453    begin
13454       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
13455         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
13456       then
13457          return Chars (N1) = Chars (N2);
13458
13459       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
13460         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
13461       then
13462          return Same_Name (Selector_Name (N1), Selector_Name (N2))
13463            and then Same_Name (Prefix (N1), Prefix (N2));
13464
13465       else
13466          return False;
13467       end if;
13468    end Same_Name;
13469
13470    -----------------
13471    -- Same_Object --
13472    -----------------
13473
13474    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
13475       N1 : constant Node_Id := Original_Node (Node1);
13476       N2 : constant Node_Id := Original_Node (Node2);
13477       --  We do the tests on original nodes, since we are most interested
13478       --  in the original source, not any expansion that got in the way.
13479
13480       K1 : constant Node_Kind := Nkind (N1);
13481       K2 : constant Node_Kind := Nkind (N2);
13482
13483    begin
13484       --  First case, both are entities with same entity
13485
13486       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
13487          declare
13488             EN1 : constant Entity_Id := Entity (N1);
13489             EN2 : constant Entity_Id := Entity (N2);
13490          begin
13491             if Present (EN1) and then Present (EN2)
13492               and then (Ekind_In (EN1, E_Variable, E_Constant)
13493                          or else Is_Formal (EN1))
13494               and then EN1 = EN2
13495             then
13496                return True;
13497             end if;
13498          end;
13499       end if;
13500
13501       --  Second case, selected component with same selector, same record
13502
13503       if K1 = N_Selected_Component
13504         and then K2 = N_Selected_Component
13505         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
13506       then
13507          return Same_Object (Prefix (N1), Prefix (N2));
13508
13509       --  Third case, indexed component with same subscripts, same array
13510
13511       elsif K1 = N_Indexed_Component
13512         and then K2 = N_Indexed_Component
13513         and then Same_Object (Prefix (N1), Prefix (N2))
13514       then
13515          declare
13516             E1, E2 : Node_Id;
13517          begin
13518             E1 := First (Expressions (N1));
13519             E2 := First (Expressions (N2));
13520             while Present (E1) loop
13521                if not Same_Value (E1, E2) then
13522                   return False;
13523                else
13524                   Next (E1);
13525                   Next (E2);
13526                end if;
13527             end loop;
13528
13529             return True;
13530          end;
13531
13532       --  Fourth case, slice of same array with same bounds
13533
13534       elsif K1 = N_Slice
13535         and then K2 = N_Slice
13536         and then Nkind (Discrete_Range (N1)) = N_Range
13537         and then Nkind (Discrete_Range (N2)) = N_Range
13538         and then Same_Value (Low_Bound (Discrete_Range (N1)),
13539                              Low_Bound (Discrete_Range (N2)))
13540         and then Same_Value (High_Bound (Discrete_Range (N1)),
13541                              High_Bound (Discrete_Range (N2)))
13542       then
13543          return Same_Name (Prefix (N1), Prefix (N2));
13544
13545       --  All other cases, not clearly the same object
13546
13547       else
13548          return False;
13549       end if;
13550    end Same_Object;
13551
13552    ---------------
13553    -- Same_Type --
13554    ---------------
13555
13556    function Same_Type (T1, T2 : Entity_Id) return Boolean is
13557    begin
13558       if T1 = T2 then
13559          return True;
13560
13561       elsif not Is_Constrained (T1)
13562         and then not Is_Constrained (T2)
13563         and then Base_Type (T1) = Base_Type (T2)
13564       then
13565          return True;
13566
13567       --  For now don't bother with case of identical constraints, to be
13568       --  fiddled with later on perhaps (this is only used for optimization
13569       --  purposes, so it is not critical to do a best possible job)
13570
13571       else
13572          return False;
13573       end if;
13574    end Same_Type;
13575
13576    ----------------
13577    -- Same_Value --
13578    ----------------
13579
13580    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
13581    begin
13582       if Compile_Time_Known_Value (Node1)
13583         and then Compile_Time_Known_Value (Node2)
13584         and then Expr_Value (Node1) = Expr_Value (Node2)
13585       then
13586          return True;
13587       elsif Same_Object (Node1, Node2) then
13588          return True;
13589       else
13590          return False;
13591       end if;
13592    end Same_Value;
13593
13594    ------------------------
13595    -- Scope_Is_Transient --
13596    ------------------------
13597
13598    function Scope_Is_Transient return Boolean is
13599    begin
13600       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
13601    end Scope_Is_Transient;
13602
13603    ------------------
13604    -- Scope_Within --
13605    ------------------
13606
13607    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
13608       Scop : Entity_Id;
13609
13610    begin
13611       Scop := Scope1;
13612       while Scop /= Standard_Standard loop
13613          Scop := Scope (Scop);
13614
13615          if Scop = Scope2 then
13616             return True;
13617          end if;
13618       end loop;
13619
13620       return False;
13621    end Scope_Within;
13622
13623    --------------------------
13624    -- Scope_Within_Or_Same --
13625    --------------------------
13626
13627    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
13628       Scop : Entity_Id;
13629
13630    begin
13631       Scop := Scope1;
13632       while Scop /= Standard_Standard loop
13633          if Scop = Scope2 then
13634             return True;
13635          else
13636             Scop := Scope (Scop);
13637          end if;
13638       end loop;
13639
13640       return False;
13641    end Scope_Within_Or_Same;
13642
13643    --------------------
13644    -- Set_Convention --
13645    --------------------
13646
13647    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
13648    begin
13649       Basic_Set_Convention (E, Val);
13650
13651       if Is_Type (E)
13652         and then Is_Access_Subprogram_Type (Base_Type (E))
13653         and then Has_Foreign_Convention (E)
13654       then
13655          Set_Can_Use_Internal_Rep (E, False);
13656       end if;
13657    end Set_Convention;
13658
13659    ------------------------
13660    -- Set_Current_Entity --
13661    ------------------------
13662
13663    --  The given entity is to be set as the currently visible definition of its
13664    --  associated name (i.e. the Node_Id associated with its name). All we have
13665    --  to do is to get the name from the identifier, and then set the
13666    --  associated Node_Id to point to the given entity.
13667
13668    procedure Set_Current_Entity (E : Entity_Id) is
13669    begin
13670       Set_Name_Entity_Id (Chars (E), E);
13671    end Set_Current_Entity;
13672
13673    ---------------------------
13674    -- Set_Debug_Info_Needed --
13675    ---------------------------
13676
13677    procedure Set_Debug_Info_Needed (T : Entity_Id) is
13678
13679       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
13680       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
13681       --  Used to set debug info in a related node if not set already
13682
13683       --------------------------------------
13684       -- Set_Debug_Info_Needed_If_Not_Set --
13685       --------------------------------------
13686
13687       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
13688       begin
13689          if Present (E)
13690            and then not Needs_Debug_Info (E)
13691          then
13692             Set_Debug_Info_Needed (E);
13693
13694             --  For a private type, indicate that the full view also needs
13695             --  debug information.
13696
13697             if Is_Type (E)
13698               and then Is_Private_Type (E)
13699               and then Present (Full_View (E))
13700             then
13701                Set_Debug_Info_Needed (Full_View (E));
13702             end if;
13703          end if;
13704       end Set_Debug_Info_Needed_If_Not_Set;
13705
13706    --  Start of processing for Set_Debug_Info_Needed
13707
13708    begin
13709       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
13710       --  indicates that Debug_Info_Needed is never required for the entity.
13711
13712       if No (T)
13713         or else Debug_Info_Off (T)
13714       then
13715          return;
13716       end if;
13717
13718       --  Set flag in entity itself. Note that we will go through the following
13719       --  circuitry even if the flag is already set on T. That's intentional,
13720       --  it makes sure that the flag will be set in subsidiary entities.
13721
13722       Set_Needs_Debug_Info (T);
13723
13724       --  Set flag on subsidiary entities if not set already
13725
13726       if Is_Object (T) then
13727          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
13728
13729       elsif Is_Type (T) then
13730          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
13731
13732          if Is_Record_Type (T) then
13733             declare
13734                Ent : Entity_Id := First_Entity (T);
13735             begin
13736                while Present (Ent) loop
13737                   Set_Debug_Info_Needed_If_Not_Set (Ent);
13738                   Next_Entity (Ent);
13739                end loop;
13740             end;
13741
13742             --  For a class wide subtype, we also need debug information
13743             --  for the equivalent type.
13744
13745             if Ekind (T) = E_Class_Wide_Subtype then
13746                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
13747             end if;
13748
13749          elsif Is_Array_Type (T) then
13750             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
13751
13752             declare
13753                Indx : Node_Id := First_Index (T);
13754             begin
13755                while Present (Indx) loop
13756                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
13757                   Indx := Next_Index (Indx);
13758                end loop;
13759             end;
13760
13761             --  For a packed array type, we also need debug information for
13762             --  the type used to represent the packed array. Conversely, we
13763             --  also need it for the former if we need it for the latter.
13764
13765             if Is_Packed (T) then
13766                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
13767             end if;
13768
13769             if Is_Packed_Array_Type (T) then
13770                Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
13771             end if;
13772
13773          elsif Is_Access_Type (T) then
13774             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
13775
13776          elsif Is_Private_Type (T) then
13777             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
13778
13779          elsif Is_Protected_Type (T) then
13780             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
13781          end if;
13782       end if;
13783    end Set_Debug_Info_Needed;
13784
13785    ---------------------------------
13786    -- Set_Entity_With_Style_Check --
13787    ---------------------------------
13788
13789    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
13790       Val_Actual : Entity_Id;
13791       Nod        : Node_Id;
13792
13793    begin
13794       --  Unconditionally set the entity
13795
13796       Set_Entity (N, Val);
13797
13798       --  Check for No_Implementation_Identifiers
13799
13800       if Restriction_Check_Required (No_Implementation_Identifiers) then
13801
13802          --  We have an implementation defined entity if it is marked as
13803          --  implementation defined, or is defined in a package marked as
13804          --  implementation defined. However, library packages themselves
13805          --  are excluded (we don't want to flag Interfaces itself, just
13806          --  the entities within it).
13807
13808          if (Is_Implementation_Defined (Val)
13809                or else
13810              Is_Implementation_Defined (Scope (Val)))
13811            and then not (Ekind_In (Val, E_Package, E_Generic_Package)
13812                           and then Is_Library_Level_Entity (Val))
13813          then
13814             Check_Restriction (No_Implementation_Identifiers, N);
13815          end if;
13816       end if;
13817
13818       --  Do the style check
13819
13820       if Style_Check
13821         and then not Suppress_Style_Checks (Val)
13822         and then not In_Instance
13823       then
13824          if Nkind (N) = N_Identifier then
13825             Nod := N;
13826          elsif Nkind (N) = N_Expanded_Name then
13827             Nod := Selector_Name (N);
13828          else
13829             return;
13830          end if;
13831
13832          --  A special situation arises for derived operations, where we want
13833          --  to do the check against the parent (since the Sloc of the derived
13834          --  operation points to the derived type declaration itself).
13835
13836          Val_Actual := Val;
13837          while not Comes_From_Source (Val_Actual)
13838            and then Nkind (Val_Actual) in N_Entity
13839            and then (Ekind (Val_Actual) = E_Enumeration_Literal
13840                       or else Is_Subprogram (Val_Actual)
13841                       or else Is_Generic_Subprogram (Val_Actual))
13842            and then Present (Alias (Val_Actual))
13843          loop
13844             Val_Actual := Alias (Val_Actual);
13845          end loop;
13846
13847          --  Renaming declarations for generic actuals do not come from source,
13848          --  and have a different name from that of the entity they rename, so
13849          --  there is no style check to perform here.
13850
13851          if Chars (Nod) = Chars (Val_Actual) then
13852             Style.Check_Identifier (Nod, Val_Actual);
13853          end if;
13854       end if;
13855
13856       Set_Entity (N, Val);
13857    end Set_Entity_With_Style_Check;
13858
13859    ------------------------
13860    -- Set_Name_Entity_Id --
13861    ------------------------
13862
13863    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
13864    begin
13865       Set_Name_Table_Info (Id, Int (Val));
13866    end Set_Name_Entity_Id;
13867
13868    ---------------------
13869    -- Set_Next_Actual --
13870    ---------------------
13871
13872    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
13873    begin
13874       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
13875          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
13876       end if;
13877    end Set_Next_Actual;
13878
13879    ----------------------------------
13880    -- Set_Optimize_Alignment_Flags --
13881    ----------------------------------
13882
13883    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
13884    begin
13885       if Optimize_Alignment = 'S' then
13886          Set_Optimize_Alignment_Space (E);
13887       elsif Optimize_Alignment = 'T' then
13888          Set_Optimize_Alignment_Time (E);
13889       end if;
13890    end Set_Optimize_Alignment_Flags;
13891
13892    -----------------------
13893    -- Set_Public_Status --
13894    -----------------------
13895
13896    procedure Set_Public_Status (Id : Entity_Id) is
13897       S : constant Entity_Id := Current_Scope;
13898
13899       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
13900       --  Determines if E is defined within handled statement sequence or
13901       --  an if statement, returns True if so, False otherwise.
13902
13903       ----------------------
13904       -- Within_HSS_Or_If --
13905       ----------------------
13906
13907       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
13908          N : Node_Id;
13909       begin
13910          N := Declaration_Node (E);
13911          loop
13912             N := Parent (N);
13913
13914             if No (N) then
13915                return False;
13916
13917             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
13918                                N_If_Statement)
13919             then
13920                return True;
13921             end if;
13922          end loop;
13923       end Within_HSS_Or_If;
13924
13925    --  Start of processing for Set_Public_Status
13926
13927    begin
13928       --  Everything in the scope of Standard is public
13929
13930       if S = Standard_Standard then
13931          Set_Is_Public (Id);
13932
13933       --  Entity is definitely not public if enclosing scope is not public
13934
13935       elsif not Is_Public (S) then
13936          return;
13937
13938       --  An object or function declaration that occurs in a handled sequence
13939       --  of statements or within an if statement is the declaration for a
13940       --  temporary object or local subprogram generated by the expander. It
13941       --  never needs to be made public and furthermore, making it public can
13942       --  cause back end problems.
13943
13944       elsif Nkind_In (Parent (Id), N_Object_Declaration,
13945                                    N_Function_Specification)
13946         and then Within_HSS_Or_If (Id)
13947       then
13948          return;
13949
13950       --  Entities in public packages or records are public
13951
13952       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
13953          Set_Is_Public (Id);
13954
13955       --  The bounds of an entry family declaration can generate object
13956       --  declarations that are visible to the back-end, e.g. in the
13957       --  the declaration of a composite type that contains tasks.
13958
13959       elsif Is_Concurrent_Type (S)
13960         and then not Has_Completion (S)
13961         and then Nkind (Parent (Id)) = N_Object_Declaration
13962       then
13963          Set_Is_Public (Id);
13964       end if;
13965    end Set_Public_Status;
13966
13967    -----------------------------
13968    -- Set_Referenced_Modified --
13969    -----------------------------
13970
13971    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
13972       Pref : Node_Id;
13973
13974    begin
13975       --  Deal with indexed or selected component where prefix is modified
13976
13977       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
13978          Pref := Prefix (N);
13979
13980          --  If prefix is access type, then it is the designated object that is
13981          --  being modified, which means we have no entity to set the flag on.
13982
13983          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
13984             return;
13985
13986             --  Otherwise chase the prefix
13987
13988          else
13989             Set_Referenced_Modified (Pref, Out_Param);
13990          end if;
13991
13992       --  Otherwise see if we have an entity name (only other case to process)
13993
13994       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
13995          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
13996          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
13997       end if;
13998    end Set_Referenced_Modified;
13999
14000    ----------------------------
14001    -- Set_Scope_Is_Transient --
14002    ----------------------------
14003
14004    procedure Set_Scope_Is_Transient (V : Boolean := True) is
14005    begin
14006       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
14007    end Set_Scope_Is_Transient;
14008
14009    -------------------
14010    -- Set_Size_Info --
14011    -------------------
14012
14013    procedure Set_Size_Info (T1, T2 : Entity_Id) is
14014    begin
14015       --  We copy Esize, but not RM_Size, since in general RM_Size is
14016       --  subtype specific and does not get inherited by all subtypes.
14017
14018       Set_Esize                     (T1, Esize                     (T2));
14019       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
14020
14021       if Is_Discrete_Or_Fixed_Point_Type (T1)
14022            and then
14023          Is_Discrete_Or_Fixed_Point_Type (T2)
14024       then
14025          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
14026       end if;
14027
14028       Set_Alignment                 (T1, Alignment                 (T2));
14029    end Set_Size_Info;
14030
14031    --------------------
14032    -- Static_Boolean --
14033    --------------------
14034
14035    function Static_Boolean (N : Node_Id) return Uint is
14036    begin
14037       Analyze_And_Resolve (N, Standard_Boolean);
14038
14039       if N = Error
14040         or else Error_Posted (N)
14041         or else Etype (N) = Any_Type
14042       then
14043          return No_Uint;
14044       end if;
14045
14046       if Is_Static_Expression (N) then
14047          if not Raises_Constraint_Error (N) then
14048             return Expr_Value (N);
14049          else
14050             return No_Uint;
14051          end if;
14052
14053       elsif Etype (N) = Any_Type then
14054          return No_Uint;
14055
14056       else
14057          Flag_Non_Static_Expr
14058            ("static boolean expression required here", N);
14059          return No_Uint;
14060       end if;
14061    end Static_Boolean;
14062
14063    --------------------
14064    -- Static_Integer --
14065    --------------------
14066
14067    function Static_Integer (N : Node_Id) return Uint is
14068    begin
14069       Analyze_And_Resolve (N, Any_Integer);
14070
14071       if N = Error
14072         or else Error_Posted (N)
14073         or else Etype (N) = Any_Type
14074       then
14075          return No_Uint;
14076       end if;
14077
14078       if Is_Static_Expression (N) then
14079          if not Raises_Constraint_Error (N) then
14080             return Expr_Value (N);
14081          else
14082             return No_Uint;
14083          end if;
14084
14085       elsif Etype (N) = Any_Type then
14086          return No_Uint;
14087
14088       else
14089          Flag_Non_Static_Expr
14090            ("static integer expression required here", N);
14091          return No_Uint;
14092       end if;
14093    end Static_Integer;
14094
14095    --------------------------
14096    -- Statically_Different --
14097    --------------------------
14098
14099    function Statically_Different (E1, E2 : Node_Id) return Boolean is
14100       R1 : constant Node_Id := Get_Referenced_Object (E1);
14101       R2 : constant Node_Id := Get_Referenced_Object (E2);
14102    begin
14103       return     Is_Entity_Name (R1)
14104         and then Is_Entity_Name (R2)
14105         and then Entity (R1) /= Entity (R2)
14106         and then not Is_Formal (Entity (R1))
14107         and then not Is_Formal (Entity (R2));
14108    end Statically_Different;
14109
14110    --------------------------------------
14111    -- Subject_To_Loop_Entry_Attributes --
14112    --------------------------------------
14113
14114    function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
14115       Stmt : Node_Id;
14116
14117    begin
14118       Stmt := N;
14119
14120       --  The expansion mechanism transform a loop subject to at least one
14121       --  'Loop_Entry attribute into a conditional block. Infinite loops lack
14122       --  the conditional part.
14123
14124       if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
14125         and then Nkind (Original_Node (N)) = N_Loop_Statement
14126       then
14127          Stmt := Original_Node (N);
14128       end if;
14129
14130       return
14131         Nkind (Stmt) = N_Loop_Statement
14132           and then Present (Identifier (Stmt))
14133           and then Present (Entity (Identifier (Stmt)))
14134           and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
14135    end Subject_To_Loop_Entry_Attributes;
14136
14137    -----------------------------
14138    -- Subprogram_Access_Level --
14139    -----------------------------
14140
14141    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
14142    begin
14143       if Present (Alias (Subp)) then
14144          return Subprogram_Access_Level (Alias (Subp));
14145       else
14146          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
14147       end if;
14148    end Subprogram_Access_Level;
14149
14150    -------------------------------
14151    -- Support_Atomic_Primitives --
14152    -------------------------------
14153
14154    function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
14155       Size : Int;
14156
14157    begin
14158       --  Verify the alignment of Typ is known
14159
14160       if not Known_Alignment (Typ) then
14161          return False;
14162       end if;
14163
14164       if Known_Static_Esize (Typ) then
14165          Size := UI_To_Int (Esize (Typ));
14166
14167       --  If the Esize (Object_Size) is unknown at compile time, look at the
14168       --  RM_Size (Value_Size) which may have been set by an explicit rep item.
14169
14170       elsif Known_Static_RM_Size (Typ) then
14171          Size := UI_To_Int (RM_Size (Typ));
14172
14173       --  Otherwise, the size is considered to be unknown.
14174
14175       else
14176          return False;
14177       end if;
14178
14179       --  Check that the size of the component is 8, 16, 32 or 64 bits and that
14180       --  Typ is properly aligned.
14181
14182       case Size is
14183          when 8 | 16 | 32 | 64 =>
14184             return Size = UI_To_Int (Alignment (Typ)) * 8;
14185          when others           =>
14186             return False;
14187       end case;
14188    end Support_Atomic_Primitives;
14189
14190    -----------------
14191    -- Trace_Scope --
14192    -----------------
14193
14194    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
14195    begin
14196       if Debug_Flag_W then
14197          for J in 0 .. Scope_Stack.Last loop
14198             Write_Str ("  ");
14199          end loop;
14200
14201          Write_Str (Msg);
14202          Write_Name (Chars (E));
14203          Write_Str (" from ");
14204          Write_Location (Sloc (N));
14205          Write_Eol;
14206       end if;
14207    end Trace_Scope;
14208
14209    -----------------------
14210    -- Transfer_Entities --
14211    -----------------------
14212
14213    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
14214       Ent : Entity_Id := First_Entity (From);
14215
14216    begin
14217       if No (Ent) then
14218          return;
14219       end if;
14220
14221       if (Last_Entity (To)) = Empty then
14222          Set_First_Entity (To, Ent);
14223       else
14224          Set_Next_Entity (Last_Entity (To), Ent);
14225       end if;
14226
14227       Set_Last_Entity (To, Last_Entity (From));
14228
14229       while Present (Ent) loop
14230          Set_Scope (Ent, To);
14231
14232          if not Is_Public (Ent) then
14233             Set_Public_Status (Ent);
14234
14235             if Is_Public (Ent)
14236               and then Ekind (Ent) = E_Record_Subtype
14237
14238             then
14239                --  The components of the propagated Itype must be public
14240                --  as well.
14241
14242                declare
14243                   Comp : Entity_Id;
14244                begin
14245                   Comp := First_Entity (Ent);
14246                   while Present (Comp) loop
14247                      Set_Is_Public (Comp);
14248                      Next_Entity (Comp);
14249                   end loop;
14250                end;
14251             end if;
14252          end if;
14253
14254          Next_Entity (Ent);
14255       end loop;
14256
14257       Set_First_Entity (From, Empty);
14258       Set_Last_Entity (From, Empty);
14259    end Transfer_Entities;
14260
14261    -----------------------
14262    -- Type_Access_Level --
14263    -----------------------
14264
14265    function Type_Access_Level (Typ : Entity_Id) return Uint is
14266       Btyp : Entity_Id;
14267
14268    begin
14269       Btyp := Base_Type (Typ);
14270
14271       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
14272       --  simply use the level where the type is declared. This is true for
14273       --  stand-alone object declarations, and for anonymous access types
14274       --  associated with components the level is the same as that of the
14275       --  enclosing composite type. However, special treatment is needed for
14276       --  the cases of access parameters, return objects of an anonymous access
14277       --  type, and, in Ada 95, access discriminants of limited types.
14278
14279       if Ekind (Btyp) in Access_Kind then
14280          if Ekind (Btyp) = E_Anonymous_Access_Type then
14281
14282             --  If the type is a nonlocal anonymous access type (such as for
14283             --  an access parameter) we treat it as being declared at the
14284             --  library level to ensure that names such as X.all'access don't
14285             --  fail static accessibility checks.
14286
14287             if not Is_Local_Anonymous_Access (Typ) then
14288                return Scope_Depth (Standard_Standard);
14289
14290             --  If this is a return object, the accessibility level is that of
14291             --  the result subtype of the enclosing function. The test here is
14292             --  little complicated, because we have to account for extended
14293             --  return statements that have been rewritten as blocks, in which
14294             --  case we have to find and the Is_Return_Object attribute of the
14295             --  itype's associated object. It would be nice to find a way to
14296             --  simplify this test, but it doesn't seem worthwhile to add a new
14297             --  flag just for purposes of this test. ???
14298
14299             elsif Ekind (Scope (Btyp)) = E_Return_Statement
14300               or else
14301                 (Is_Itype (Btyp)
14302                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
14303                              N_Object_Declaration
14304                   and then Is_Return_Object
14305                              (Defining_Identifier
14306                                 (Associated_Node_For_Itype (Btyp))))
14307             then
14308                declare
14309                   Scop : Entity_Id;
14310
14311                begin
14312                   Scop := Scope (Scope (Btyp));
14313                   while Present (Scop) loop
14314                      exit when Ekind (Scop) = E_Function;
14315                      Scop := Scope (Scop);
14316                   end loop;
14317
14318                   --  Treat the return object's type as having the level of the
14319                   --  function's result subtype (as per RM05-6.5(5.3/2)).
14320
14321                   return Type_Access_Level (Etype (Scop));
14322                end;
14323             end if;
14324          end if;
14325
14326          Btyp := Root_Type (Btyp);
14327
14328          --  The accessibility level of anonymous access types associated with
14329          --  discriminants is that of the current instance of the type, and
14330          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
14331
14332          --  AI-402: access discriminants have accessibility based on the
14333          --  object rather than the type in Ada 2005, so the above paragraph
14334          --  doesn't apply.
14335
14336          --  ??? Needs completion with rules from AI-416
14337
14338          if Ada_Version <= Ada_95
14339            and then Ekind (Typ) = E_Anonymous_Access_Type
14340            and then Present (Associated_Node_For_Itype (Typ))
14341            and then Nkind (Associated_Node_For_Itype (Typ)) =
14342                                                  N_Discriminant_Specification
14343          then
14344             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
14345          end if;
14346       end if;
14347
14348       --  Return library level for a generic formal type. This is done because
14349       --  RM(10.3.2) says that "The statically deeper relationship does not
14350       --  apply to ... a descendant of a generic formal type". Rather than
14351       --  checking at each point where a static accessibility check is
14352       --  performed to see if we are dealing with a formal type, this rule is
14353       --  implemented by having Type_Access_Level and Deepest_Type_Access_Level
14354       --  return extreme values for a formal type; Deepest_Type_Access_Level
14355       --  returns Int'Last. By calling the appropriate function from among the
14356       --  two, we ensure that the static accessibility check will pass if we
14357       --  happen to run into a formal type. More specifically, we should call
14358       --  Deepest_Type_Access_Level instead of Type_Access_Level whenever the
14359       --  call occurs as part of a static accessibility check and the error
14360       --  case is the case where the type's level is too shallow (as opposed
14361       --  to too deep).
14362
14363       if Is_Generic_Type (Root_Type (Btyp)) then
14364          return Scope_Depth (Standard_Standard);
14365       end if;
14366
14367       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
14368    end Type_Access_Level;
14369
14370    ------------------------------------
14371    -- Type_Without_Stream_Operation  --
14372    ------------------------------------
14373
14374    function Type_Without_Stream_Operation
14375      (T  : Entity_Id;
14376       Op : TSS_Name_Type := TSS_Null) return Entity_Id
14377    is
14378       BT         : constant Entity_Id := Base_Type (T);
14379       Op_Missing : Boolean;
14380
14381    begin
14382       if not Restriction_Active (No_Default_Stream_Attributes) then
14383          return Empty;
14384       end if;
14385
14386       if Is_Elementary_Type (T) then
14387          if Op = TSS_Null then
14388             Op_Missing :=
14389               No (TSS (BT, TSS_Stream_Read))
14390                 or else No (TSS (BT, TSS_Stream_Write));
14391
14392          else
14393             Op_Missing := No (TSS (BT, Op));
14394          end if;
14395
14396          if Op_Missing then
14397             return T;
14398          else
14399             return Empty;
14400          end if;
14401
14402       elsif Is_Array_Type (T) then
14403          return Type_Without_Stream_Operation (Component_Type (T), Op);
14404
14405       elsif Is_Record_Type (T) then
14406          declare
14407             Comp  : Entity_Id;
14408             C_Typ : Entity_Id;
14409
14410          begin
14411             Comp := First_Component (T);
14412             while Present (Comp) loop
14413                C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
14414
14415                if Present (C_Typ) then
14416                   return C_Typ;
14417                end if;
14418
14419                Next_Component (Comp);
14420             end loop;
14421
14422             return Empty;
14423          end;
14424
14425       elsif Is_Private_Type (T)
14426         and then Present (Full_View (T))
14427       then
14428          return Type_Without_Stream_Operation (Full_View (T), Op);
14429       else
14430          return Empty;
14431       end if;
14432    end Type_Without_Stream_Operation;
14433
14434    ----------------------------
14435    -- Unique_Defining_Entity --
14436    ----------------------------
14437
14438    function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
14439    begin
14440       return Unique_Entity (Defining_Entity (N));
14441    end Unique_Defining_Entity;
14442
14443    -------------------
14444    -- Unique_Entity --
14445    -------------------
14446
14447    function Unique_Entity (E : Entity_Id) return Entity_Id is
14448       U : Entity_Id := E;
14449       P : Node_Id;
14450
14451    begin
14452       case Ekind (E) is
14453          when E_Constant =>
14454             if Present (Full_View (E)) then
14455                U := Full_View (E);
14456             end if;
14457
14458          when Type_Kind =>
14459             if Present (Full_View (E)) then
14460                U := Full_View (E);
14461             end if;
14462
14463          when E_Package_Body =>
14464             P := Parent (E);
14465
14466             if Nkind (P) = N_Defining_Program_Unit_Name then
14467                P := Parent (P);
14468             end if;
14469
14470             U := Corresponding_Spec (P);
14471
14472          when E_Subprogram_Body =>
14473             P := Parent (E);
14474
14475             if Nkind (P) = N_Defining_Program_Unit_Name then
14476                P := Parent (P);
14477             end if;
14478
14479             P := Parent (P);
14480
14481             if Nkind (P) = N_Subprogram_Body_Stub then
14482                if Present (Library_Unit (P)) then
14483
14484                   --  Get to the function or procedure (generic) entity through
14485                   --  the body entity.
14486
14487                   U :=
14488                     Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
14489                end if;
14490             else
14491                U := Corresponding_Spec (P);
14492             end if;
14493
14494          when Formal_Kind =>
14495             if Present (Spec_Entity (E)) then
14496                U := Spec_Entity (E);
14497             end if;
14498
14499          when others =>
14500             null;
14501       end case;
14502
14503       return U;
14504    end Unique_Entity;
14505
14506    -----------------
14507    -- Unique_Name --
14508    -----------------
14509
14510    function Unique_Name (E : Entity_Id) return String is
14511
14512       --  Names of E_Subprogram_Body or E_Package_Body entities are not
14513       --  reliable, as they may not include the overloading suffix. Instead,
14514       --  when looking for the name of E or one of its enclosing scope, we get
14515       --  the name of the corresponding Unique_Entity.
14516
14517       function Get_Scoped_Name (E : Entity_Id) return String;
14518       --  Return the name of E prefixed by all the names of the scopes to which
14519       --  E belongs, except for Standard.
14520
14521       ---------------------
14522       -- Get_Scoped_Name --
14523       ---------------------
14524
14525       function Get_Scoped_Name (E : Entity_Id) return String is
14526          Name : constant String := Get_Name_String (Chars (E));
14527       begin
14528          if Has_Fully_Qualified_Name (E)
14529            or else Scope (E) = Standard_Standard
14530          then
14531             return Name;
14532          else
14533             return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
14534          end if;
14535       end Get_Scoped_Name;
14536
14537    --  Start of processing for Unique_Name
14538
14539    begin
14540       if E = Standard_Standard then
14541          return Get_Name_String (Name_Standard);
14542
14543       elsif Scope (E) = Standard_Standard
14544         and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
14545       then
14546          return Get_Name_String (Name_Standard) & "__" &
14547            Get_Name_String (Chars (E));
14548
14549       elsif Ekind (E) = E_Enumeration_Literal then
14550          return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
14551
14552       else
14553          return Get_Scoped_Name (Unique_Entity (E));
14554       end if;
14555    end Unique_Name;
14556
14557    ---------------------
14558    -- Unit_Is_Visible --
14559    ---------------------
14560
14561    function Unit_Is_Visible (U : Entity_Id) return Boolean is
14562       Curr        : constant Node_Id   := Cunit (Current_Sem_Unit);
14563       Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
14564
14565       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
14566       --  For a child unit, check whether unit appears in a with_clause
14567       --  of a parent.
14568
14569       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
14570       --  Scan the context clause of one compilation unit looking for a
14571       --  with_clause for the unit in question.
14572
14573       ----------------------------
14574       -- Unit_In_Parent_Context --
14575       ----------------------------
14576
14577       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
14578       begin
14579          if Unit_In_Context (Par_Unit) then
14580             return True;
14581
14582          elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
14583             return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
14584
14585          else
14586             return False;
14587          end if;
14588       end Unit_In_Parent_Context;
14589
14590       ---------------------
14591       -- Unit_In_Context --
14592       ---------------------
14593
14594       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
14595          Clause : Node_Id;
14596
14597       begin
14598          Clause := First (Context_Items (Comp_Unit));
14599          while Present (Clause) loop
14600             if Nkind (Clause) = N_With_Clause then
14601                if Library_Unit (Clause) = U then
14602                   return True;
14603
14604                --  The with_clause may denote a renaming of the unit we are
14605                --  looking for, eg. Text_IO which renames Ada.Text_IO.
14606
14607                elsif
14608                  Renamed_Entity (Entity (Name (Clause))) =
14609                                                 Defining_Entity (Unit (U))
14610                then
14611                   return True;
14612                end if;
14613             end if;
14614
14615             Next (Clause);
14616          end loop;
14617
14618          return False;
14619       end Unit_In_Context;
14620
14621    --  Start of processing for Unit_Is_Visible
14622
14623    begin
14624       --  The currrent unit is directly visible
14625
14626       if Curr = U then
14627          return True;
14628
14629       elsif Unit_In_Context (Curr) then
14630          return True;
14631
14632       --  If the current unit is a body, check the context of the spec
14633
14634       elsif Nkind (Unit (Curr)) = N_Package_Body
14635         or else
14636           (Nkind (Unit (Curr)) = N_Subprogram_Body
14637             and then not Acts_As_Spec (Unit (Curr)))
14638       then
14639          if Unit_In_Context (Library_Unit (Curr)) then
14640             return True;
14641          end if;
14642       end if;
14643
14644       --  If the spec is a child unit, examine the parents
14645
14646       if Is_Child_Unit (Curr_Entity) then
14647          if Nkind (Unit (Curr)) in N_Unit_Body then
14648             return
14649               Unit_In_Parent_Context
14650                 (Parent_Spec (Unit (Library_Unit (Curr))));
14651          else
14652             return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
14653          end if;
14654
14655       else
14656          return False;
14657       end if;
14658    end Unit_Is_Visible;
14659
14660    ------------------------------
14661    -- Universal_Interpretation --
14662    ------------------------------
14663
14664    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
14665       Index : Interp_Index;
14666       It    : Interp;
14667
14668    begin
14669       --  The argument may be a formal parameter of an operator or subprogram
14670       --  with multiple interpretations, or else an expression for an actual.
14671
14672       if Nkind (Opnd) = N_Defining_Identifier
14673         or else not Is_Overloaded (Opnd)
14674       then
14675          if Etype (Opnd) = Universal_Integer
14676            or else Etype (Opnd) = Universal_Real
14677          then
14678             return Etype (Opnd);
14679          else
14680             return Empty;
14681          end if;
14682
14683       else
14684          Get_First_Interp (Opnd, Index, It);
14685          while Present (It.Typ) loop
14686             if It.Typ = Universal_Integer
14687               or else It.Typ = Universal_Real
14688             then
14689                return It.Typ;
14690             end if;
14691
14692             Get_Next_Interp (Index, It);
14693          end loop;
14694
14695          return Empty;
14696       end if;
14697    end Universal_Interpretation;
14698
14699    ---------------
14700    -- Unqualify --
14701    ---------------
14702
14703    function Unqualify (Expr : Node_Id) return Node_Id is
14704    begin
14705       --  Recurse to handle unlikely case of multiple levels of qualification
14706
14707       if Nkind (Expr) = N_Qualified_Expression then
14708          return Unqualify (Expression (Expr));
14709
14710       --  Normal case, not a qualified expression
14711
14712       else
14713          return Expr;
14714       end if;
14715    end Unqualify;
14716
14717    -----------------------
14718    -- Visible_Ancestors --
14719    -----------------------
14720
14721    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
14722       List_1 : Elist_Id;
14723       List_2 : Elist_Id;
14724       Elmt   : Elmt_Id;
14725
14726    begin
14727       pragma Assert (Is_Record_Type (Typ)
14728         and then Is_Tagged_Type (Typ));
14729
14730       --  Collect all the parents and progenitors of Typ. If the full-view of
14731       --  private parents and progenitors is available then it is used to
14732       --  generate the list of visible ancestors; otherwise their partial
14733       --  view is added to the resulting list.
14734
14735       Collect_Parents
14736         (T               => Typ,
14737          List            => List_1,
14738          Use_Full_View   => True);
14739
14740       Collect_Interfaces
14741         (T               => Typ,
14742          Ifaces_List     => List_2,
14743          Exclude_Parents => True,
14744          Use_Full_View   => True);
14745
14746       --  Join the two lists. Avoid duplications because an interface may
14747       --  simultaneously be parent and progenitor of a type.
14748
14749       Elmt := First_Elmt (List_2);
14750       while Present (Elmt) loop
14751          Append_Unique_Elmt (Node (Elmt), List_1);
14752          Next_Elmt (Elmt);
14753       end loop;
14754
14755       return List_1;
14756    end Visible_Ancestors;
14757
14758    ----------------------
14759    -- Within_Init_Proc --
14760    ----------------------
14761
14762    function Within_Init_Proc return Boolean is
14763       S : Entity_Id;
14764
14765    begin
14766       S := Current_Scope;
14767       while not Is_Overloadable (S) loop
14768          if S = Standard_Standard then
14769             return False;
14770          else
14771             S := Scope (S);
14772          end if;
14773       end loop;
14774
14775       return Is_Init_Proc (S);
14776    end Within_Init_Proc;
14777
14778    ----------------
14779    -- Wrong_Type --
14780    ----------------
14781
14782    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
14783       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
14784       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
14785
14786       Matching_Field : Entity_Id;
14787       --  Entity to give a more precise suggestion on how to write a one-
14788       --  element positional aggregate.
14789
14790       function Has_One_Matching_Field return Boolean;
14791       --  Determines if Expec_Type is a record type with a single component or
14792       --  discriminant whose type matches the found type or is one dimensional
14793       --  array whose component type matches the found type. In the case of
14794       --  one discriminant, we ignore the variant parts. That's not accurate,
14795       --  but good enough for the warning.
14796
14797       ----------------------------
14798       -- Has_One_Matching_Field --
14799       ----------------------------
14800
14801       function Has_One_Matching_Field return Boolean is
14802          E : Entity_Id;
14803
14804       begin
14805          Matching_Field := Empty;
14806
14807          if Is_Array_Type (Expec_Type)
14808            and then Number_Dimensions (Expec_Type) = 1
14809            and then
14810              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
14811          then
14812             --  Use type name if available. This excludes multidimensional
14813             --  arrays and anonymous arrays.
14814
14815             if Comes_From_Source (Expec_Type) then
14816                Matching_Field := Expec_Type;
14817
14818             --  For an assignment, use name of target
14819
14820             elsif Nkind (Parent (Expr)) = N_Assignment_Statement
14821               and then Is_Entity_Name (Name (Parent (Expr)))
14822             then
14823                Matching_Field := Entity (Name (Parent (Expr)));
14824             end if;
14825
14826             return True;
14827
14828          elsif not Is_Record_Type (Expec_Type) then
14829             return False;
14830
14831          else
14832             E := First_Entity (Expec_Type);
14833             loop
14834                if No (E) then
14835                   return False;
14836
14837                elsif not Ekind_In (E, E_Discriminant, E_Component)
14838                  or else Nam_In (Chars (E), Name_uTag, Name_uParent)
14839                then
14840                   Next_Entity (E);
14841
14842                else
14843                   exit;
14844                end if;
14845             end loop;
14846
14847             if not Covers (Etype (E), Found_Type) then
14848                return False;
14849
14850             elsif Present (Next_Entity (E))
14851               and then (Ekind (E) = E_Component
14852                          or else Ekind (Next_Entity (E)) = E_Discriminant)
14853             then
14854                return False;
14855
14856             else
14857                Matching_Field := E;
14858                return True;
14859             end if;
14860          end if;
14861       end Has_One_Matching_Field;
14862
14863    --  Start of processing for Wrong_Type
14864
14865    begin
14866       --  Don't output message if either type is Any_Type, or if a message
14867       --  has already been posted for this node. We need to do the latter
14868       --  check explicitly (it is ordinarily done in Errout), because we
14869       --  are using ! to force the output of the error messages.
14870
14871       if Expec_Type = Any_Type
14872         or else Found_Type = Any_Type
14873         or else Error_Posted (Expr)
14874       then
14875          return;
14876
14877       --  If one of the types is a Taft-Amendment type and the other it its
14878       --  completion, it must be an illegal use of a TAT in the spec, for
14879       --  which an error was already emitted. Avoid cascaded errors.
14880
14881       elsif Is_Incomplete_Type (Expec_Type)
14882         and then Has_Completion_In_Body (Expec_Type)
14883         and then Full_View (Expec_Type) = Etype (Expr)
14884       then
14885          return;
14886
14887       elsif Is_Incomplete_Type (Etype (Expr))
14888         and then Has_Completion_In_Body (Etype (Expr))
14889         and then Full_View (Etype (Expr)) = Expec_Type
14890       then
14891          return;
14892
14893       --  In  an instance, there is an ongoing problem with completion of
14894       --  type derived from private types. Their structure is what Gigi
14895       --  expects, but the  Etype is the parent type rather than the
14896       --  derived private type itself. Do not flag error in this case. The
14897       --  private completion is an entity without a parent, like an Itype.
14898       --  Similarly, full and partial views may be incorrect in the instance.
14899       --  There is no simple way to insure that it is consistent ???
14900
14901       elsif In_Instance then
14902          if Etype (Etype (Expr)) = Etype (Expected_Type)
14903            and then
14904              (Has_Private_Declaration (Expected_Type)
14905                or else Has_Private_Declaration (Etype (Expr)))
14906            and then No (Parent (Expected_Type))
14907          then
14908             return;
14909          end if;
14910       end if;
14911
14912       --  An interesting special check. If the expression is parenthesized
14913       --  and its type corresponds to the type of the sole component of the
14914       --  expected record type, or to the component type of the expected one
14915       --  dimensional array type, then assume we have a bad aggregate attempt.
14916
14917       if Nkind (Expr) in N_Subexpr
14918         and then Paren_Count (Expr) /= 0
14919         and then Has_One_Matching_Field
14920       then
14921          Error_Msg_N ("positional aggregate cannot have one component", Expr);
14922          if Present (Matching_Field) then
14923             if Is_Array_Type (Expec_Type) then
14924                Error_Msg_NE
14925                  ("\write instead `&''First ='> ...`", Expr, Matching_Field);
14926
14927             else
14928                Error_Msg_NE
14929                  ("\write instead `& ='> ...`", Expr, Matching_Field);
14930             end if;
14931          end if;
14932
14933       --  Another special check, if we are looking for a pool-specific access
14934       --  type and we found an E_Access_Attribute_Type, then we have the case
14935       --  of an Access attribute being used in a context which needs a pool-
14936       --  specific type, which is never allowed. The one extra check we make
14937       --  is that the expected designated type covers the Found_Type.
14938
14939       elsif Is_Access_Type (Expec_Type)
14940         and then Ekind (Found_Type) = E_Access_Attribute_Type
14941         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
14942         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
14943         and then Covers
14944           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
14945       then
14946          Error_Msg_N -- CODEFIX
14947            ("result must be general access type!", Expr);
14948          Error_Msg_NE -- CODEFIX
14949            ("add ALL to }!", Expr, Expec_Type);
14950
14951       --  Another special check, if the expected type is an integer type,
14952       --  but the expression is of type System.Address, and the parent is
14953       --  an addition or subtraction operation whose left operand is the
14954       --  expression in question and whose right operand is of an integral
14955       --  type, then this is an attempt at address arithmetic, so give
14956       --  appropriate message.
14957
14958       elsif Is_Integer_Type (Expec_Type)
14959         and then Is_RTE (Found_Type, RE_Address)
14960         and then (Nkind (Parent (Expr)) = N_Op_Add
14961                     or else
14962                   Nkind (Parent (Expr)) = N_Op_Subtract)
14963         and then Expr = Left_Opnd (Parent (Expr))
14964         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
14965       then
14966          Error_Msg_N
14967            ("address arithmetic not predefined in package System",
14968             Parent (Expr));
14969          Error_Msg_N
14970            ("\possible missing with/use of System.Storage_Elements",
14971             Parent (Expr));
14972          return;
14973
14974       --  If the expected type is an anonymous access type, as for access
14975       --  parameters and discriminants, the error is on the designated types.
14976
14977       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
14978          if Comes_From_Source (Expec_Type) then
14979             Error_Msg_NE ("expected}!", Expr, Expec_Type);
14980          else
14981             Error_Msg_NE
14982               ("expected an access type with designated}",
14983                  Expr, Designated_Type (Expec_Type));
14984          end if;
14985
14986          if Is_Access_Type (Found_Type)
14987            and then not Comes_From_Source (Found_Type)
14988          then
14989             Error_Msg_NE
14990               ("\\found an access type with designated}!",
14991                 Expr, Designated_Type (Found_Type));
14992          else
14993             if From_With_Type (Found_Type) then
14994                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
14995                Error_Msg_Qual_Level := 99;
14996                Error_Msg_NE -- CODEFIX
14997                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
14998                Error_Msg_Qual_Level := 0;
14999             else
15000                Error_Msg_NE ("found}!", Expr, Found_Type);
15001             end if;
15002          end if;
15003
15004       --  Normal case of one type found, some other type expected
15005
15006       else
15007          --  If the names of the two types are the same, see if some number
15008          --  of levels of qualification will help. Don't try more than three
15009          --  levels, and if we get to standard, it's no use (and probably
15010          --  represents an error in the compiler) Also do not bother with
15011          --  internal scope names.
15012
15013          declare
15014             Expec_Scope : Entity_Id;
15015             Found_Scope : Entity_Id;
15016
15017          begin
15018             Expec_Scope := Expec_Type;
15019             Found_Scope := Found_Type;
15020
15021             for Levels in Int range 0 .. 3 loop
15022                if Chars (Expec_Scope) /= Chars (Found_Scope) then
15023                   Error_Msg_Qual_Level := Levels;
15024                   exit;
15025                end if;
15026
15027                Expec_Scope := Scope (Expec_Scope);
15028                Found_Scope := Scope (Found_Scope);
15029
15030                exit when Expec_Scope = Standard_Standard
15031                  or else Found_Scope = Standard_Standard
15032                  or else not Comes_From_Source (Expec_Scope)
15033                  or else not Comes_From_Source (Found_Scope);
15034             end loop;
15035          end;
15036
15037          if Is_Record_Type (Expec_Type)
15038            and then Present (Corresponding_Remote_Type (Expec_Type))
15039          then
15040             Error_Msg_NE ("expected}!", Expr,
15041                           Corresponding_Remote_Type (Expec_Type));
15042          else
15043             Error_Msg_NE ("expected}!", Expr, Expec_Type);
15044          end if;
15045
15046          if Is_Entity_Name (Expr)
15047            and then Is_Package_Or_Generic_Package (Entity (Expr))
15048          then
15049             Error_Msg_N ("\\found package name!", Expr);
15050
15051          elsif Is_Entity_Name (Expr)
15052            and then
15053              (Ekind (Entity (Expr)) = E_Procedure
15054                 or else
15055               Ekind (Entity (Expr)) = E_Generic_Procedure)
15056          then
15057             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
15058                Error_Msg_N
15059                  ("found procedure name, possibly missing Access attribute!",
15060                    Expr);
15061             else
15062                Error_Msg_N
15063                  ("\\found procedure name instead of function!", Expr);
15064             end if;
15065
15066          elsif Nkind (Expr) = N_Function_Call
15067            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
15068            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
15069            and then No (Parameter_Associations (Expr))
15070          then
15071             Error_Msg_N
15072               ("found function name, possibly missing Access attribute!",
15073                Expr);
15074
15075          --  Catch common error: a prefix or infix operator which is not
15076          --  directly visible because the type isn't.
15077
15078          elsif Nkind (Expr) in N_Op
15079             and then Is_Overloaded (Expr)
15080             and then not Is_Immediately_Visible (Expec_Type)
15081             and then not Is_Potentially_Use_Visible (Expec_Type)
15082             and then not In_Use (Expec_Type)
15083             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
15084          then
15085             Error_Msg_N
15086               ("operator of the type is not directly visible!", Expr);
15087
15088          elsif Ekind (Found_Type) = E_Void
15089            and then Present (Parent (Found_Type))
15090            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
15091          then
15092             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
15093
15094          else
15095             Error_Msg_NE ("\\found}!", Expr, Found_Type);
15096          end if;
15097
15098          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
15099          --  of the same modular type, and (M1 and M2) = 0 was intended.
15100
15101          if Expec_Type = Standard_Boolean
15102            and then Is_Modular_Integer_Type (Found_Type)
15103            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
15104            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
15105          then
15106             declare
15107                Op : constant Node_Id := Right_Opnd (Parent (Expr));
15108                L  : constant Node_Id := Left_Opnd (Op);
15109                R  : constant Node_Id := Right_Opnd (Op);
15110             begin
15111                --  The case for the message is when the left operand of the
15112                --  comparison is the same modular type, or when it is an
15113                --  integer literal (or other universal integer expression),
15114                --  which would have been typed as the modular type if the
15115                --  parens had been there.
15116
15117                if (Etype (L) = Found_Type
15118                      or else
15119                    Etype (L) = Universal_Integer)
15120                  and then Is_Integer_Type (Etype (R))
15121                then
15122                   Error_Msg_N
15123                     ("\\possible missing parens for modular operation", Expr);
15124                end if;
15125             end;
15126          end if;
15127
15128          --  Reset error message qualification indication
15129
15130          Error_Msg_Qual_Level := 0;
15131       end if;
15132    end Wrong_Type;
15133
15134 end Sem_Util;