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-2011, 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_Tss;  use Exp_Tss;
  35 with Exp_Util; use Exp_Util;
  36 with Fname;    use Fname;
  37 with Freeze;   use Freeze;
  38 with Lib;      use Lib;
  39 with Lib.Xref; use Lib.Xref;
  40 with Nlists;   use Nlists;
  41 with Output;   use Output;
  42 with Opt;      use Opt;
  43 with Restrict; use Restrict;
  44 with Rident;   use Rident;
  45 with Rtsfind;  use Rtsfind;
  46 with Sem;      use Sem;
  47 with Sem_Aux;  use Sem_Aux;
  48 with Sem_Attr; use Sem_Attr;
  49 with Sem_Ch8;  use Sem_Ch8;
  50 with Sem_Disp; use Sem_Disp;
  51 with Sem_Eval; use Sem_Eval;
  52 with Sem_Res;  use Sem_Res;
  53 with Sem_Type; use Sem_Type;
  54 with Sinfo;    use Sinfo;
  55 with Sinput;   use Sinput;
  56 with Stand;    use Stand;
  57 with Style;
  58 with Stringt;  use Stringt;
  59 with Table;
  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;
  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    -- Order Dependence (AI05-0144) --
 100    ----------------------------------
 101
 102    --  Each actual in a call is entered into the table below. A flag indicates
 103    --  whether the corresponding formal is OUT or IN OUT. Each top-level call
 104    --  (procedure call, condition, assignment) examines all the actuals for a
 105    --  possible order dependence. The table is reset after each such check.
 106    --  The actuals to be checked in a call to Check_Order_Dependence are at
 107    --  positions 1 .. Last.
 108
 109    type Actual_Name is record
 110       Act         : Node_Id;
 111       Is_Writable : Boolean;
 112    end record;
 113
 114    package Actuals_In_Call is new Table.Table (
 115       Table_Component_Type => Actual_Name,
 116       Table_Index_Type     => Int,
 117       Table_Low_Bound      => 0,
 118       Table_Initial        => 10,
 119       Table_Increment      => 100,
 120       Table_Name           => "Actuals");
 121
 122    -----------------------
 123    -- Local Subprograms --
 124    -----------------------
 125
 126    function Build_Component_Subtype
 127      (C   : List_Id;
 128       Loc : Source_Ptr;
 129       T   : Entity_Id) return Node_Id;
 130    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
 131    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
 132    --  Loc is the source location, T is the original subtype.
 133
 134    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
 135    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
 136    --  with discriminants whose default values are static, examine only the
 137    --  components in the selected variant to determine whether all of them
 138    --  have a default.
 139
 140    function Has_Null_Extension (T : Entity_Id) return Boolean;
 141    --  T is a derived tagged type. Check whether the type extension is null.
 142    --  If the parent type is fully initialized, T can be treated as such.
 143
 144    ------------------------------
 145    --  Abstract_Interface_List --
 146    ------------------------------
 147
 148    function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
 149       Nod : Node_Id;
 150
 151    begin
 152       if Is_Concurrent_Type (Typ) then
 153
 154          --  If we are dealing with a synchronized subtype, go to the base
 155          --  type, whose declaration has the interface list.
 156
 157          --  Shouldn't this be Declaration_Node???
 158
 159          Nod := Parent (Base_Type (Typ));
 160
 161          if Nkind (Nod) = N_Full_Type_Declaration then
 162             return Empty_List;
 163          end if;
 164
 165       elsif Ekind (Typ) = E_Record_Type_With_Private then
 166          if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
 167             Nod := Type_Definition (Parent (Typ));
 168
 169          elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
 170             if Present (Full_View (Typ))
 171               and then Nkind (Parent (Full_View (Typ)))
 172                          = N_Full_Type_Declaration
 173             then
 174                Nod := Type_Definition (Parent (Full_View (Typ)));
 175
 176             --  If the full-view is not available we cannot do anything else
 177             --  here (the source has errors).
 178
 179             else
 180                return Empty_List;
 181             end if;
 182
 183          --  Support for generic formals with interfaces is still missing ???
 184
 185          elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 186             return Empty_List;
 187
 188          else
 189             pragma Assert
 190               (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
 191             Nod := Parent (Typ);
 192          end if;
 193
 194       elsif Ekind (Typ) = E_Record_Subtype then
 195          Nod := Type_Definition (Parent (Etype (Typ)));
 196
 197       elsif Ekind (Typ) = E_Record_Subtype_With_Private then
 198
 199          --  Recurse, because parent may still be a private extension. Also
 200          --  note that the full view of the subtype or the full view of its
 201          --  base type may (both) be unavailable.
 202
 203          return Abstract_Interface_List (Etype (Typ));
 204
 205       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
 206          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 207             Nod := Formal_Type_Definition (Parent (Typ));
 208          else
 209             Nod := Type_Definition (Parent (Typ));
 210          end if;
 211       end if;
 212
 213       return Interface_List (Nod);
 214    end Abstract_Interface_List;
 215
 216    --------------------------------
 217    -- Add_Access_Type_To_Process --
 218    --------------------------------
 219
 220    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
 221       L : Elist_Id;
 222
 223    begin
 224       Ensure_Freeze_Node (E);
 225       L := Access_Types_To_Process (Freeze_Node (E));
 226
 227       if No (L) then
 228          L := New_Elmt_List;
 229          Set_Access_Types_To_Process (Freeze_Node (E), L);
 230       end if;
 231
 232       Append_Elmt (A, L);
 233    end Add_Access_Type_To_Process;
 234
 235    ----------------------------
 236    -- Add_Global_Declaration --
 237    ----------------------------
 238
 239    procedure Add_Global_Declaration (N : Node_Id) is
 240       Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
 241
 242    begin
 243       if No (Declarations (Aux_Node)) then
 244          Set_Declarations (Aux_Node, New_List);
 245       end if;
 246
 247       Append_To (Declarations (Aux_Node), N);
 248       Analyze (N);
 249    end Add_Global_Declaration;
 250
 251    -----------------
 252    -- Addressable --
 253    -----------------
 254
 255    --  For now, just 8/16/32/64. but analyze later if AAMP is special???
 256
 257    function Addressable (V : Uint) return Boolean is
 258    begin
 259       return V = Uint_8  or else
 260              V = Uint_16 or else
 261              V = Uint_32 or else
 262              V = Uint_64;
 263    end Addressable;
 264
 265    function Addressable (V : Int) return Boolean is
 266    begin
 267       return V = 8  or else
 268              V = 16 or else
 269              V = 32 or else
 270              V = 64;
 271    end Addressable;
 272
 273    -----------------------
 274    -- Alignment_In_Bits --
 275    -----------------------
 276
 277    function Alignment_In_Bits (E : Entity_Id) return Uint is
 278    begin
 279       return Alignment (E) * System_Storage_Unit;
 280    end Alignment_In_Bits;
 281
 282    -----------------------------------------
 283    -- Apply_Compile_Time_Constraint_Error --
 284    -----------------------------------------
 285
 286    procedure Apply_Compile_Time_Constraint_Error
 287      (N      : Node_Id;
 288       Msg    : String;
 289       Reason : RT_Exception_Code;
 290       Ent    : Entity_Id  := Empty;
 291       Typ    : Entity_Id  := Empty;
 292       Loc    : Source_Ptr := No_Location;
 293       Rep    : Boolean    := True;
 294       Warn   : Boolean    := False)
 295    is
 296       Stat   : constant Boolean := Is_Static_Expression (N);
 297       R_Stat : constant Node_Id :=
 298                  Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
 299       Rtyp   : Entity_Id;
 300
 301    begin
 302       if No (Typ) then
 303          Rtyp := Etype (N);
 304       else
 305          Rtyp := Typ;
 306       end if;
 307
 308       Discard_Node
 309         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 310
 311       if not Rep then
 312          return;
 313       end if;
 314
 315       --  Now we replace the node by an N_Raise_Constraint_Error node
 316       --  This does not need reanalyzing, so set it as analyzed now.
 317
 318       Rewrite (N, R_Stat);
 319       Set_Analyzed (N, True);
 320
 321       Set_Etype (N, Rtyp);
 322       Set_Raises_Constraint_Error (N);
 323
 324       --  Now deal with possible local raise handling
 325
 326       Possible_Local_Raise (N, Standard_Constraint_Error);
 327
 328       --  If the original expression was marked as static, the result is
 329       --  still marked as static, but the Raises_Constraint_Error flag is
 330       --  always set so that further static evaluation is not attempted.
 331
 332       if Stat then
 333          Set_Is_Static_Expression (N);
 334       end if;
 335    end Apply_Compile_Time_Constraint_Error;
 336
 337    --------------------------------
 338    -- Bad_Predicated_Subtype_Use --
 339    --------------------------------
 340
 341    procedure Bad_Predicated_Subtype_Use
 342      (Msg : String;
 343       N   : Node_Id;
 344       Typ : Entity_Id)
 345    is
 346    begin
 347       if Has_Predicates (Typ) then
 348          if Is_Generic_Actual_Type (Typ) then
 349             Error_Msg_FE (Msg & '?', N, Typ);
 350             Error_Msg_F ("\Program_Error will be raised at run time?", N);
 351             Insert_Action (N,
 352               Make_Raise_Program_Error (Sloc (N),
 353                 Reason => PE_Bad_Predicated_Generic_Type));
 354
 355          else
 356             Error_Msg_FE (Msg, N, Typ);
 357          end if;
 358       end if;
 359    end Bad_Predicated_Subtype_Use;
 360
 361    --------------------------
 362    -- Build_Actual_Subtype --
 363    --------------------------
 364
 365    function Build_Actual_Subtype
 366      (T : Entity_Id;
 367       N : Node_Or_Entity_Id) return Node_Id
 368    is
 369       Loc : Source_Ptr;
 370       --  Normally Sloc (N), but may point to corresponding body in some cases
 371
 372       Constraints : List_Id;
 373       Decl        : Node_Id;
 374       Discr       : Entity_Id;
 375       Hi          : Node_Id;
 376       Lo          : Node_Id;
 377       Subt        : Entity_Id;
 378       Disc_Type   : Entity_Id;
 379       Obj         : Node_Id;
 380
 381    begin
 382       Loc := Sloc (N);
 383
 384       if Nkind (N) = N_Defining_Identifier then
 385          Obj := New_Reference_To (N, Loc);
 386
 387          --  If this is a formal parameter of a subprogram declaration, and
 388          --  we are compiling the body, we want the declaration for the
 389          --  actual subtype to carry the source position of the body, to
 390          --  prevent anomalies in gdb when stepping through the code.
 391
 392          if Is_Formal (N) then
 393             declare
 394                Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
 395             begin
 396                if Nkind (Decl) = N_Subprogram_Declaration
 397                  and then Present (Corresponding_Body (Decl))
 398                then
 399                   Loc := Sloc (Corresponding_Body (Decl));
 400                end if;
 401             end;
 402          end if;
 403
 404       else
 405          Obj := N;
 406       end if;
 407
 408       if Is_Array_Type (T) then
 409          Constraints := New_List;
 410          for J in 1 .. Number_Dimensions (T) loop
 411
 412             --  Build an array subtype declaration with the nominal subtype and
 413             --  the bounds of the actual. Add the declaration in front of the
 414             --  local declarations for the subprogram, for analysis before any
 415             --  reference to the formal in the body.
 416
 417             Lo :=
 418               Make_Attribute_Reference (Loc,
 419                 Prefix         =>
 420                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 421                 Attribute_Name => Name_First,
 422                 Expressions    => New_List (
 423                   Make_Integer_Literal (Loc, J)));
 424
 425             Hi :=
 426               Make_Attribute_Reference (Loc,
 427                 Prefix         =>
 428                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 429                 Attribute_Name => Name_Last,
 430                 Expressions    => New_List (
 431                   Make_Integer_Literal (Loc, J)));
 432
 433             Append (Make_Range (Loc, Lo, Hi), Constraints);
 434          end loop;
 435
 436       --  If the type has unknown discriminants there is no constrained
 437       --  subtype to build. This is never called for a formal or for a
 438       --  lhs, so returning the type is ok ???
 439
 440       elsif Has_Unknown_Discriminants (T) then
 441          return T;
 442
 443       else
 444          Constraints := New_List;
 445
 446          --  Type T is a generic derived type, inherit the discriminants from
 447          --  the parent type.
 448
 449          if Is_Private_Type (T)
 450            and then No (Full_View (T))
 451
 452             --  T was flagged as an error if it was declared as a formal
 453             --  derived type with known discriminants. In this case there
 454             --  is no need to look at the parent type since T already carries
 455             --  its own discriminants.
 456
 457            and then not Error_Posted (T)
 458          then
 459             Disc_Type := Etype (Base_Type (T));
 460          else
 461             Disc_Type := T;
 462          end if;
 463
 464          Discr := First_Discriminant (Disc_Type);
 465          while Present (Discr) loop
 466             Append_To (Constraints,
 467               Make_Selected_Component (Loc,
 468                 Prefix =>
 469                   Duplicate_Subexpr_No_Checks (Obj),
 470                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 471             Next_Discriminant (Discr);
 472          end loop;
 473       end if;
 474
 475       Subt := Make_Temporary (Loc, 'S', Related_Node => N);
 476       Set_Is_Internal (Subt);
 477
 478       Decl :=
 479         Make_Subtype_Declaration (Loc,
 480           Defining_Identifier => Subt,
 481           Subtype_Indication =>
 482             Make_Subtype_Indication (Loc,
 483               Subtype_Mark => New_Reference_To (T,  Loc),
 484               Constraint  =>
 485                 Make_Index_Or_Discriminant_Constraint (Loc,
 486                   Constraints => Constraints)));
 487
 488       Mark_Rewrite_Insertion (Decl);
 489       return Decl;
 490    end Build_Actual_Subtype;
 491
 492    ---------------------------------------
 493    -- Build_Actual_Subtype_Of_Component --
 494    ---------------------------------------
 495
 496    function Build_Actual_Subtype_Of_Component
 497      (T : Entity_Id;
 498       N : Node_Id) return Node_Id
 499    is
 500       Loc       : constant Source_Ptr := Sloc (N);
 501       P         : constant Node_Id    := Prefix (N);
 502       D         : Elmt_Id;
 503       Id        : Node_Id;
 504       Indx_Type : Entity_Id;
 505
 506       Deaccessed_T : Entity_Id;
 507       --  This is either a copy of T, or if T is an access type, then it is
 508       --  the directly designated type of this access type.
 509
 510       function Build_Actual_Array_Constraint return List_Id;
 511       --  If one or more of the bounds of the component depends on
 512       --  discriminants, build  actual constraint using the discriminants
 513       --  of the prefix.
 514
 515       function Build_Actual_Record_Constraint return List_Id;
 516       --  Similar to previous one, for discriminated components constrained
 517       --  by the discriminant of the enclosing object.
 518
 519       -----------------------------------
 520       -- Build_Actual_Array_Constraint --
 521       -----------------------------------
 522
 523       function Build_Actual_Array_Constraint return List_Id is
 524          Constraints : constant List_Id := New_List;
 525          Indx        : Node_Id;
 526          Hi          : Node_Id;
 527          Lo          : Node_Id;
 528          Old_Hi      : Node_Id;
 529          Old_Lo      : Node_Id;
 530
 531       begin
 532          Indx := First_Index (Deaccessed_T);
 533          while Present (Indx) loop
 534             Old_Lo := Type_Low_Bound  (Etype (Indx));
 535             Old_Hi := Type_High_Bound (Etype (Indx));
 536
 537             if Denotes_Discriminant (Old_Lo) then
 538                Lo :=
 539                  Make_Selected_Component (Loc,
 540                    Prefix => New_Copy_Tree (P),
 541                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 542
 543             else
 544                Lo := New_Copy_Tree (Old_Lo);
 545
 546                --  The new bound will be reanalyzed in the enclosing
 547                --  declaration. For literal bounds that come from a type
 548                --  declaration, the type of the context must be imposed, so
 549                --  insure that analysis will take place. For non-universal
 550                --  types this is not strictly necessary.
 551
 552                Set_Analyzed (Lo, False);
 553             end if;
 554
 555             if Denotes_Discriminant (Old_Hi) then
 556                Hi :=
 557                  Make_Selected_Component (Loc,
 558                    Prefix => New_Copy_Tree (P),
 559                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 560
 561             else
 562                Hi := New_Copy_Tree (Old_Hi);
 563                Set_Analyzed (Hi, False);
 564             end if;
 565
 566             Append (Make_Range (Loc, Lo, Hi), Constraints);
 567             Next_Index (Indx);
 568          end loop;
 569
 570          return Constraints;
 571       end Build_Actual_Array_Constraint;
 572
 573       ------------------------------------
 574       -- Build_Actual_Record_Constraint --
 575       ------------------------------------
 576
 577       function Build_Actual_Record_Constraint return List_Id is
 578          Constraints : constant List_Id := New_List;
 579          D           : Elmt_Id;
 580          D_Val       : Node_Id;
 581
 582       begin
 583          D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
 584          while Present (D) loop
 585             if Denotes_Discriminant (Node (D)) then
 586                D_Val :=  Make_Selected_Component (Loc,
 587                  Prefix => New_Copy_Tree (P),
 588                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 589
 590             else
 591                D_Val := New_Copy_Tree (Node (D));
 592             end if;
 593
 594             Append (D_Val, Constraints);
 595             Next_Elmt (D);
 596          end loop;
 597
 598          return Constraints;
 599       end Build_Actual_Record_Constraint;
 600
 601    --  Start of processing for Build_Actual_Subtype_Of_Component
 602
 603    begin
 604       --  Why the test for Spec_Expression mode here???
 605
 606       if In_Spec_Expression then
 607          return Empty;
 608
 609       --  More comments for the rest of this body would be good ???
 610
 611       elsif Nkind (N) = N_Explicit_Dereference then
 612          if Is_Composite_Type (T)
 613            and then not Is_Constrained (T)
 614            and then not (Is_Class_Wide_Type (T)
 615                           and then Is_Constrained (Root_Type (T)))
 616            and then not Has_Unknown_Discriminants (T)
 617          then
 618             --  If the type of the dereference is already constrained, it is an
 619             --  actual subtype.
 620
 621             if Is_Array_Type (Etype (N))
 622               and then Is_Constrained (Etype (N))
 623             then
 624                return Empty;
 625             else
 626                Remove_Side_Effects (P);
 627                return Build_Actual_Subtype (T, N);
 628             end if;
 629          else
 630             return Empty;
 631          end if;
 632       end if;
 633
 634       if Ekind (T) = E_Access_Subtype then
 635          Deaccessed_T := Designated_Type (T);
 636       else
 637          Deaccessed_T := T;
 638       end if;
 639
 640       if Ekind (Deaccessed_T) = E_Array_Subtype then
 641          Id := First_Index (Deaccessed_T);
 642          while Present (Id) loop
 643             Indx_Type := Underlying_Type (Etype (Id));
 644
 645             if Denotes_Discriminant (Type_Low_Bound  (Indx_Type))
 646                  or else
 647                Denotes_Discriminant (Type_High_Bound (Indx_Type))
 648             then
 649                Remove_Side_Effects (P);
 650                return
 651                  Build_Component_Subtype
 652                    (Build_Actual_Array_Constraint, Loc, Base_Type (T));
 653             end if;
 654
 655             Next_Index (Id);
 656          end loop;
 657
 658       elsif Is_Composite_Type (Deaccessed_T)
 659         and then Has_Discriminants (Deaccessed_T)
 660         and then not Has_Unknown_Discriminants (Deaccessed_T)
 661       then
 662          D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
 663          while Present (D) loop
 664             if Denotes_Discriminant (Node (D)) then
 665                Remove_Side_Effects (P);
 666                return
 667                  Build_Component_Subtype (
 668                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
 669             end if;
 670
 671             Next_Elmt (D);
 672          end loop;
 673       end if;
 674
 675       --  If none of the above, the actual and nominal subtypes are the same
 676
 677       return Empty;
 678    end Build_Actual_Subtype_Of_Component;
 679
 680    -----------------------------
 681    -- Build_Component_Subtype --
 682    -----------------------------
 683
 684    function Build_Component_Subtype
 685      (C   : List_Id;
 686       Loc : Source_Ptr;
 687       T   : Entity_Id) return Node_Id
 688    is
 689       Subt : Entity_Id;
 690       Decl : Node_Id;
 691
 692    begin
 693       --  Unchecked_Union components do not require component subtypes
 694
 695       if Is_Unchecked_Union (T) then
 696          return Empty;
 697       end if;
 698
 699       Subt := Make_Temporary (Loc, 'S');
 700       Set_Is_Internal (Subt);
 701
 702       Decl :=
 703         Make_Subtype_Declaration (Loc,
 704           Defining_Identifier => Subt,
 705           Subtype_Indication =>
 706             Make_Subtype_Indication (Loc,
 707               Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
 708               Constraint  =>
 709                 Make_Index_Or_Discriminant_Constraint (Loc,
 710                   Constraints => C)));
 711
 712       Mark_Rewrite_Insertion (Decl);
 713       return Decl;
 714    end Build_Component_Subtype;
 715
 716    ---------------------------
 717    -- Build_Default_Subtype --
 718    ---------------------------
 719
 720    function Build_Default_Subtype
 721      (T : Entity_Id;
 722       N : Node_Id) return Entity_Id
 723    is
 724       Loc  : constant Source_Ptr := Sloc (N);
 725       Disc : Entity_Id;
 726
 727    begin
 728       if not Has_Discriminants (T) or else Is_Constrained (T) then
 729          return T;
 730       end if;
 731
 732       Disc := First_Discriminant (T);
 733
 734       if No (Discriminant_Default_Value (Disc)) then
 735          return T;
 736       end if;
 737
 738       declare
 739          Act         : constant Entity_Id := Make_Temporary (Loc, 'S');
 740          Constraints : constant List_Id := New_List;
 741          Decl        : Node_Id;
 742
 743       begin
 744          while Present (Disc) loop
 745             Append_To (Constraints,
 746               New_Copy_Tree (Discriminant_Default_Value (Disc)));
 747             Next_Discriminant (Disc);
 748          end loop;
 749
 750          Decl :=
 751            Make_Subtype_Declaration (Loc,
 752              Defining_Identifier => Act,
 753              Subtype_Indication =>
 754                Make_Subtype_Indication (Loc,
 755                  Subtype_Mark => New_Occurrence_Of (T, Loc),
 756                  Constraint =>
 757                    Make_Index_Or_Discriminant_Constraint (Loc,
 758                      Constraints => Constraints)));
 759
 760          Insert_Action (N, Decl);
 761          Analyze (Decl);
 762          return Act;
 763       end;
 764    end Build_Default_Subtype;
 765
 766    --------------------------------------------
 767    -- Build_Discriminal_Subtype_Of_Component --
 768    --------------------------------------------
 769
 770    function Build_Discriminal_Subtype_Of_Component
 771      (T : Entity_Id) return Node_Id
 772    is
 773       Loc : constant Source_Ptr := Sloc (T);
 774       D   : Elmt_Id;
 775       Id  : Node_Id;
 776
 777       function Build_Discriminal_Array_Constraint return List_Id;
 778       --  If one or more of the bounds of the component depends on
 779       --  discriminants, build  actual constraint using the discriminants
 780       --  of the prefix.
 781
 782       function Build_Discriminal_Record_Constraint return List_Id;
 783       --  Similar to previous one, for discriminated components constrained
 784       --  by the discriminant of the enclosing object.
 785
 786       ----------------------------------------
 787       -- Build_Discriminal_Array_Constraint --
 788       ----------------------------------------
 789
 790       function Build_Discriminal_Array_Constraint return List_Id is
 791          Constraints : constant List_Id := New_List;
 792          Indx        : Node_Id;
 793          Hi          : Node_Id;
 794          Lo          : Node_Id;
 795          Old_Hi      : Node_Id;
 796          Old_Lo      : Node_Id;
 797
 798       begin
 799          Indx := First_Index (T);
 800          while Present (Indx) loop
 801             Old_Lo := Type_Low_Bound  (Etype (Indx));
 802             Old_Hi := Type_High_Bound (Etype (Indx));
 803
 804             if Denotes_Discriminant (Old_Lo) then
 805                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
 806
 807             else
 808                Lo := New_Copy_Tree (Old_Lo);
 809             end if;
 810
 811             if Denotes_Discriminant (Old_Hi) then
 812                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
 813
 814             else
 815                Hi := New_Copy_Tree (Old_Hi);
 816             end if;
 817
 818             Append (Make_Range (Loc, Lo, Hi), Constraints);
 819             Next_Index (Indx);
 820          end loop;
 821
 822          return Constraints;
 823       end Build_Discriminal_Array_Constraint;
 824
 825       -----------------------------------------
 826       -- Build_Discriminal_Record_Constraint --
 827       -----------------------------------------
 828
 829       function Build_Discriminal_Record_Constraint return List_Id is
 830          Constraints : constant List_Id := New_List;
 831          D           : Elmt_Id;
 832          D_Val       : Node_Id;
 833
 834       begin
 835          D := First_Elmt (Discriminant_Constraint (T));
 836          while Present (D) loop
 837             if Denotes_Discriminant (Node (D)) then
 838                D_Val :=
 839                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
 840
 841             else
 842                D_Val := New_Copy_Tree (Node (D));
 843             end if;
 844
 845             Append (D_Val, Constraints);
 846             Next_Elmt (D);
 847          end loop;
 848
 849          return Constraints;
 850       end Build_Discriminal_Record_Constraint;
 851
 852    --  Start of processing for Build_Discriminal_Subtype_Of_Component
 853
 854    begin
 855       if Ekind (T) = E_Array_Subtype then
 856          Id := First_Index (T);
 857          while Present (Id) loop
 858             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
 859                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
 860             then
 861                return Build_Component_Subtype
 862                  (Build_Discriminal_Array_Constraint, Loc, T);
 863             end if;
 864
 865             Next_Index (Id);
 866          end loop;
 867
 868       elsif Ekind (T) = E_Record_Subtype
 869         and then Has_Discriminants (T)
 870         and then not Has_Unknown_Discriminants (T)
 871       then
 872          D := First_Elmt (Discriminant_Constraint (T));
 873          while Present (D) loop
 874             if Denotes_Discriminant (Node (D)) then
 875                return Build_Component_Subtype
 876                  (Build_Discriminal_Record_Constraint, Loc, T);
 877             end if;
 878
 879             Next_Elmt (D);
 880          end loop;
 881       end if;
 882
 883       --  If none of the above, the actual and nominal subtypes are the same
 884
 885       return Empty;
 886    end Build_Discriminal_Subtype_Of_Component;
 887
 888    ------------------------------
 889    -- Build_Elaboration_Entity --
 890    ------------------------------
 891
 892    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
 893       Loc      : constant Source_Ptr := Sloc (N);
 894       Decl     : Node_Id;
 895       Elab_Ent : Entity_Id;
 896
 897       procedure Set_Package_Name (Ent : Entity_Id);
 898       --  Given an entity, sets the fully qualified name of the entity in
 899       --  Name_Buffer, with components separated by double underscores. This
 900       --  is a recursive routine that climbs the scope chain to Standard.
 901
 902       ----------------------
 903       -- Set_Package_Name --
 904       ----------------------
 905
 906       procedure Set_Package_Name (Ent : Entity_Id) is
 907       begin
 908          if Scope (Ent) /= Standard_Standard then
 909             Set_Package_Name (Scope (Ent));
 910
 911             declare
 912                Nam : constant String := Get_Name_String (Chars (Ent));
 913             begin
 914                Name_Buffer (Name_Len + 1) := '_';
 915                Name_Buffer (Name_Len + 2) := '_';
 916                Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
 917                Name_Len := Name_Len + Nam'Length + 2;
 918             end;
 919
 920          else
 921             Get_Name_String (Chars (Ent));
 922          end if;
 923       end Set_Package_Name;
 924
 925    --  Start of processing for Build_Elaboration_Entity
 926
 927    begin
 928       --  Ignore if already constructed
 929
 930       if Present (Elaboration_Entity (Spec_Id)) then
 931          return;
 932       end if;
 933
 934       --  Construct name of elaboration entity as xxx_E, where xxx is the unit
 935       --  name with dots replaced by double underscore. We have to manually
 936       --  construct this name, since it will be elaborated in the outer scope,
 937       --  and thus will not have the unit name automatically prepended.
 938
 939       Set_Package_Name (Spec_Id);
 940
 941       --  Append _E
 942
 943       Name_Buffer (Name_Len + 1) := '_';
 944       Name_Buffer (Name_Len + 2) := 'E';
 945       Name_Len := Name_Len + 2;
 946
 947       --  Create elaboration flag
 948
 949       Elab_Ent :=
 950         Make_Defining_Identifier (Loc, Chars => Name_Find);
 951       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
 952
 953       Decl :=
 954          Make_Object_Declaration (Loc,
 955            Defining_Identifier => Elab_Ent,
 956            Object_Definition   =>
 957              New_Occurrence_Of (Standard_Boolean, Loc),
 958            Expression          =>
 959              New_Occurrence_Of (Standard_False, Loc));
 960
 961       Push_Scope (Standard_Standard);
 962       Add_Global_Declaration (Decl);
 963       Pop_Scope;
 964
 965       --  Reset True_Constant indication, since we will indeed assign a value
 966       --  to the variable in the binder main. We also kill the Current_Value
 967       --  and Last_Assignment fields for the same reason.
 968
 969       Set_Is_True_Constant (Elab_Ent, False);
 970       Set_Current_Value    (Elab_Ent, Empty);
 971       Set_Last_Assignment  (Elab_Ent, Empty);
 972
 973       --  We do not want any further qualification of the name (if we did
 974       --  not do this, we would pick up the name of the generic package
 975       --  in the case of a library level generic instantiation).
 976
 977       Set_Has_Qualified_Name       (Elab_Ent);
 978       Set_Has_Fully_Qualified_Name (Elab_Ent);
 979    end Build_Elaboration_Entity;
 980
 981    -----------------------------------
 982    -- Cannot_Raise_Constraint_Error --
 983    -----------------------------------
 984
 985    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
 986    begin
 987       if Compile_Time_Known_Value (Expr) then
 988          return True;
 989
 990       elsif Do_Range_Check (Expr) then
 991          return False;
 992
 993       elsif Raises_Constraint_Error (Expr) then
 994          return False;
 995
 996       else
 997          case Nkind (Expr) is
 998             when N_Identifier =>
 999                return True;
1000
1001             when N_Expanded_Name =>
1002                return True;
1003
1004             when N_Selected_Component =>
1005                return not Do_Discriminant_Check (Expr);
1006
1007             when N_Attribute_Reference =>
1008                if Do_Overflow_Check (Expr) then
1009                   return False;
1010
1011                elsif No (Expressions (Expr)) then
1012                   return True;
1013
1014                else
1015                   declare
1016                      N : Node_Id;
1017
1018                   begin
1019                      N := First (Expressions (Expr));
1020                      while Present (N) loop
1021                         if Cannot_Raise_Constraint_Error (N) then
1022                            Next (N);
1023                         else
1024                            return False;
1025                         end if;
1026                      end loop;
1027
1028                      return True;
1029                   end;
1030                end if;
1031
1032             when N_Type_Conversion =>
1033                if Do_Overflow_Check (Expr)
1034                  or else Do_Length_Check (Expr)
1035                  or else Do_Tag_Check (Expr)
1036                then
1037                   return False;
1038                else
1039                   return
1040                     Cannot_Raise_Constraint_Error (Expression (Expr));
1041                end if;
1042
1043             when N_Unchecked_Type_Conversion =>
1044                return Cannot_Raise_Constraint_Error (Expression (Expr));
1045
1046             when N_Unary_Op =>
1047                if Do_Overflow_Check (Expr) then
1048                   return False;
1049                else
1050                   return
1051                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1052                end if;
1053
1054             when N_Op_Divide |
1055                  N_Op_Mod    |
1056                  N_Op_Rem
1057             =>
1058                if Do_Division_Check (Expr)
1059                  or else Do_Overflow_Check (Expr)
1060                then
1061                   return False;
1062                else
1063                   return
1064                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1065                       and then
1066                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1067                end if;
1068
1069             when N_Op_Add                    |
1070                  N_Op_And                    |
1071                  N_Op_Concat                 |
1072                  N_Op_Eq                     |
1073                  N_Op_Expon                  |
1074                  N_Op_Ge                     |
1075                  N_Op_Gt                     |
1076                  N_Op_Le                     |
1077                  N_Op_Lt                     |
1078                  N_Op_Multiply               |
1079                  N_Op_Ne                     |
1080                  N_Op_Or                     |
1081                  N_Op_Rotate_Left            |
1082                  N_Op_Rotate_Right           |
1083                  N_Op_Shift_Left             |
1084                  N_Op_Shift_Right            |
1085                  N_Op_Shift_Right_Arithmetic |
1086                  N_Op_Subtract               |
1087                  N_Op_Xor
1088             =>
1089                if Do_Overflow_Check (Expr) then
1090                   return False;
1091                else
1092                   return
1093                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1094                       and then
1095                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1096                end if;
1097
1098             when others =>
1099                return False;
1100          end case;
1101       end if;
1102    end Cannot_Raise_Constraint_Error;
1103
1104    ---------------------------------------
1105    -- Check_Later_Vs_Basic_Declarations --
1106    ---------------------------------------
1107
1108    procedure Check_Later_Vs_Basic_Declarations
1109      (Decls          : List_Id;
1110       During_Parsing : Boolean)
1111    is
1112       Body_Sloc : Source_Ptr;
1113       Decl      : Node_Id;
1114
1115       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
1116       --  Return whether Decl is considered as a declarative item.
1117       --  When During_Parsing is True, the semantics of Ada 83 is followed.
1118       --  When During_Parsing is False, the semantics of SPARK is followed.
1119
1120       -------------------------------
1121       -- Is_Later_Declarative_Item --
1122       -------------------------------
1123
1124       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
1125       begin
1126          if Nkind (Decl) in N_Later_Decl_Item then
1127             return True;
1128
1129          elsif Nkind (Decl) = N_Pragma then
1130             return True;
1131
1132          elsif During_Parsing then
1133             return False;
1134
1135          --  In SPARK, a package declaration is not considered as a later
1136          --  declarative item.
1137
1138          elsif Nkind (Decl) = N_Package_Declaration then
1139             return False;
1140
1141          --  In SPARK, a renaming is considered as a later declarative item
1142
1143          elsif Nkind (Decl) in N_Renaming_Declaration then
1144             return True;
1145
1146          else
1147             return False;
1148          end if;
1149       end Is_Later_Declarative_Item;
1150
1151    --  Start of Check_Later_Vs_Basic_Declarations
1152
1153    begin
1154       Decl := First (Decls);
1155
1156       --  Loop through sequence of basic declarative items
1157
1158       Outer : while Present (Decl) loop
1159          if Nkind (Decl) /= N_Subprogram_Body
1160            and then Nkind (Decl) /= N_Package_Body
1161            and then Nkind (Decl) /= N_Task_Body
1162            and then Nkind (Decl) not in N_Body_Stub
1163          then
1164             Next (Decl);
1165
1166             --  Once a body is encountered, we only allow later declarative
1167             --  items. The inner loop checks the rest of the list.
1168
1169          else
1170             Body_Sloc := Sloc (Decl);
1171
1172             Inner : while Present (Decl) loop
1173                if not Is_Later_Declarative_Item (Decl) then
1174                   if During_Parsing then
1175                      if Ada_Version = Ada_83 then
1176                         Error_Msg_Sloc := Body_Sloc;
1177                         Error_Msg_N
1178                           ("(Ada 83) decl cannot appear after body#", Decl);
1179                      end if;
1180                   else
1181                      Error_Msg_Sloc := Body_Sloc;
1182                      Check_Formal_Restriction
1183                        ("decl cannot appear after body#", Decl);
1184                   end if;
1185                end if;
1186
1187                Next (Decl);
1188             end loop Inner;
1189          end if;
1190       end loop Outer;
1191    end Check_Later_Vs_Basic_Declarations;
1192
1193    -----------------------------------------
1194    -- Check_Dynamically_Tagged_Expression --
1195    -----------------------------------------
1196
1197    procedure Check_Dynamically_Tagged_Expression
1198      (Expr        : Node_Id;
1199       Typ         : Entity_Id;
1200       Related_Nod : Node_Id)
1201    is
1202    begin
1203       pragma Assert (Is_Tagged_Type (Typ));
1204
1205       --  In order to avoid spurious errors when analyzing the expanded code,
1206       --  this check is done only for nodes that come from source and for
1207       --  actuals of generic instantiations.
1208
1209       if (Comes_From_Source (Related_Nod)
1210            or else In_Generic_Actual (Expr))
1211         and then (Is_Class_Wide_Type (Etype (Expr))
1212                    or else Is_Dynamically_Tagged (Expr))
1213         and then Is_Tagged_Type (Typ)
1214         and then not Is_Class_Wide_Type (Typ)
1215       then
1216          Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1217       end if;
1218    end Check_Dynamically_Tagged_Expression;
1219
1220    --------------------------
1221    -- Check_Fully_Declared --
1222    --------------------------
1223
1224    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1225    begin
1226       if Ekind (T) = E_Incomplete_Type then
1227
1228          --  Ada 2005 (AI-50217): If the type is available through a limited
1229          --  with_clause, verify that its full view has been analyzed.
1230
1231          if From_With_Type (T)
1232            and then Present (Non_Limited_View (T))
1233            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1234          then
1235             --  The non-limited view is fully declared
1236             null;
1237
1238          else
1239             Error_Msg_NE
1240               ("premature usage of incomplete}", N, First_Subtype (T));
1241          end if;
1242
1243       --  Need comments for these tests ???
1244
1245       elsif Has_Private_Component (T)
1246         and then not Is_Generic_Type (Root_Type (T))
1247         and then not In_Spec_Expression
1248       then
1249          --  Special case: if T is the anonymous type created for a single
1250          --  task or protected object, use the name of the source object.
1251
1252          if Is_Concurrent_Type (T)
1253            and then not Comes_From_Source (T)
1254            and then Nkind (N) = N_Object_Declaration
1255          then
1256             Error_Msg_NE ("type of& has incomplete component", N,
1257               Defining_Identifier (N));
1258
1259          else
1260             Error_Msg_NE
1261               ("premature usage of incomplete}", N, First_Subtype (T));
1262          end if;
1263       end if;
1264    end Check_Fully_Declared;
1265
1266    -------------------------
1267    -- Check_Nested_Access --
1268    -------------------------
1269
1270    procedure Check_Nested_Access (Ent : Entity_Id) is
1271       Scop         : constant Entity_Id := Current_Scope;
1272       Current_Subp : Entity_Id;
1273       Enclosing    : Entity_Id;
1274
1275    begin
1276       --  Currently only enabled for VM back-ends for efficiency, should we
1277       --  enable it more systematically ???
1278
1279       --  Check for Is_Imported needs commenting below ???
1280
1281       if VM_Target /= No_VM
1282         and then (Ekind (Ent) = E_Variable
1283                     or else
1284                   Ekind (Ent) = E_Constant
1285                     or else
1286                   Ekind (Ent) = E_Loop_Parameter)
1287         and then Scope (Ent) /= Empty
1288         and then not Is_Library_Level_Entity (Ent)
1289         and then not Is_Imported (Ent)
1290       then
1291          if Is_Subprogram (Scop)
1292            or else Is_Generic_Subprogram (Scop)
1293            or else Is_Entry (Scop)
1294          then
1295             Current_Subp := Scop;
1296          else
1297             Current_Subp := Current_Subprogram;
1298          end if;
1299
1300          Enclosing := Enclosing_Subprogram (Ent);
1301
1302          if Enclosing /= Empty
1303            and then Enclosing /= Current_Subp
1304          then
1305             Set_Has_Up_Level_Access (Ent, True);
1306          end if;
1307       end if;
1308    end Check_Nested_Access;
1309
1310    ----------------------------
1311    -- Check_Order_Dependence --
1312    ----------------------------
1313
1314    procedure Check_Order_Dependence is
1315       Act1 : Node_Id;
1316       Act2 : Node_Id;
1317
1318    begin
1319       if Ada_Version < Ada_2012 then
1320          return;
1321       end if;
1322
1323       --  Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested
1324       --  calls within a construct have been collected. If one of them is
1325       --  writable and overlaps with another one, evaluation of the enclosing
1326       --  construct is nondeterministic. This is illegal in Ada 2012, but is
1327       --  treated as a warning for now.
1328
1329       for J in 1 .. Actuals_In_Call.Last loop
1330          if Actuals_In_Call.Table (J).Is_Writable then
1331             Act1 := Actuals_In_Call.Table (J).Act;
1332
1333             if Nkind (Act1) = N_Attribute_Reference then
1334                Act1 := Prefix (Act1);
1335             end if;
1336
1337             for K in 1 .. Actuals_In_Call.Last loop
1338                if K /= J then
1339                   Act2 := Actuals_In_Call.Table (K).Act;
1340
1341                   if Nkind (Act2) = N_Attribute_Reference then
1342                      Act2 := Prefix (Act2);
1343                   end if;
1344
1345                   if Actuals_In_Call.Table (K).Is_Writable
1346                     and then K < J
1347                   then
1348                      --  Already checked
1349
1350                      null;
1351
1352                   elsif Denotes_Same_Object (Act1, Act2)
1353                     and then Parent (Act1) /= Parent (Act2)
1354                   then
1355                      Error_Msg_N
1356                        ("result may differ if evaluated "
1357                         & "after other actual in expression?", Act1);
1358                   end if;
1359                end if;
1360             end loop;
1361          end if;
1362       end loop;
1363
1364       --  Remove checked actuals from table
1365
1366       Actuals_In_Call.Set_Last (0);
1367    end Check_Order_Dependence;
1368
1369    ------------------------------------------
1370    -- Check_Potentially_Blocking_Operation --
1371    ------------------------------------------
1372
1373    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
1374       S : Entity_Id;
1375
1376    begin
1377       --  N is one of the potentially blocking operations listed in 9.5.1(8).
1378       --  When pragma Detect_Blocking is active, the run time will raise
1379       --  Program_Error. Here we only issue a warning, since we generally
1380       --  support the use of potentially blocking operations in the absence
1381       --  of the pragma.
1382
1383       --  Indirect blocking through a subprogram call cannot be diagnosed
1384       --  statically without interprocedural analysis, so we do not attempt
1385       --  to do it here.
1386
1387       S := Scope (Current_Scope);
1388       while Present (S) and then S /= Standard_Standard loop
1389          if Is_Protected_Type (S) then
1390             Error_Msg_N
1391               ("potentially blocking operation in protected operation?", N);
1392             return;
1393          end if;
1394
1395          S := Scope (S);
1396       end loop;
1397    end Check_Potentially_Blocking_Operation;
1398
1399    ------------------------------
1400    -- Check_Unprotected_Access --
1401    ------------------------------
1402
1403    procedure Check_Unprotected_Access
1404      (Context : Node_Id;
1405       Expr    : Node_Id)
1406    is
1407       Cont_Encl_Typ : Entity_Id;
1408       Pref_Encl_Typ : Entity_Id;
1409
1410       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
1411       --  Check whether Obj is a private component of a protected object.
1412       --  Return the protected type where the component resides, Empty
1413       --  otherwise.
1414
1415       function Is_Public_Operation return Boolean;
1416       --  Verify that the enclosing operation is callable from outside the
1417       --  protected object, to minimize false positives.
1418
1419       ------------------------------
1420       -- Enclosing_Protected_Type --
1421       ------------------------------
1422
1423       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
1424       begin
1425          if Is_Entity_Name (Obj) then
1426             declare
1427                Ent : Entity_Id := Entity (Obj);
1428
1429             begin
1430                --  The object can be a renaming of a private component, use
1431                --  the original record component.
1432
1433                if Is_Prival (Ent) then
1434                   Ent := Prival_Link (Ent);
1435                end if;
1436
1437                if Is_Protected_Type (Scope (Ent)) then
1438                   return Scope (Ent);
1439                end if;
1440             end;
1441          end if;
1442
1443          --  For indexed and selected components, recursively check the prefix
1444
1445          if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
1446             return Enclosing_Protected_Type (Prefix (Obj));
1447
1448          --  The object does not denote a protected component
1449
1450          else
1451             return Empty;
1452          end if;
1453       end Enclosing_Protected_Type;
1454
1455       -------------------------
1456       -- Is_Public_Operation --
1457       -------------------------
1458
1459       function Is_Public_Operation return Boolean is
1460          S : Entity_Id;
1461          E : Entity_Id;
1462
1463       begin
1464          S := Current_Scope;
1465          while Present (S)
1466            and then S /= Pref_Encl_Typ
1467          loop
1468             if Scope (S) = Pref_Encl_Typ then
1469                E := First_Entity (Pref_Encl_Typ);
1470                while Present (E)
1471                  and then E /= First_Private_Entity (Pref_Encl_Typ)
1472                loop
1473                   if E = S then
1474                      return True;
1475                   end if;
1476                   Next_Entity (E);
1477                end loop;
1478             end if;
1479
1480             S := Scope (S);
1481          end loop;
1482
1483          return False;
1484       end Is_Public_Operation;
1485
1486    --  Start of processing for Check_Unprotected_Access
1487
1488    begin
1489       if Nkind (Expr) = N_Attribute_Reference
1490         and then Attribute_Name (Expr) = Name_Unchecked_Access
1491       then
1492          Cont_Encl_Typ := Enclosing_Protected_Type (Context);
1493          Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
1494
1495          --  Check whether we are trying to export a protected component to a
1496          --  context with an equal or lower access level.
1497
1498          if Present (Pref_Encl_Typ)
1499            and then No (Cont_Encl_Typ)
1500            and then Is_Public_Operation
1501            and then Scope_Depth (Pref_Encl_Typ) >=
1502                       Object_Access_Level (Context)
1503          then
1504             Error_Msg_N
1505               ("?possible unprotected access to protected data", Expr);
1506          end if;
1507       end if;
1508    end Check_Unprotected_Access;
1509
1510    ---------------
1511    -- Check_VMS --
1512    ---------------
1513
1514    procedure Check_VMS (Construct : Node_Id) is
1515    begin
1516       if not OpenVMS_On_Target then
1517          Error_Msg_N
1518            ("this construct is allowed only in Open'V'M'S", Construct);
1519       end if;
1520    end Check_VMS;
1521
1522    ------------------------
1523    -- Collect_Interfaces --
1524    ------------------------
1525
1526    procedure Collect_Interfaces
1527      (T               : Entity_Id;
1528       Ifaces_List     : out Elist_Id;
1529       Exclude_Parents : Boolean := False;
1530       Use_Full_View   : Boolean := True)
1531    is
1532       procedure Collect (Typ : Entity_Id);
1533       --  Subsidiary subprogram used to traverse the whole list
1534       --  of directly and indirectly implemented interfaces
1535
1536       -------------
1537       -- Collect --
1538       -------------
1539
1540       procedure Collect (Typ : Entity_Id) is
1541          Ancestor   : Entity_Id;
1542          Full_T     : Entity_Id;
1543          Id         : Node_Id;
1544          Iface      : Entity_Id;
1545
1546       begin
1547          Full_T := Typ;
1548
1549          --  Handle private types
1550
1551          if Use_Full_View
1552            and then Is_Private_Type (Typ)
1553            and then Present (Full_View (Typ))
1554          then
1555             Full_T := Full_View (Typ);
1556          end if;
1557
1558          --  Include the ancestor if we are generating the whole list of
1559          --  abstract interfaces.
1560
1561          if Etype (Full_T) /= Typ
1562
1563             --  Protect the frontend against wrong sources. For example:
1564
1565             --    package P is
1566             --      type A is tagged null record;
1567             --      type B is new A with private;
1568             --      type C is new A with private;
1569             --    private
1570             --      type B is new C with null record;
1571             --      type C is new B with null record;
1572             --    end P;
1573
1574            and then Etype (Full_T) /= T
1575          then
1576             Ancestor := Etype (Full_T);
1577             Collect (Ancestor);
1578
1579             if Is_Interface (Ancestor)
1580               and then not Exclude_Parents
1581             then
1582                Append_Unique_Elmt (Ancestor, Ifaces_List);
1583             end if;
1584          end if;
1585
1586          --  Traverse the graph of ancestor interfaces
1587
1588          if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
1589             Id := First (Abstract_Interface_List (Full_T));
1590             while Present (Id) loop
1591                Iface := Etype (Id);
1592
1593                --  Protect against wrong uses. For example:
1594                --    type I is interface;
1595                --    type O is tagged null record;
1596                --    type Wrong is new I and O with null record; -- ERROR
1597
1598                if Is_Interface (Iface) then
1599                   if Exclude_Parents
1600                     and then Etype (T) /= T
1601                     and then Interface_Present_In_Ancestor (Etype (T), Iface)
1602                   then
1603                      null;
1604                   else
1605                      Collect (Iface);
1606                      Append_Unique_Elmt (Iface, Ifaces_List);
1607                   end if;
1608                end if;
1609
1610                Next (Id);
1611             end loop;
1612          end if;
1613       end Collect;
1614
1615    --  Start of processing for Collect_Interfaces
1616
1617    begin
1618       pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
1619       Ifaces_List := New_Elmt_List;
1620       Collect (T);
1621    end Collect_Interfaces;
1622
1623    ----------------------------------
1624    -- Collect_Interface_Components --
1625    ----------------------------------
1626
1627    procedure Collect_Interface_Components
1628      (Tagged_Type     : Entity_Id;
1629       Components_List : out Elist_Id)
1630    is
1631       procedure Collect (Typ : Entity_Id);
1632       --  Subsidiary subprogram used to climb to the parents
1633
1634       -------------
1635       -- Collect --
1636       -------------
1637
1638       procedure Collect (Typ : Entity_Id) is
1639          Tag_Comp   : Entity_Id;
1640          Parent_Typ : Entity_Id;
1641
1642       begin
1643          --  Handle private types
1644
1645          if Present (Full_View (Etype (Typ))) then
1646             Parent_Typ := Full_View (Etype (Typ));
1647          else
1648             Parent_Typ := Etype (Typ);
1649          end if;
1650
1651          if Parent_Typ /= Typ
1652
1653             --  Protect the frontend against wrong sources. For example:
1654
1655             --    package P is
1656             --      type A is tagged null record;
1657             --      type B is new A with private;
1658             --      type C is new A with private;
1659             --    private
1660             --      type B is new C with null record;
1661             --      type C is new B with null record;
1662             --    end P;
1663
1664            and then Parent_Typ /= Tagged_Type
1665          then
1666             Collect (Parent_Typ);
1667          end if;
1668
1669          --  Collect the components containing tags of secondary dispatch
1670          --  tables.
1671
1672          Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
1673          while Present (Tag_Comp) loop
1674             pragma Assert (Present (Related_Type (Tag_Comp)));
1675             Append_Elmt (Tag_Comp, Components_List);
1676
1677             Tag_Comp := Next_Tag_Component (Tag_Comp);
1678          end loop;
1679       end Collect;
1680
1681    --  Start of processing for Collect_Interface_Components
1682
1683    begin
1684       pragma Assert (Ekind (Tagged_Type) = E_Record_Type
1685         and then Is_Tagged_Type (Tagged_Type));
1686
1687       Components_List := New_Elmt_List;
1688       Collect (Tagged_Type);
1689    end Collect_Interface_Components;
1690
1691    -----------------------------
1692    -- Collect_Interfaces_Info --
1693    -----------------------------
1694
1695    procedure Collect_Interfaces_Info
1696      (T               : Entity_Id;
1697       Ifaces_List     : out Elist_Id;
1698       Components_List : out Elist_Id;
1699       Tags_List       : out Elist_Id)
1700    is
1701       Comps_List : Elist_Id;
1702       Comp_Elmt  : Elmt_Id;
1703       Comp_Iface : Entity_Id;
1704       Iface_Elmt : Elmt_Id;
1705       Iface      : Entity_Id;
1706
1707       function Search_Tag (Iface : Entity_Id) return Entity_Id;
1708       --  Search for the secondary tag associated with the interface type
1709       --  Iface that is implemented by T.
1710
1711       ----------------
1712       -- Search_Tag --
1713       ----------------
1714
1715       function Search_Tag (Iface : Entity_Id) return Entity_Id is
1716          ADT : Elmt_Id;
1717       begin
1718          if not Is_CPP_Class (T) then
1719             ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
1720          else
1721             ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
1722          end if;
1723
1724          while Present (ADT)
1725             and then Is_Tag (Node (ADT))
1726             and then Related_Type (Node (ADT)) /= Iface
1727          loop
1728             --  Skip secondary dispatch table referencing thunks to user
1729             --  defined primitives covered by this interface.
1730
1731             pragma Assert (Has_Suffix (Node (ADT), 'P'));
1732             Next_Elmt (ADT);
1733
1734             --  Skip secondary dispatch tables of Ada types
1735
1736             if not Is_CPP_Class (T) then
1737
1738                --  Skip secondary dispatch table referencing thunks to
1739                --  predefined primitives.
1740
1741                pragma Assert (Has_Suffix (Node (ADT), 'Y'));
1742                Next_Elmt (ADT);
1743
1744                --  Skip secondary dispatch table referencing user-defined
1745                --  primitives covered by this interface.
1746
1747                pragma Assert (Has_Suffix (Node (ADT), 'D'));
1748                Next_Elmt (ADT);
1749
1750                --  Skip secondary dispatch table referencing predefined
1751                --  primitives.
1752
1753                pragma Assert (Has_Suffix (Node (ADT), 'Z'));
1754                Next_Elmt (ADT);
1755             end if;
1756          end loop;
1757
1758          pragma Assert (Is_Tag (Node (ADT)));
1759          return Node (ADT);
1760       end Search_Tag;
1761
1762    --  Start of processing for Collect_Interfaces_Info
1763
1764    begin
1765       Collect_Interfaces (T, Ifaces_List);
1766       Collect_Interface_Components (T, Comps_List);
1767
1768       --  Search for the record component and tag associated with each
1769       --  interface type of T.
1770
1771       Components_List := New_Elmt_List;
1772       Tags_List       := New_Elmt_List;
1773
1774       Iface_Elmt := First_Elmt (Ifaces_List);
1775       while Present (Iface_Elmt) loop
1776          Iface := Node (Iface_Elmt);
1777
1778          --  Associate the primary tag component and the primary dispatch table
1779          --  with all the interfaces that are parents of T
1780
1781          if Is_Ancestor (Iface, T, Use_Full_View => True) then
1782             Append_Elmt (First_Tag_Component (T), Components_List);
1783             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
1784
1785          --  Otherwise search for the tag component and secondary dispatch
1786          --  table of Iface
1787
1788          else
1789             Comp_Elmt := First_Elmt (Comps_List);
1790             while Present (Comp_Elmt) loop
1791                Comp_Iface := Related_Type (Node (Comp_Elmt));
1792
1793                if Comp_Iface = Iface
1794                  or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
1795                then
1796                   Append_Elmt (Node (Comp_Elmt), Components_List);
1797                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
1798                   exit;
1799                end if;
1800
1801                Next_Elmt (Comp_Elmt);
1802             end loop;
1803             pragma Assert (Present (Comp_Elmt));
1804          end if;
1805
1806          Next_Elmt (Iface_Elmt);
1807       end loop;
1808    end Collect_Interfaces_Info;
1809
1810    ---------------------
1811    -- Collect_Parents --
1812    ---------------------
1813
1814    procedure Collect_Parents
1815      (T             : Entity_Id;
1816       List          : out Elist_Id;
1817       Use_Full_View : Boolean := True)
1818    is
1819       Current_Typ : Entity_Id := T;
1820       Parent_Typ  : Entity_Id;
1821
1822    begin
1823       List := New_Elmt_List;
1824
1825       --  No action if the if the type has no parents
1826
1827       if T = Etype (T) then
1828          return;
1829       end if;
1830
1831       loop
1832          Parent_Typ := Etype (Current_Typ);
1833
1834          if Is_Private_Type (Parent_Typ)
1835            and then Present (Full_View (Parent_Typ))
1836            and then Use_Full_View
1837          then
1838             Parent_Typ := Full_View (Base_Type (Parent_Typ));
1839          end if;
1840
1841          Append_Elmt (Parent_Typ, List);
1842
1843          exit when Parent_Typ = Current_Typ;
1844          Current_Typ := Parent_Typ;
1845       end loop;
1846    end Collect_Parents;
1847
1848    ----------------------------------
1849    -- Collect_Primitive_Operations --
1850    ----------------------------------
1851
1852    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
1853       B_Type         : constant Entity_Id := Base_Type (T);
1854       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
1855       B_Scope        : Entity_Id          := Scope (B_Type);
1856       Op_List        : Elist_Id;
1857       Formal         : Entity_Id;
1858       Is_Prim        : Boolean;
1859       Formal_Derived : Boolean := False;
1860       Id             : Entity_Id;
1861
1862       function Match (E : Entity_Id) return Boolean;
1863       --  True if E's base type is B_Type, or E is of an anonymous access type
1864       --  and the base type of its designated type is B_Type.
1865
1866       -----------
1867       -- Match --
1868       -----------
1869
1870       function Match (E : Entity_Id) return Boolean is
1871          Etyp : Entity_Id := Etype (E);
1872
1873       begin
1874          if Ekind (Etyp) = E_Anonymous_Access_Type then
1875             Etyp := Designated_Type (Etyp);
1876          end if;
1877
1878          return Base_Type (Etyp) = B_Type;
1879       end Match;
1880
1881    --  Start of processing for Collect_Primitive_Operations
1882
1883    begin
1884       --  For tagged types, the primitive operations are collected as they
1885       --  are declared, and held in an explicit list which is simply returned.
1886
1887       if Is_Tagged_Type (B_Type) then
1888          return Primitive_Operations (B_Type);
1889
1890       --  An untagged generic type that is a derived type inherits the
1891       --  primitive operations of its parent type. Other formal types only
1892       --  have predefined operators, which are not explicitly represented.
1893
1894       elsif Is_Generic_Type (B_Type) then
1895          if Nkind (B_Decl) = N_Formal_Type_Declaration
1896            and then Nkind (Formal_Type_Definition (B_Decl))
1897              = N_Formal_Derived_Type_Definition
1898          then
1899             Formal_Derived := True;
1900          else
1901             return New_Elmt_List;
1902          end if;
1903       end if;
1904
1905       Op_List := New_Elmt_List;
1906
1907       if B_Scope = Standard_Standard then
1908          if B_Type = Standard_String then
1909             Append_Elmt (Standard_Op_Concat, Op_List);
1910
1911          elsif B_Type = Standard_Wide_String then
1912             Append_Elmt (Standard_Op_Concatw, Op_List);
1913
1914          else
1915             null;
1916          end if;
1917
1918       elsif (Is_Package_Or_Generic_Package (B_Scope)
1919               and then
1920                 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
1921                                                             N_Package_Body)
1922         or else Is_Derived_Type (B_Type)
1923       then
1924          --  The primitive operations appear after the base type, except
1925          --  if the derivation happens within the private part of B_Scope
1926          --  and the type is a private type, in which case both the type
1927          --  and some primitive operations may appear before the base
1928          --  type, and the list of candidates starts after the type.
1929
1930          if In_Open_Scopes (B_Scope)
1931            and then Scope (T) = B_Scope
1932            and then In_Private_Part (B_Scope)
1933          then
1934             Id := Next_Entity (T);
1935          else
1936             Id := Next_Entity (B_Type);
1937          end if;
1938
1939          while Present (Id) loop
1940
1941             --  Note that generic formal subprograms are not
1942             --  considered to be primitive operations and thus
1943             --  are never inherited.
1944
1945             if Is_Overloadable (Id)
1946               and then Nkind (Parent (Parent (Id)))
1947                          not in N_Formal_Subprogram_Declaration
1948             then
1949                Is_Prim := False;
1950
1951                if Match (Id) then
1952                   Is_Prim := True;
1953
1954                else
1955                   Formal := First_Formal (Id);
1956                   while Present (Formal) loop
1957                      if Match (Formal) then
1958                         Is_Prim := True;
1959                         exit;
1960                      end if;
1961
1962                      Next_Formal (Formal);
1963                   end loop;
1964                end if;
1965
1966                --  For a formal derived type, the only primitives are the
1967                --  ones inherited from the parent type. Operations appearing
1968                --  in the package declaration are not primitive for it.
1969
1970                if Is_Prim
1971                  and then (not Formal_Derived
1972                             or else Present (Alias (Id)))
1973                then
1974                   --  In the special case of an equality operator aliased to
1975                   --  an overriding dispatching equality belonging to the same
1976                   --  type, we don't include it in the list of primitives.
1977                   --  This avoids inheriting multiple equality operators when
1978                   --  deriving from untagged private types whose full type is
1979                   --  tagged, which can otherwise cause ambiguities. Note that
1980                   --  this should only happen for this kind of untagged parent
1981                   --  type, since normally dispatching operations are inherited
1982                   --  using the type's Primitive_Operations list.
1983
1984                   if Chars (Id) = Name_Op_Eq
1985                     and then Is_Dispatching_Operation (Id)
1986                     and then Present (Alias (Id))
1987                     and then Present (Overridden_Operation (Alias (Id)))
1988                     and then Base_Type (Etype (First_Entity (Id))) =
1989                                Base_Type (Etype (First_Entity (Alias (Id))))
1990                   then
1991                      null;
1992
1993                   --  Include the subprogram in the list of primitives
1994
1995                   else
1996                      Append_Elmt (Id, Op_List);
1997                   end if;
1998                end if;
1999             end if;
2000
2001             Next_Entity (Id);
2002
2003             --  For a type declared in System, some of its operations may
2004             --  appear in the target-specific extension to System.
2005
2006             if No (Id)
2007               and then B_Scope = RTU_Entity (System)
2008               and then Present_System_Aux
2009             then
2010                B_Scope := System_Aux_Id;
2011                Id := First_Entity (System_Aux_Id);
2012             end if;
2013          end loop;
2014       end if;
2015
2016       return Op_List;
2017    end Collect_Primitive_Operations;
2018
2019    -----------------------------------
2020    -- Compile_Time_Constraint_Error --
2021    -----------------------------------
2022
2023    function Compile_Time_Constraint_Error
2024      (N    : Node_Id;
2025       Msg  : String;
2026       Ent  : Entity_Id  := Empty;
2027       Loc  : Source_Ptr := No_Location;
2028       Warn : Boolean    := False) return Node_Id
2029    is
2030       Msgc : String (1 .. Msg'Length + 2);
2031       --  Copy of message, with room for possible ? and ! at end
2032
2033       Msgl : Natural;
2034       Wmsg : Boolean;
2035       P    : Node_Id;
2036       OldP : Node_Id;
2037       Msgs : Boolean;
2038       Eloc : Source_Ptr;
2039
2040    begin
2041       --  A static constraint error in an instance body is not a fatal error.
2042       --  we choose to inhibit the message altogether, because there is no
2043       --  obvious node (for now) on which to post it. On the other hand the
2044       --  offending node must be replaced with a constraint_error in any case.
2045
2046       --  No messages are generated if we already posted an error on this node
2047
2048       if not Error_Posted (N) then
2049          if Loc /= No_Location then
2050             Eloc := Loc;
2051          else
2052             Eloc := Sloc (N);
2053          end if;
2054
2055          Msgc (1 .. Msg'Length) := Msg;
2056          Msgl := Msg'Length;
2057
2058          --  Message is a warning, even in Ada 95 case
2059
2060          if Msg (Msg'Last) = '?' then
2061             Wmsg := True;
2062
2063          --  In Ada 83, all messages are warnings. In the private part and
2064          --  the body of an instance, constraint_checks are only warnings.
2065          --  We also make this a warning if the Warn parameter is set.
2066
2067          elsif Warn
2068            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
2069          then
2070             Msgl := Msgl + 1;
2071             Msgc (Msgl) := '?';
2072             Wmsg := True;
2073
2074          elsif In_Instance_Not_Visible then
2075             Msgl := Msgl + 1;
2076             Msgc (Msgl) := '?';
2077             Wmsg := True;
2078
2079          --  Otherwise we have a real error message (Ada 95 static case)
2080          --  and we make this an unconditional message. Note that in the
2081          --  warning case we do not make the message unconditional, it seems
2082          --  quite reasonable to delete messages like this (about exceptions
2083          --  that will be raised) in dead code.
2084
2085          else
2086             Wmsg := False;
2087             Msgl := Msgl + 1;
2088             Msgc (Msgl) := '!';
2089          end if;
2090
2091          --  Should we generate a warning? The answer is not quite yes. The
2092          --  very annoying exception occurs in the case of a short circuit
2093          --  operator where the left operand is static and decisive. Climb
2094          --  parents to see if that is the case we have here. Conditional
2095          --  expressions with decisive conditions are a similar situation.
2096
2097          Msgs := True;
2098          P := N;
2099          loop
2100             OldP := P;
2101             P := Parent (P);
2102
2103             --  And then with False as left operand
2104
2105             if Nkind (P) = N_And_Then
2106               and then Compile_Time_Known_Value (Left_Opnd (P))
2107               and then Is_False (Expr_Value (Left_Opnd (P)))
2108             then
2109                Msgs := False;
2110                exit;
2111
2112             --  OR ELSE with True as left operand
2113
2114             elsif Nkind (P) = N_Or_Else
2115               and then Compile_Time_Known_Value (Left_Opnd (P))
2116               and then Is_True (Expr_Value (Left_Opnd (P)))
2117             then
2118                Msgs := False;
2119                exit;
2120
2121             --  Conditional expression
2122
2123             elsif Nkind (P) = N_Conditional_Expression then
2124                declare
2125                   Cond : constant Node_Id := First (Expressions (P));
2126                   Texp : constant Node_Id := Next (Cond);
2127                   Fexp : constant Node_Id := Next (Texp);
2128
2129                begin
2130                   if Compile_Time_Known_Value (Cond) then
2131
2132                      --  Condition is True and we are in the right operand
2133
2134                      if Is_True (Expr_Value (Cond))
2135                        and then OldP = Fexp
2136                      then
2137                         Msgs := False;
2138                         exit;
2139
2140                      --  Condition is False and we are in the left operand
2141
2142                      elsif Is_False (Expr_Value (Cond))
2143                        and then OldP = Texp
2144                      then
2145                         Msgs := False;
2146                         exit;
2147                      end if;
2148                   end if;
2149                end;
2150
2151             --  Special case for component association in aggregates, where
2152             --  we want to keep climbing up to the parent aggregate.
2153
2154             elsif Nkind (P) = N_Component_Association
2155               and then Nkind (Parent (P)) = N_Aggregate
2156             then
2157                null;
2158
2159             --  Keep going if within subexpression
2160
2161             else
2162                exit when Nkind (P) not in N_Subexpr;
2163             end if;
2164          end loop;
2165
2166          if Msgs then
2167             if Present (Ent) then
2168                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
2169             else
2170                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
2171             end if;
2172
2173             if Wmsg then
2174                if Inside_Init_Proc then
2175                   Error_Msg_NEL
2176                     ("\?& will be raised for objects of this type",
2177                      N, Standard_Constraint_Error, Eloc);
2178                else
2179                   Error_Msg_NEL
2180                     ("\?& will be raised at run time",
2181                      N, Standard_Constraint_Error, Eloc);
2182                end if;
2183
2184             else
2185                Error_Msg
2186                  ("\static expression fails Constraint_Check", Eloc);
2187                Set_Error_Posted (N);
2188             end if;
2189          end if;
2190       end if;
2191
2192       return N;
2193    end Compile_Time_Constraint_Error;
2194
2195    -----------------------
2196    -- Conditional_Delay --
2197    -----------------------
2198
2199    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
2200    begin
2201       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
2202          Set_Has_Delayed_Freeze (New_Ent);
2203       end if;
2204    end Conditional_Delay;
2205
2206    -------------------------
2207    -- Copy_Parameter_List --
2208    -------------------------
2209
2210    function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
2211       Loc    : constant Source_Ptr := Sloc (Subp_Id);
2212       Plist  : List_Id;
2213       Formal : Entity_Id;
2214
2215    begin
2216       if No (First_Formal (Subp_Id)) then
2217          return No_List;
2218       else
2219          Plist := New_List;
2220          Formal := First_Formal (Subp_Id);
2221          while Present (Formal) loop
2222             Append
2223               (Make_Parameter_Specification (Loc,
2224                 Defining_Identifier =>
2225                   Make_Defining_Identifier (Sloc (Formal),
2226                     Chars => Chars (Formal)),
2227                 In_Present  => In_Present (Parent (Formal)),
2228                 Out_Present => Out_Present (Parent (Formal)),
2229              Parameter_Type =>
2230                   New_Reference_To (Etype (Formal), Loc),
2231                 Expression =>
2232                   New_Copy_Tree (Expression (Parent (Formal)))),
2233               Plist);
2234
2235             Next_Formal (Formal);
2236          end loop;
2237       end if;
2238
2239       return Plist;
2240    end Copy_Parameter_List;
2241
2242    --------------------
2243    -- Current_Entity --
2244    --------------------
2245
2246    --  The currently visible definition for a given identifier is the
2247    --  one most chained at the start of the visibility chain, i.e. the
2248    --  one that is referenced by the Node_Id value of the name of the
2249    --  given identifier.
2250
2251    function Current_Entity (N : Node_Id) return Entity_Id is
2252    begin
2253       return Get_Name_Entity_Id (Chars (N));
2254    end Current_Entity;
2255
2256    -----------------------------
2257    -- Current_Entity_In_Scope --
2258    -----------------------------
2259
2260    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
2261       E  : Entity_Id;
2262       CS : constant Entity_Id := Current_Scope;
2263
2264       Transient_Case : constant Boolean := Scope_Is_Transient;
2265
2266    begin
2267       E := Get_Name_Entity_Id (Chars (N));
2268       while Present (E)
2269         and then Scope (E) /= CS
2270         and then (not Transient_Case or else Scope (E) /= Scope (CS))
2271       loop
2272          E := Homonym (E);
2273       end loop;
2274
2275       return E;
2276    end Current_Entity_In_Scope;
2277
2278    -------------------
2279    -- Current_Scope --
2280    -------------------
2281
2282    function Current_Scope return Entity_Id is
2283    begin
2284       if Scope_Stack.Last = -1 then
2285          return Standard_Standard;
2286       else
2287          declare
2288             C : constant Entity_Id :=
2289                   Scope_Stack.Table (Scope_Stack.Last).Entity;
2290          begin
2291             if Present (C) then
2292                return C;
2293             else
2294                return Standard_Standard;
2295             end if;
2296          end;
2297       end if;
2298    end Current_Scope;
2299
2300    ------------------------
2301    -- Current_Subprogram --
2302    ------------------------
2303
2304    function Current_Subprogram return Entity_Id is
2305       Scop : constant Entity_Id := Current_Scope;
2306    begin
2307       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
2308          return Scop;
2309       else
2310          return Enclosing_Subprogram (Scop);
2311       end if;
2312    end Current_Subprogram;
2313
2314    ---------------------
2315    -- Defining_Entity --
2316    ---------------------
2317
2318    function Defining_Entity (N : Node_Id) return Entity_Id is
2319       K   : constant Node_Kind := Nkind (N);
2320       Err : Entity_Id := Empty;
2321
2322    begin
2323       case K is
2324          when
2325            N_Subprogram_Declaration                 |
2326            N_Abstract_Subprogram_Declaration        |
2327            N_Subprogram_Body                        |
2328            N_Package_Declaration                    |
2329            N_Subprogram_Renaming_Declaration        |
2330            N_Subprogram_Body_Stub                   |
2331            N_Generic_Subprogram_Declaration         |
2332            N_Generic_Package_Declaration            |
2333            N_Formal_Subprogram_Declaration
2334          =>
2335             return Defining_Entity (Specification (N));
2336
2337          when
2338            N_Component_Declaration                  |
2339            N_Defining_Program_Unit_Name             |
2340            N_Discriminant_Specification             |
2341            N_Entry_Body                             |
2342            N_Entry_Declaration                      |
2343            N_Entry_Index_Specification              |
2344            N_Exception_Declaration                  |
2345            N_Exception_Renaming_Declaration         |
2346            N_Formal_Object_Declaration              |
2347            N_Formal_Package_Declaration             |
2348            N_Formal_Type_Declaration                |
2349            N_Full_Type_Declaration                  |
2350            N_Implicit_Label_Declaration             |
2351            N_Incomplete_Type_Declaration            |
2352            N_Loop_Parameter_Specification           |
2353            N_Number_Declaration                     |
2354            N_Object_Declaration                     |
2355            N_Object_Renaming_Declaration            |
2356            N_Package_Body_Stub                      |
2357            N_Parameter_Specification                |
2358            N_Private_Extension_Declaration          |
2359            N_Private_Type_Declaration               |
2360            N_Protected_Body                         |
2361            N_Protected_Body_Stub                    |
2362            N_Protected_Type_Declaration             |
2363            N_Single_Protected_Declaration           |
2364            N_Single_Task_Declaration                |
2365            N_Subtype_Declaration                    |
2366            N_Task_Body                              |
2367            N_Task_Body_Stub                         |
2368            N_Task_Type_Declaration
2369          =>
2370             return Defining_Identifier (N);
2371
2372          when N_Subunit =>
2373             return Defining_Entity (Proper_Body (N));
2374
2375          when
2376            N_Function_Instantiation                 |
2377            N_Function_Specification                 |
2378            N_Generic_Function_Renaming_Declaration  |
2379            N_Generic_Package_Renaming_Declaration   |
2380            N_Generic_Procedure_Renaming_Declaration |
2381            N_Package_Body                           |
2382            N_Package_Instantiation                  |
2383            N_Package_Renaming_Declaration           |
2384            N_Package_Specification                  |
2385            N_Procedure_Instantiation                |
2386            N_Procedure_Specification
2387          =>
2388             declare
2389                Nam : constant Node_Id := Defining_Unit_Name (N);
2390
2391             begin
2392                if Nkind (Nam) in N_Entity then
2393                   return Nam;
2394
2395                --  For Error, make up a name and attach to declaration
2396                --  so we can continue semantic analysis
2397
2398                elsif Nam = Error then
2399                   Err := Make_Temporary (Sloc (N), 'T');
2400                   Set_Defining_Unit_Name (N, Err);
2401
2402                   return Err;
2403                --  If not an entity, get defining identifier
2404
2405                else
2406                   return Defining_Identifier (Nam);
2407                end if;
2408             end;
2409
2410          when N_Block_Statement =>
2411             return Entity (Identifier (N));
2412
2413          when others =>
2414             raise Program_Error;
2415
2416       end case;
2417    end Defining_Entity;
2418
2419    --------------------------
2420    -- Denotes_Discriminant --
2421    --------------------------
2422
2423    function Denotes_Discriminant
2424      (N                : Node_Id;
2425       Check_Concurrent : Boolean := False) return Boolean
2426    is
2427       E : Entity_Id;
2428    begin
2429       if not Is_Entity_Name (N)
2430         or else No (Entity (N))
2431       then
2432          return False;
2433       else
2434          E := Entity (N);
2435       end if;
2436
2437       --  If we are checking for a protected type, the discriminant may have
2438       --  been rewritten as the corresponding discriminal of the original type
2439       --  or of the corresponding concurrent record, depending on whether we
2440       --  are in the spec or body of the protected type.
2441
2442       return Ekind (E) = E_Discriminant
2443         or else
2444           (Check_Concurrent
2445             and then Ekind (E) = E_In_Parameter
2446             and then Present (Discriminal_Link (E))
2447             and then
2448               (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
2449                 or else
2450                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
2451
2452    end Denotes_Discriminant;
2453
2454    -------------------------
2455    -- Denotes_Same_Object --
2456    -------------------------
2457
2458    function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
2459       Obj1 : Node_Id := A1;
2460       Obj2 : Node_Id := A2;
2461
2462       procedure Check_Renaming (Obj : in out Node_Id);
2463       --  If an object is a renaming, examine renamed object. If it is a
2464       --  dereference of a variable, or an indexed expression with non-constant
2465       --  indexes, no overlap check can be reported.
2466
2467       --------------------
2468       -- Check_Renaming --
2469       --------------------
2470
2471       procedure Check_Renaming (Obj : in out Node_Id) is
2472       begin
2473          if Is_Entity_Name (Obj)
2474            and then Present (Renamed_Entity (Entity (Obj)))
2475          then
2476             Obj := Renamed_Entity (Entity (Obj));
2477             if Nkind (Obj) = N_Explicit_Dereference
2478               and then Is_Variable (Prefix (Obj))
2479             then
2480                Obj := Empty;
2481
2482             elsif Nkind (Obj) = N_Indexed_Component then
2483                declare
2484                   Indx : Node_Id;
2485
2486                begin
2487                   Indx := First (Expressions (Obj));
2488                   while Present (Indx) loop
2489                      if not Is_OK_Static_Expression (Indx) then
2490                         Obj := Empty;
2491                         exit;
2492                      end if;
2493
2494                      Next_Index (Indx);
2495                   end loop;
2496                end;
2497             end if;
2498          end if;
2499       end Check_Renaming;
2500
2501    --  Start of processing for Denotes_Same_Object
2502
2503    begin
2504       Check_Renaming (Obj1);
2505       Check_Renaming (Obj2);
2506
2507       if No (Obj1)
2508         or else No (Obj2)
2509       then
2510          return False;
2511       end if;
2512
2513       --  If we have entity names, then must be same entity
2514
2515       if Is_Entity_Name (Obj1) then
2516          if Is_Entity_Name (Obj2) then
2517             return Entity (Obj1) = Entity (Obj2);
2518          else
2519             return False;
2520          end if;
2521
2522       --  No match if not same node kind
2523
2524       elsif Nkind (Obj1) /= Nkind (Obj2) then
2525          return False;
2526
2527       --  For selected components, must have same prefix and selector
2528
2529       elsif Nkind (Obj1) = N_Selected_Component then
2530          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
2531            and then
2532          Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
2533
2534       --  For explicit dereferences, prefixes must be same
2535
2536       elsif Nkind (Obj1) = N_Explicit_Dereference then
2537          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
2538
2539       --  For indexed components, prefixes and all subscripts must be the same
2540
2541       elsif Nkind (Obj1) = N_Indexed_Component then
2542          if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
2543             declare
2544                Indx1 : Node_Id;
2545                Indx2 : Node_Id;
2546
2547             begin
2548                Indx1 := First (Expressions (Obj1));
2549                Indx2 := First (Expressions (Obj2));
2550                while Present (Indx1) loop
2551
2552                   --  Indexes must denote the same static value or same object
2553
2554                   if Is_OK_Static_Expression (Indx1) then
2555                      if not Is_OK_Static_Expression (Indx2) then
2556                         return False;
2557
2558                      elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
2559                         return False;
2560                      end if;
2561
2562                   elsif not Denotes_Same_Object (Indx1, Indx2) then
2563                      return False;
2564                   end if;
2565
2566                   Next (Indx1);
2567                   Next (Indx2);
2568                end loop;
2569
2570                return True;
2571             end;
2572          else
2573             return False;
2574          end if;
2575
2576       --  For slices, prefixes must match and bounds must match
2577
2578       elsif Nkind (Obj1) = N_Slice
2579         and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
2580       then
2581          declare
2582             Lo1, Lo2, Hi1, Hi2 : Node_Id;
2583
2584          begin
2585             Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
2586             Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
2587
2588             --  Check whether bounds are statically identical. There is no
2589             --  attempt to detect partial overlap of slices.
2590
2591             return Denotes_Same_Object (Lo1, Lo2)
2592               and then Denotes_Same_Object (Hi1, Hi2);
2593          end;
2594
2595          --  Literals will appear as indexes. Isn't this where we should check
2596          --  Known_At_Compile_Time at least if we are generating warnings ???
2597
2598       elsif Nkind (Obj1) = N_Integer_Literal then
2599          return Intval (Obj1) = Intval (Obj2);
2600
2601       else
2602          return False;
2603       end if;
2604    end Denotes_Same_Object;
2605
2606    -------------------------
2607    -- Denotes_Same_Prefix --
2608    -------------------------
2609
2610    function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
2611
2612    begin
2613       if Is_Entity_Name (A1) then
2614          if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
2615            and then not Is_Access_Type (Etype (A1))
2616          then
2617             return Denotes_Same_Object (A1, Prefix (A2))
2618               or else Denotes_Same_Prefix (A1, Prefix (A2));
2619          else
2620             return False;
2621          end if;
2622
2623       elsif Is_Entity_Name (A2) then
2624          return Denotes_Same_Prefix (A2, A1);
2625
2626       elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
2627               and then
2628             Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
2629       then
2630          declare
2631             Root1, Root2 : Node_Id;
2632             Depth1, Depth2 : Int := 0;
2633
2634          begin
2635             Root1 := Prefix (A1);
2636             while not Is_Entity_Name (Root1) loop
2637                if not Nkind_In
2638                  (Root1, N_Selected_Component, N_Indexed_Component)
2639                then
2640                   return False;
2641                else
2642                   Root1 := Prefix (Root1);
2643                end if;
2644
2645                Depth1 := Depth1 + 1;
2646             end loop;
2647
2648             Root2 := Prefix (A2);
2649             while not Is_Entity_Name (Root2) loop
2650                if not Nkind_In
2651                  (Root2, N_Selected_Component, N_Indexed_Component)
2652                then
2653                   return False;
2654                else
2655                   Root2 := Prefix (Root2);
2656                end if;
2657
2658                Depth2 := Depth2 + 1;
2659             end loop;
2660
2661             --  If both have the same depth and they do not denote the same
2662             --  object, they are disjoint and not warning is needed.
2663
2664             if Depth1 = Depth2 then
2665                return False;
2666
2667             elsif Depth1 > Depth2 then
2668                Root1 := Prefix (A1);
2669                for I in 1 .. Depth1 - Depth2 - 1 loop
2670                   Root1 := Prefix (Root1);
2671                end loop;
2672
2673                return Denotes_Same_Object (Root1, A2);
2674
2675             else
2676                Root2 := Prefix (A2);
2677                for I in 1 .. Depth2 - Depth1 - 1 loop
2678                   Root2 := Prefix (Root2);
2679                end loop;
2680
2681                return Denotes_Same_Object (A1, Root2);
2682             end if;
2683          end;
2684
2685       else
2686          return False;
2687       end if;
2688    end Denotes_Same_Prefix;
2689
2690    ----------------------
2691    -- Denotes_Variable --
2692    ----------------------
2693
2694    function Denotes_Variable (N : Node_Id) return Boolean is
2695    begin
2696       return Is_Variable (N) and then Paren_Count (N) = 0;
2697    end Denotes_Variable;
2698
2699    -----------------------------
2700    -- Depends_On_Discriminant --
2701    -----------------------------
2702
2703    function Depends_On_Discriminant (N : Node_Id) return Boolean is
2704       L : Node_Id;
2705       H : Node_Id;
2706
2707    begin
2708       Get_Index_Bounds (N, L, H);
2709       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
2710    end Depends_On_Discriminant;
2711
2712    -------------------------
2713    -- Designate_Same_Unit --
2714    -------------------------
2715
2716    function Designate_Same_Unit
2717      (Name1 : Node_Id;
2718       Name2 : Node_Id) return Boolean
2719    is
2720       K1 : constant Node_Kind := Nkind (Name1);
2721       K2 : constant Node_Kind := Nkind (Name2);
2722
2723       function Prefix_Node (N : Node_Id) return Node_Id;
2724       --  Returns the parent unit name node of a defining program unit name
2725       --  or the prefix if N is a selected component or an expanded name.
2726
2727       function Select_Node (N : Node_Id) return Node_Id;
2728       --  Returns the defining identifier node of a defining program unit
2729       --  name or  the selector node if N is a selected component or an
2730       --  expanded name.
2731
2732       -----------------
2733       -- Prefix_Node --
2734       -----------------
2735
2736       function Prefix_Node (N : Node_Id) return Node_Id is
2737       begin
2738          if Nkind (N) = N_Defining_Program_Unit_Name then
2739             return Name (N);
2740
2741          else
2742             return Prefix (N);
2743          end if;
2744       end Prefix_Node;
2745
2746       -----------------
2747       -- Select_Node --
2748       -----------------
2749
2750       function Select_Node (N : Node_Id) return Node_Id is
2751       begin
2752          if Nkind (N) = N_Defining_Program_Unit_Name then
2753             return Defining_Identifier (N);
2754
2755          else
2756             return Selector_Name (N);
2757          end if;
2758       end Select_Node;
2759
2760    --  Start of processing for Designate_Next_Unit
2761
2762    begin
2763       if (K1 = N_Identifier or else
2764           K1 = N_Defining_Identifier)
2765         and then
2766          (K2 = N_Identifier or else
2767           K2 = N_Defining_Identifier)
2768       then
2769          return Chars (Name1) = Chars (Name2);
2770
2771       elsif
2772          (K1 = N_Expanded_Name      or else
2773           K1 = N_Selected_Component or else
2774           K1 = N_Defining_Program_Unit_Name)
2775         and then
2776          (K2 = N_Expanded_Name      or else
2777           K2 = N_Selected_Component or else
2778           K2 = N_Defining_Program_Unit_Name)
2779       then
2780          return
2781            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
2782              and then
2783                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
2784
2785       else
2786          return False;
2787       end if;
2788    end Designate_Same_Unit;
2789
2790    --------------------------
2791    -- Enclosing_CPP_Parent --
2792    --------------------------
2793
2794    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
2795       Parent_Typ : Entity_Id := Typ;
2796
2797    begin
2798       while not Is_CPP_Class (Parent_Typ)
2799          and then Etype (Parent_Typ) /= Parent_Typ
2800       loop
2801          Parent_Typ := Etype (Parent_Typ);
2802
2803          if Is_Private_Type (Parent_Typ) then
2804             Parent_Typ := Full_View (Base_Type (Parent_Typ));
2805          end if;
2806       end loop;
2807
2808       pragma Assert (Is_CPP_Class (Parent_Typ));
2809       return Parent_Typ;
2810    end Enclosing_CPP_Parent;
2811
2812    ----------------------------
2813    -- Enclosing_Generic_Body --
2814    ----------------------------
2815
2816    function Enclosing_Generic_Body
2817      (N : Node_Id) return Node_Id
2818    is
2819       P    : Node_Id;
2820       Decl : Node_Id;
2821       Spec : Node_Id;
2822
2823    begin
2824       P := Parent (N);
2825       while Present (P) loop
2826          if Nkind (P) = N_Package_Body
2827            or else Nkind (P) = N_Subprogram_Body
2828          then
2829             Spec := Corresponding_Spec (P);
2830
2831             if Present (Spec) then
2832                Decl := Unit_Declaration_Node (Spec);
2833
2834                if Nkind (Decl) = N_Generic_Package_Declaration
2835                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
2836                then
2837                   return P;
2838                end if;
2839             end if;
2840          end if;
2841
2842          P := Parent (P);
2843       end loop;
2844
2845       return Empty;
2846    end Enclosing_Generic_Body;
2847
2848    ----------------------------
2849    -- Enclosing_Generic_Unit --
2850    ----------------------------
2851
2852    function Enclosing_Generic_Unit
2853      (N : Node_Id) return Node_Id
2854    is
2855       P    : Node_Id;
2856       Decl : Node_Id;
2857       Spec : Node_Id;
2858
2859    begin
2860       P := Parent (N);
2861       while Present (P) loop
2862          if Nkind (P) = N_Generic_Package_Declaration
2863            or else Nkind (P) = N_Generic_Subprogram_Declaration
2864          then
2865             return P;
2866
2867          elsif Nkind (P) = N_Package_Body
2868            or else Nkind (P) = N_Subprogram_Body
2869          then
2870             Spec := Corresponding_Spec (P);
2871
2872             if Present (Spec) then
2873                Decl := Unit_Declaration_Node (Spec);
2874
2875                if Nkind (Decl) = N_Generic_Package_Declaration
2876                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
2877                then
2878                   return Decl;
2879                end if;
2880             end if;
2881          end if;
2882
2883          P := Parent (P);
2884       end loop;
2885
2886       return Empty;
2887    end Enclosing_Generic_Unit;
2888
2889    -------------------------------
2890    -- Enclosing_Lib_Unit_Entity --
2891    -------------------------------
2892
2893    function Enclosing_Lib_Unit_Entity return Entity_Id is
2894       Unit_Entity : Entity_Id;
2895
2896    begin
2897       --  Look for enclosing library unit entity by following scope links.
2898       --  Equivalent to, but faster than indexing through the scope stack.
2899
2900       Unit_Entity := Current_Scope;
2901       while (Present (Scope (Unit_Entity))
2902         and then Scope (Unit_Entity) /= Standard_Standard)
2903         and not Is_Child_Unit (Unit_Entity)
2904       loop
2905          Unit_Entity := Scope (Unit_Entity);
2906       end loop;
2907
2908       return Unit_Entity;
2909    end Enclosing_Lib_Unit_Entity;
2910
2911    -----------------------------
2912    -- Enclosing_Lib_Unit_Node --
2913    -----------------------------
2914
2915    function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
2916       Current_Node : Node_Id;
2917
2918    begin
2919       Current_Node := N;
2920       while Present (Current_Node)
2921         and then Nkind (Current_Node) /= N_Compilation_Unit
2922       loop
2923          Current_Node := Parent (Current_Node);
2924       end loop;
2925
2926       if Nkind (Current_Node) /= N_Compilation_Unit then
2927          return Empty;
2928       end if;
2929
2930       return Current_Node;
2931    end Enclosing_Lib_Unit_Node;
2932
2933    -----------------------
2934    -- Enclosing_Package --
2935    -----------------------
2936
2937    function Enclosing_Package (E : Entity_Id) return Entity_Id is
2938       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
2939
2940    begin
2941       if Dynamic_Scope = Standard_Standard then
2942          return Standard_Standard;
2943
2944       elsif Dynamic_Scope = Empty then
2945          return Empty;
2946
2947       elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
2948                       E_Generic_Package)
2949       then
2950          return Dynamic_Scope;
2951
2952       else
2953          return Enclosing_Package (Dynamic_Scope);
2954       end if;
2955    end Enclosing_Package;
2956
2957    --------------------------
2958    -- Enclosing_Subprogram --
2959    --------------------------
2960
2961    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
2962       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
2963
2964    begin
2965       if Dynamic_Scope = Standard_Standard then
2966          return Empty;
2967
2968       elsif Dynamic_Scope = Empty then
2969          return Empty;
2970
2971       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
2972          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
2973
2974       elsif Ekind (Dynamic_Scope) = E_Block
2975         or else Ekind (Dynamic_Scope) = E_Return_Statement
2976       then
2977          return Enclosing_Subprogram (Dynamic_Scope);
2978
2979       elsif Ekind (Dynamic_Scope) = E_Task_Type then
2980          return Get_Task_Body_Procedure (Dynamic_Scope);
2981
2982       elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
2983         and then Present (Full_View (Dynamic_Scope))
2984         and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
2985       then
2986          return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
2987
2988       --  No body is generated if the protected operation is eliminated
2989
2990       elsif Convention (Dynamic_Scope) = Convention_Protected
2991         and then not Is_Eliminated (Dynamic_Scope)
2992         and then Present (Protected_Body_Subprogram (Dynamic_Scope))
2993       then
2994          return Protected_Body_Subprogram (Dynamic_Scope);
2995
2996       else
2997          return Dynamic_Scope;
2998       end if;
2999    end Enclosing_Subprogram;
3000
3001    ------------------------
3002    -- Ensure_Freeze_Node --
3003    ------------------------
3004
3005    procedure Ensure_Freeze_Node (E : Entity_Id) is
3006       FN : Node_Id;
3007
3008    begin
3009       if No (Freeze_Node (E)) then
3010          FN := Make_Freeze_Entity (Sloc (E));
3011          Set_Has_Delayed_Freeze (E);
3012          Set_Freeze_Node (E, FN);
3013          Set_Access_Types_To_Process (FN, No_Elist);
3014          Set_TSS_Elist (FN, No_Elist);
3015          Set_Entity (FN, E);
3016       end if;
3017    end Ensure_Freeze_Node;
3018
3019    ----------------
3020    -- Enter_Name --
3021    ----------------
3022
3023    procedure Enter_Name (Def_Id : Entity_Id) is
3024       C : constant Entity_Id := Current_Entity (Def_Id);
3025       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
3026       S : constant Entity_Id := Current_Scope;
3027
3028    begin
3029       Generate_Definition (Def_Id);
3030
3031       --  Add new name to current scope declarations. Check for duplicate
3032       --  declaration, which may or may not be a genuine error.
3033
3034       if Present (E) then
3035
3036          --  Case of previous entity entered because of a missing declaration
3037          --  or else a bad subtype indication. Best is to use the new entity,
3038          --  and make the previous one invisible.
3039
3040          if Etype (E) = Any_Type then
3041             Set_Is_Immediately_Visible (E, False);
3042
3043          --  Case of renaming declaration constructed for package instances.
3044          --  if there is an explicit declaration with the same identifier,
3045          --  the renaming is not immediately visible any longer, but remains
3046          --  visible through selected component notation.
3047
3048          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
3049            and then not Comes_From_Source (E)
3050          then
3051             Set_Is_Immediately_Visible (E, False);
3052
3053          --  The new entity may be the package renaming, which has the same
3054          --  same name as a generic formal which has been seen already.
3055
3056          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
3057             and then not Comes_From_Source (Def_Id)
3058          then
3059             Set_Is_Immediately_Visible (E, False);
3060
3061          --  For a fat pointer corresponding to a remote access to subprogram,
3062          --  we use the same identifier as the RAS type, so that the proper
3063          --  name appears in the stub. This type is only retrieved through
3064          --  the RAS type and never by visibility, and is not added to the
3065          --  visibility list (see below).
3066
3067          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
3068            and then Present (Corresponding_Remote_Type (Def_Id))
3069          then
3070             null;
3071
3072          --  A controller component for a type extension overrides the
3073          --  inherited component.
3074
3075          elsif Chars (E) = Name_uController then
3076             null;
3077
3078          --  Case of an implicit operation or derived literal. The new entity
3079          --  hides the implicit one,  which is removed from all visibility,
3080          --  i.e. the entity list of its scope, and homonym chain of its name.
3081
3082          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
3083            or else Is_Internal (E)
3084          then
3085             declare
3086                Prev     : Entity_Id;
3087                Prev_Vis : Entity_Id;
3088                Decl     : constant Node_Id := Parent (E);
3089
3090             begin
3091                --  If E is an implicit declaration, it cannot be the first
3092                --  entity in the scope.
3093
3094                Prev := First_Entity (Current_Scope);
3095                while Present (Prev)
3096                  and then Next_Entity (Prev) /= E
3097                loop
3098                   Next_Entity (Prev);
3099                end loop;
3100
3101                if No (Prev) then
3102
3103                   --  If E is not on the entity chain of the current scope,
3104                   --  it is an implicit declaration in the generic formal
3105                   --  part of a generic subprogram. When analyzing the body,
3106                   --  the generic formals are visible but not on the entity
3107                   --  chain of the subprogram. The new entity will become
3108                   --  the visible one in the body.
3109
3110                   pragma Assert
3111                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
3112                   null;
3113
3114                else
3115                   Set_Next_Entity (Prev, Next_Entity (E));
3116
3117                   if No (Next_Entity (Prev)) then
3118                      Set_Last_Entity (Current_Scope, Prev);
3119                   end if;
3120
3121                   if E = Current_Entity (E) then
3122                      Prev_Vis := Empty;
3123
3124                   else
3125                      Prev_Vis := Current_Entity (E);
3126                      while Homonym (Prev_Vis) /= E loop
3127                         Prev_Vis := Homonym (Prev_Vis);
3128                      end loop;
3129                   end if;
3130
3131                   if Present (Prev_Vis)  then
3132
3133                      --  Skip E in the visibility chain
3134
3135                      Set_Homonym (Prev_Vis, Homonym (E));
3136
3137                   else
3138                      Set_Name_Entity_Id (Chars (E), Homonym (E));
3139                   end if;
3140                end if;
3141             end;
3142
3143          --  This section of code could use a comment ???
3144
3145          elsif Present (Etype (E))
3146            and then Is_Concurrent_Type (Etype (E))
3147            and then E = Def_Id
3148          then
3149             return;
3150
3151          --  If the homograph is a protected component renaming, it should not
3152          --  be hiding the current entity. Such renamings are treated as weak
3153          --  declarations.
3154
3155          elsif Is_Prival (E) then
3156             Set_Is_Immediately_Visible (E, False);
3157
3158          --  In this case the current entity is a protected component renaming.
3159          --  Perform minimal decoration by setting the scope and return since
3160          --  the prival should not be hiding other visible entities.
3161
3162          elsif Is_Prival (Def_Id) then
3163             Set_Scope (Def_Id, Current_Scope);
3164             return;
3165
3166          --  Analogous to privals, the discriminal generated for an entry index
3167          --  parameter acts as a weak declaration. Perform minimal decoration
3168          --  to avoid bogus errors.
3169
3170          elsif Is_Discriminal (Def_Id)
3171            and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
3172          then
3173             Set_Scope (Def_Id, Current_Scope);
3174             return;
3175
3176          --  In the body or private part of an instance, a type extension may
3177          --  introduce a component with the same name as that of an actual. The
3178          --  legality rule is not enforced, but the semantics of the full type
3179          --  with two components of same name are not clear at this point???
3180
3181          elsif In_Instance_Not_Visible then
3182             null;
3183
3184          --  When compiling a package body, some child units may have become
3185          --  visible. They cannot conflict with local entities that hide them.
3186
3187          elsif Is_Child_Unit (E)
3188            and then In_Open_Scopes (Scope (E))
3189            and then not Is_Immediately_Visible (E)
3190          then
3191             null;
3192
3193          --  Conversely, with front-end inlining we may compile the parent body
3194          --  first, and a child unit subsequently. The context is now the
3195          --  parent spec, and body entities are not visible.
3196
3197          elsif Is_Child_Unit (Def_Id)
3198            and then Is_Package_Body_Entity (E)
3199            and then not In_Package_Body (Current_Scope)
3200          then
3201             null;
3202
3203          --  Case of genuine duplicate declaration
3204
3205          else
3206             Error_Msg_Sloc := Sloc (E);
3207
3208             --  If the previous declaration is an incomplete type declaration
3209             --  this may be an attempt to complete it with a private type. The
3210             --  following avoids confusing cascaded errors.
3211
3212             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
3213               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
3214             then
3215                Error_Msg_N
3216                  ("incomplete type cannot be completed with a private " &
3217                   "declaration", Parent (Def_Id));
3218                Set_Is_Immediately_Visible (E, False);
3219                Set_Full_View (E, Def_Id);
3220
3221             --  An inherited component of a record conflicts with a new
3222             --  discriminant. The discriminant is inserted first in the scope,
3223             --  but the error should be posted on it, not on the component.
3224
3225             elsif Ekind (E) = E_Discriminant
3226               and then Present (Scope (Def_Id))
3227               and then Scope (Def_Id) /= Current_Scope
3228             then
3229                Error_Msg_Sloc := Sloc (Def_Id);
3230                Error_Msg_N ("& conflicts with declaration#", E);
3231                return;
3232
3233             --  If the name of the unit appears in its own context clause, a
3234             --  dummy package with the name has already been created, and the
3235             --  error emitted. Try to continue quietly.
3236
3237             elsif Error_Posted (E)
3238               and then Sloc (E) = No_Location
3239               and then Nkind (Parent (E)) = N_Package_Specification
3240               and then Current_Scope = Standard_Standard
3241             then
3242                Set_Scope (Def_Id, Current_Scope);
3243                return;
3244
3245             else
3246                Error_Msg_N ("& conflicts with declaration#", Def_Id);
3247
3248                --  Avoid cascaded messages with duplicate components in
3249                --  derived types.
3250
3251                if Ekind_In (E, E_Component, E_Discriminant) then
3252                   return;
3253                end if;
3254             end if;
3255
3256             if Nkind (Parent (Parent (Def_Id))) =
3257                 N_Generic_Subprogram_Declaration
3258               and then Def_Id =
3259                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
3260             then
3261                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
3262             end if;
3263
3264             --  If entity is in standard, then we are in trouble, because it
3265             --  means that we have a library package with a duplicated name.
3266             --  That's hard to recover from, so abort!
3267
3268             if S = Standard_Standard then
3269                raise Unrecoverable_Error;
3270
3271             --  Otherwise we continue with the declaration. Having two
3272             --  identical declarations should not cause us too much trouble!
3273
3274             else
3275                null;
3276             end if;
3277          end if;
3278       end if;
3279
3280       --  If we fall through, declaration is OK, at least OK enough to continue
3281
3282       --  If Def_Id is a discriminant or a record component we are in the midst
3283       --  of inheriting components in a derived record definition. Preserve
3284       --  their Ekind and Etype.
3285
3286       if Ekind_In (Def_Id, E_Discriminant, E_Component) then
3287          null;
3288
3289       --  If a type is already set, leave it alone (happens when a type
3290       --  declaration is reanalyzed following a call to the optimizer).
3291
3292       elsif Present (Etype (Def_Id)) then
3293          null;
3294
3295       --  Otherwise, the kind E_Void insures that premature uses of the entity
3296       --  will be detected. Any_Type insures that no cascaded errors will occur
3297
3298       else
3299          Set_Ekind (Def_Id, E_Void);
3300          Set_Etype (Def_Id, Any_Type);
3301       end if;
3302
3303       --  Inherited discriminants and components in derived record types are
3304       --  immediately visible. Itypes are not.
3305
3306       if Ekind_In (Def_Id, E_Discriminant, E_Component)
3307         or else (No (Corresponding_Remote_Type (Def_Id))
3308                  and then not Is_Itype (Def_Id))
3309       then
3310          Set_Is_Immediately_Visible (Def_Id);
3311          Set_Current_Entity         (Def_Id);
3312       end if;
3313
3314       Set_Homonym       (Def_Id, C);
3315       Append_Entity     (Def_Id, S);
3316       Set_Public_Status (Def_Id);
3317
3318       --  Declaring a homonym is not allowed in SPARK or ALFA ...
3319
3320       if Present (C)
3321         and then (Restriction_Check_Required (SPARK)
3322                    or else Formal_Verification_Mode)
3323       then
3324
3325          declare
3326             Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
3327             Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
3328             Other_Scope    : constant Node_Id := Enclosing_Dynamic_Scope (C);
3329          begin
3330
3331             --  ... unless the new declaration is in a subprogram, and the
3332             --  visible declaration is a variable declaration or a parameter
3333             --  specification outside that subprogram.
3334
3335             if Present (Enclosing_Subp)
3336               and then Nkind_In (Parent (C), N_Object_Declaration,
3337                                  N_Parameter_Specification)
3338               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
3339             then
3340                null;
3341
3342             --  ... or the new declaration is in a package, and the visible
3343             --  declaration occurs outside that package.
3344
3345             elsif Present (Enclosing_Pack)
3346               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
3347             then
3348                null;
3349
3350             --  ... or the new declaration is a component declaration in a
3351             --  record type definition.
3352
3353             elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
3354                null;
3355
3356             --  Don't issue error for non-source entities
3357
3358             elsif Comes_From_Source (Def_Id)
3359               and then Comes_From_Source (C)
3360             then
3361                Error_Msg_Sloc := Sloc (C);
3362                Check_Formal_Restriction
3363                  ("redeclaration of identifier &#", Def_Id);
3364             end if;
3365          end;
3366       end if;
3367
3368       --  Warn if new entity hides an old one
3369
3370       if Warn_On_Hiding and then Present (C)
3371
3372          --  Don't warn for record components since they always have a well
3373          --  defined scope which does not confuse other uses. Note that in
3374          --  some cases, Ekind has not been set yet.
3375
3376          and then Ekind (C) /= E_Component
3377          and then Ekind (C) /= E_Discriminant
3378          and then Nkind (Parent (C)) /= N_Component_Declaration
3379          and then Ekind (Def_Id) /= E_Component
3380          and then Ekind (Def_Id) /= E_Discriminant
3381          and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
3382
3383          --  Don't warn for one character variables. It is too common to use
3384          --  such variables as locals and will just cause too many false hits.
3385
3386          and then Length_Of_Name (Chars (C)) /= 1
3387
3388          --  Don't warn for non-source entities
3389
3390          and then Comes_From_Source (C)
3391          and then Comes_From_Source (Def_Id)
3392
3393          --  Don't warn unless entity in question is in extended main source
3394
3395          and then In_Extended_Main_Source_Unit (Def_Id)
3396
3397          --  Finally, the hidden entity must be either immediately visible or
3398          --  use visible (i.e. from a used package).
3399
3400          and then
3401            (Is_Immediately_Visible (C)
3402               or else
3403             Is_Potentially_Use_Visible (C))
3404       then
3405          Error_Msg_Sloc := Sloc (C);
3406          Error_Msg_N ("declaration hides &#?", Def_Id);
3407       end if;
3408    end Enter_Name;
3409
3410    --------------------------
3411    -- Explain_Limited_Type --
3412    --------------------------
3413
3414    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
3415       C : Entity_Id;
3416
3417    begin
3418       --  For array, component type must be limited
3419
3420       if Is_Array_Type (T) then
3421          Error_Msg_Node_2 := T;
3422          Error_Msg_NE
3423            ("\component type& of type& is limited", N, Component_Type (T));
3424          Explain_Limited_Type (Component_Type (T), N);
3425
3426       elsif Is_Record_Type (T) then
3427
3428          --  No need for extra messages if explicit limited record
3429
3430          if Is_Limited_Record (Base_Type (T)) then
3431             return;
3432          end if;
3433
3434          --  Otherwise find a limited component. Check only components that
3435          --  come from source, or inherited components that appear in the
3436          --  source of the ancestor.
3437
3438          C := First_Component (T);
3439          while Present (C) loop
3440             if Is_Limited_Type (Etype (C))
3441               and then
3442                 (Comes_From_Source (C)
3443                    or else
3444                      (Present (Original_Record_Component (C))
3445                        and then
3446                          Comes_From_Source (Original_Record_Component (C))))
3447             then
3448                Error_Msg_Node_2 := T;
3449                Error_Msg_NE ("\component& of type& has limited type", N, C);
3450                Explain_Limited_Type (Etype (C), N);
3451                return;
3452             end if;
3453
3454             Next_Component (C);
3455          end loop;
3456
3457          --  The type may be declared explicitly limited, even if no component
3458          --  of it is limited, in which case we fall out of the loop.
3459          return;
3460       end if;
3461    end Explain_Limited_Type;
3462
3463    -----------------
3464    -- Find_Actual --
3465    -----------------
3466
3467    procedure Find_Actual
3468      (N        : Node_Id;
3469       Formal   : out Entity_Id;
3470       Call     : out Node_Id)
3471    is
3472       Parnt  : constant Node_Id := Parent (N);
3473       Actual : Node_Id;
3474
3475    begin
3476       if (Nkind (Parnt) = N_Indexed_Component
3477             or else
3478           Nkind (Parnt) = N_Selected_Component)
3479         and then N = Prefix (Parnt)
3480       then
3481          Find_Actual (Parnt, Formal, Call);
3482          return;
3483
3484       elsif Nkind (Parnt) = N_Parameter_Association
3485         and then N = Explicit_Actual_Parameter (Parnt)
3486       then
3487          Call := Parent (Parnt);
3488
3489       elsif Nkind_In (Parnt, N_Procedure_Call_Statement, N_Function_Call) then
3490          Call := Parnt;
3491
3492       else
3493          Formal := Empty;
3494          Call   := Empty;
3495          return;
3496       end if;
3497
3498       --  If we have a call to a subprogram look for the parameter. Note that
3499       --  we exclude overloaded calls, since we don't know enough to be sure
3500       --  of giving the right answer in this case.
3501
3502       if Is_Entity_Name (Name (Call))
3503         and then Present (Entity (Name (Call)))
3504         and then Is_Overloadable (Entity (Name (Call)))
3505         and then not Is_Overloaded (Name (Call))
3506       then
3507          --  Fall here if we are definitely a parameter
3508
3509          Actual := First_Actual (Call);
3510          Formal := First_Formal (Entity (Name (Call)));
3511          while Present (Formal) and then Present (Actual) loop
3512             if Actual = N then
3513                return;
3514             else
3515                Actual := Next_Actual (Actual);
3516                Formal := Next_Formal (Formal);
3517             end if;
3518          end loop;
3519       end if;
3520
3521       --  Fall through here if we did not find matching actual
3522
3523       Formal := Empty;
3524       Call   := Empty;
3525    end Find_Actual;
3526
3527    ---------------------------
3528    -- Find_Body_Discriminal --
3529    ---------------------------
3530
3531    function Find_Body_Discriminal
3532      (Spec_Discriminant : Entity_Id) return Entity_Id
3533    is
3534       pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
3535
3536       Tsk  : constant Entity_Id :=
3537                Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
3538       Disc : Entity_Id;
3539
3540    begin
3541       --  Find discriminant of original concurrent type, and use its current
3542       --  discriminal, which is the renaming within the task/protected body.
3543
3544       Disc := First_Discriminant (Tsk);
3545       while Present (Disc) loop
3546          if Chars (Disc) = Chars (Spec_Discriminant) then
3547             return Discriminal (Disc);
3548          end if;
3549
3550          Next_Discriminant (Disc);
3551       end loop;
3552
3553       --  That loop should always succeed in finding a matching entry and
3554       --  returning. Fatal error if not.
3555
3556       raise Program_Error;
3557    end Find_Body_Discriminal;
3558
3559    -------------------------------------
3560    -- Find_Corresponding_Discriminant --
3561    -------------------------------------
3562
3563    function Find_Corresponding_Discriminant
3564      (Id  : Node_Id;
3565       Typ : Entity_Id) return Entity_Id
3566    is
3567       Par_Disc : Entity_Id;
3568       Old_Disc : Entity_Id;
3569       New_Disc : Entity_Id;
3570
3571    begin
3572       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
3573
3574       --  The original type may currently be private, and the discriminant
3575       --  only appear on its full view.
3576
3577       if Is_Private_Type (Scope (Par_Disc))
3578         and then not Has_Discriminants (Scope (Par_Disc))
3579         and then Present (Full_View (Scope (Par_Disc)))
3580       then
3581          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
3582       else
3583          Old_Disc := First_Discriminant (Scope (Par_Disc));
3584       end if;
3585
3586       if Is_Class_Wide_Type (Typ) then
3587          New_Disc := First_Discriminant (Root_Type (Typ));
3588       else
3589          New_Disc := First_Discriminant (Typ);
3590       end if;
3591
3592       while Present (Old_Disc) and then Present (New_Disc) loop
3593          if Old_Disc = Par_Disc  then
3594             return New_Disc;
3595          else
3596             Next_Discriminant (Old_Disc);
3597             Next_Discriminant (New_Disc);
3598          end if;
3599       end loop;
3600
3601       --  Should always find it
3602
3603       raise Program_Error;
3604    end Find_Corresponding_Discriminant;
3605
3606    --------------------------
3607    -- Find_Overlaid_Entity --
3608    --------------------------
3609
3610    procedure Find_Overlaid_Entity
3611      (N   : Node_Id;
3612       Ent : out Entity_Id;
3613       Off : out Boolean)
3614    is
3615       Expr : Node_Id;
3616
3617    begin
3618       --  We are looking for one of the two following forms:
3619
3620       --    for X'Address use Y'Address
3621
3622       --  or
3623
3624       --    Const : constant Address := expr;
3625       --    ...
3626       --    for X'Address use Const;
3627
3628       --  In the second case, the expr is either Y'Address, or recursively a
3629       --  constant that eventually references Y'Address.
3630
3631       Ent := Empty;
3632       Off := False;
3633
3634       if Nkind (N) = N_Attribute_Definition_Clause
3635         and then Chars (N) = Name_Address
3636       then
3637          Expr := Expression (N);
3638
3639          --  This loop checks the form of the expression for Y'Address,
3640          --  using recursion to deal with intermediate constants.
3641
3642          loop
3643             --  Check for Y'Address
3644
3645             if Nkind (Expr) = N_Attribute_Reference
3646               and then Attribute_Name (Expr) = Name_Address
3647             then
3648                Expr := Prefix (Expr);
3649                exit;
3650
3651                --  Check for Const where Const is a constant entity
3652
3653             elsif Is_Entity_Name (Expr)
3654               and then Ekind (Entity (Expr)) = E_Constant
3655             then
3656                Expr := Constant_Value (Entity (Expr));
3657
3658             --  Anything else does not need checking
3659
3660             else
3661                return;
3662             end if;
3663          end loop;
3664
3665          --  This loop checks the form of the prefix for an entity,
3666          --  using recursion to deal with intermediate components.
3667
3668          loop
3669             --  Check for Y where Y is an entity
3670
3671             if Is_Entity_Name (Expr) then
3672                Ent := Entity (Expr);
3673                return;
3674
3675             --  Check for components
3676
3677             elsif
3678                Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
3679
3680                Expr := Prefix (Expr);
3681                Off := True;
3682
3683             --  Anything else does not need checking
3684
3685             else
3686                return;
3687             end if;
3688          end loop;
3689       end if;
3690    end Find_Overlaid_Entity;
3691
3692    -------------------------
3693    -- Find_Parameter_Type --
3694    -------------------------
3695
3696    function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
3697    begin
3698       if Nkind (Param) /= N_Parameter_Specification then
3699          return Empty;
3700
3701       --  For an access parameter, obtain the type from the formal entity
3702       --  itself, because access to subprogram nodes do not carry a type.
3703       --  Shouldn't we always use the formal entity ???
3704
3705       elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
3706          return Etype (Defining_Identifier (Param));
3707
3708       else
3709          return Etype (Parameter_Type (Param));
3710       end if;
3711    end Find_Parameter_Type;
3712
3713    -----------------------------
3714    -- Find_Static_Alternative --
3715    -----------------------------
3716
3717    function Find_Static_Alternative (N : Node_Id) return Node_Id is
3718       Expr   : constant Node_Id := Expression (N);
3719       Val    : constant Uint    := Expr_Value (Expr);
3720       Alt    : Node_Id;
3721       Choice : Node_Id;
3722
3723    begin
3724       Alt := First (Alternatives (N));
3725
3726       Search : loop
3727          if Nkind (Alt) /= N_Pragma then
3728             Choice := First (Discrete_Choices (Alt));
3729             while Present (Choice) loop
3730
3731                --  Others choice, always matches
3732
3733                if Nkind (Choice) = N_Others_Choice then
3734                   exit Search;
3735
3736                --  Range, check if value is in the range
3737
3738                elsif Nkind (Choice) = N_Range then
3739                   exit Search when
3740                     Val >= Expr_Value (Low_Bound (Choice))
3741                       and then
3742                     Val <= Expr_Value (High_Bound (Choice));
3743
3744                --  Choice is a subtype name. Note that we know it must
3745                --  be a static subtype, since otherwise it would have
3746                --  been diagnosed as illegal.
3747
3748                elsif Is_Entity_Name (Choice)
3749                  and then Is_Type (Entity (Choice))
3750                then
3751                   exit Search when Is_In_Range (Expr, Etype (Choice),
3752                                                 Assume_Valid => False);
3753
3754                --  Choice is a subtype indication
3755
3756                elsif Nkind (Choice) = N_Subtype_Indication then
3757                   declare
3758                      C : constant Node_Id := Constraint (Choice);
3759                      R : constant Node_Id := Range_Expression (C);
3760
3761                   begin
3762                      exit Search when
3763                        Val >= Expr_Value (Low_Bound (R))
3764                          and then
3765                        Val <= Expr_Value (High_Bound (R));
3766                   end;
3767
3768                --  Choice is a simple expression
3769
3770                else
3771                   exit Search when Val = Expr_Value (Choice);
3772                end if;
3773
3774                Next (Choice);
3775             end loop;
3776          end if;
3777
3778          Next (Alt);
3779          pragma Assert (Present (Alt));
3780       end loop Search;
3781
3782       --  The above loop *must* terminate by finding a match, since
3783       --  we know the case statement is valid, and the value of the
3784       --  expression is known at compile time. When we fall out of
3785       --  the loop, Alt points to the alternative that we know will
3786       --  be selected at run time.
3787
3788       return Alt;
3789    end Find_Static_Alternative;
3790
3791    ------------------
3792    -- First_Actual --
3793    ------------------
3794
3795    function First_Actual (Node : Node_Id) return Node_Id is
3796       N : Node_Id;
3797
3798    begin
3799       if No (Parameter_Associations (Node)) then
3800          return Empty;
3801       end if;
3802
3803       N := First (Parameter_Associations (Node));
3804
3805       if Nkind (N) = N_Parameter_Association then
3806          return First_Named_Actual (Node);
3807       else
3808          return N;
3809       end if;
3810    end First_Actual;
3811
3812    -----------------------
3813    -- Gather_Components --
3814    -----------------------
3815
3816    procedure Gather_Components
3817      (Typ           : Entity_Id;
3818       Comp_List     : Node_Id;
3819       Governed_By   : List_Id;
3820       Into          : Elist_Id;
3821       Report_Errors : out Boolean)
3822    is
3823       Assoc           : Node_Id;
3824       Variant         : Node_Id;
3825       Discrete_Choice : Node_Id;
3826       Comp_Item       : Node_Id;
3827
3828       Discrim       : Entity_Id;
3829       Discrim_Name  : Node_Id;
3830       Discrim_Value : Node_Id;
3831
3832    begin
3833       Report_Errors := False;
3834
3835       if No (Comp_List) or else Null_Present (Comp_List) then
3836          return;
3837
3838       elsif Present (Component_Items (Comp_List)) then
3839          Comp_Item := First (Component_Items (Comp_List));
3840
3841       else
3842          Comp_Item := Empty;
3843       end if;
3844
3845       while Present (Comp_Item) loop
3846
3847          --  Skip the tag of a tagged record, the interface tags, as well
3848          --  as all items that are not user components (anonymous types,
3849          --  rep clauses, Parent field, controller field).
3850
3851          if Nkind (Comp_Item) = N_Component_Declaration then
3852             declare
3853                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
3854             begin
3855                if not Is_Tag (Comp)
3856                  and then Chars (Comp) /= Name_uParent
3857                  and then Chars (Comp) /= Name_uController
3858                then
3859                   Append_Elmt (Comp, Into);
3860                end if;
3861             end;
3862          end if;
3863
3864          Next (Comp_Item);
3865       end loop;
3866
3867       if No (Variant_Part (Comp_List)) then
3868          return;
3869       else
3870          Discrim_Name := Name (Variant_Part (Comp_List));
3871          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3872       end if;
3873
3874       --  Look for the discriminant that governs this variant part.
3875       --  The discriminant *must* be in the Governed_By List
3876
3877       Assoc := First (Governed_By);
3878       Find_Constraint : loop
3879          Discrim := First (Choices (Assoc));
3880          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
3881            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
3882                       and then
3883                     Chars (Corresponding_Discriminant (Entity (Discrim)))
3884                          = Chars  (Discrim_Name))
3885            or else Chars (Original_Record_Component (Entity (Discrim)))
3886                          = Chars (Discrim_Name);
3887
3888          if No (Next (Assoc)) then
3889             if not Is_Constrained (Typ)
3890               and then Is_Derived_Type (Typ)
3891               and then Present (Stored_Constraint (Typ))
3892             then
3893                --  If the type is a tagged type with inherited discriminants,
3894                --  use the stored constraint on the parent in order to find
3895                --  the values of discriminants that are otherwise hidden by an
3896                --  explicit constraint. Renamed discriminants are handled in
3897                --  the code above.
3898
3899                --  If several parent discriminants are renamed by a single
3900                --  discriminant of the derived type, the call to obtain the
3901                --  Corresponding_Discriminant field only retrieves the last
3902                --  of them. We recover the constraint on the others from the
3903                --  Stored_Constraint as well.
3904
3905                declare
3906                   D : Entity_Id;
3907                   C : Elmt_Id;
3908
3909                begin
3910                   D := First_Discriminant (Etype (Typ));
3911                   C := First_Elmt (Stored_Constraint (Typ));
3912                   while Present (D) and then Present (C) loop
3913                      if Chars (Discrim_Name) = Chars (D) then
3914                         if Is_Entity_Name (Node (C))
3915                           and then Entity (Node (C)) = Entity (Discrim)
3916                         then
3917                            --  D is renamed by Discrim, whose value is given in
3918                            --  Assoc.
3919
3920                            null;
3921
3922                         else
3923                            Assoc :=
3924                              Make_Component_Association (Sloc (Typ),
3925                                New_List
3926                                  (New_Occurrence_Of (D, Sloc (Typ))),
3927                                   Duplicate_Subexpr_No_Checks (Node (C)));
3928                         end if;
3929                         exit Find_Constraint;
3930                      end if;
3931
3932                      Next_Discriminant (D);
3933                      Next_Elmt (C);
3934                   end loop;
3935                end;
3936             end if;
3937          end if;
3938
3939          if No (Next (Assoc)) then
3940             Error_Msg_NE (" missing value for discriminant&",
3941               First (Governed_By), Discrim_Name);
3942             Report_Errors := True;
3943             return;
3944          end if;
3945
3946          Next (Assoc);
3947       end loop Find_Constraint;
3948
3949       Discrim_Value := Expression (Assoc);
3950
3951       if not Is_OK_Static_Expression (Discrim_Value) then
3952          Error_Msg_FE
3953            ("value for discriminant & must be static!",
3954             Discrim_Value, Discrim);
3955          Why_Not_Static (Discrim_Value);
3956          Report_Errors := True;
3957          return;
3958       end if;
3959
3960       Search_For_Discriminant_Value : declare
3961          Low  : Node_Id;
3962          High : Node_Id;
3963
3964          UI_High          : Uint;
3965          UI_Low           : Uint;
3966          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
3967
3968       begin
3969          Find_Discrete_Value : while Present (Variant) loop
3970             Discrete_Choice := First (Discrete_Choices (Variant));
3971             while Present (Discrete_Choice) loop
3972
3973                exit Find_Discrete_Value when
3974                  Nkind (Discrete_Choice) = N_Others_Choice;
3975
3976                Get_Index_Bounds (Discrete_Choice, Low, High);
3977
3978                UI_Low  := Expr_Value (Low);
3979                UI_High := Expr_Value (High);
3980
3981                exit Find_Discrete_Value when
3982                  UI_Low <= UI_Discrim_Value
3983                    and then
3984                  UI_High >= UI_Discrim_Value;
3985
3986                Next (Discrete_Choice);
3987             end loop;
3988
3989             Next_Non_Pragma (Variant);
3990          end loop Find_Discrete_Value;
3991       end Search_For_Discriminant_Value;
3992
3993       if No (Variant) then
3994          Error_Msg_NE
3995            ("value of discriminant & is out of range", Discrim_Value, Discrim);
3996          Report_Errors := True;
3997          return;
3998       end  if;
3999
4000       --  If we have found the corresponding choice, recursively add its
4001       --  components to the Into list.
4002
4003       Gather_Components (Empty,
4004         Component_List (Variant), Governed_By, Into, Report_Errors);
4005    end Gather_Components;
4006
4007    ------------------------
4008    -- Get_Actual_Subtype --
4009    ------------------------
4010
4011    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
4012       Typ  : constant Entity_Id := Etype (N);
4013       Utyp : Entity_Id := Underlying_Type (Typ);
4014       Decl : Node_Id;
4015       Atyp : Entity_Id;
4016
4017    begin
4018       if No (Utyp) then
4019          Utyp := Typ;
4020       end if;
4021
4022       --  If what we have is an identifier that references a subprogram
4023       --  formal, or a variable or constant object, then we get the actual
4024       --  subtype from the referenced entity if one has been built.
4025
4026       if Nkind (N) = N_Identifier
4027         and then
4028           (Is_Formal (Entity (N))
4029             or else Ekind (Entity (N)) = E_Constant
4030             or else Ekind (Entity (N)) = E_Variable)
4031         and then Present (Actual_Subtype (Entity (N)))
4032       then
4033          return Actual_Subtype (Entity (N));
4034
4035       --  Actual subtype of unchecked union is always itself. We never need
4036       --  the "real" actual subtype. If we did, we couldn't get it anyway
4037       --  because the discriminant is not available. The restrictions on
4038       --  Unchecked_Union are designed to make sure that this is OK.
4039
4040       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
4041          return Typ;
4042
4043       --  Here for the unconstrained case, we must find actual subtype
4044       --  No actual subtype is available, so we must build it on the fly.
4045
4046       --  Checking the type, not the underlying type, for constrainedness
4047       --  seems to be necessary. Maybe all the tests should be on the type???
4048
4049       elsif (not Is_Constrained (Typ))
4050            and then (Is_Array_Type (Utyp)
4051                       or else (Is_Record_Type (Utyp)
4052                                 and then Has_Discriminants (Utyp)))
4053            and then not Has_Unknown_Discriminants (Utyp)
4054            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
4055       then
4056          --  Nothing to do if in spec expression (why not???)
4057
4058          if In_Spec_Expression then
4059             return Typ;
4060
4061          elsif Is_Private_Type (Typ)
4062            and then not Has_Discriminants (Typ)
4063          then
4064             --  If the type has no discriminants, there is no subtype to
4065             --  build, even if the underlying type is discriminated.
4066
4067             return Typ;
4068
4069          --  Else build the actual subtype
4070
4071          else
4072             Decl := Build_Actual_Subtype (Typ, N);
4073             Atyp := Defining_Identifier (Decl);
4074
4075             --  If Build_Actual_Subtype generated a new declaration then use it
4076
4077             if Atyp /= Typ then
4078
4079                --  The actual subtype is an Itype, so analyze the declaration,
4080                --  but do not attach it to the tree, to get the type defined.
4081
4082                Set_Parent (Decl, N);
4083                Set_Is_Itype (Atyp);
4084                Analyze (Decl, Suppress => All_Checks);
4085                Set_Associated_Node_For_Itype (Atyp, N);
4086                Set_Has_Delayed_Freeze (Atyp, False);
4087
4088                --  We need to freeze the actual subtype immediately. This is
4089                --  needed, because otherwise this Itype will not get frozen
4090                --  at all, and it is always safe to freeze on creation because
4091                --  any associated types must be frozen at this point.
4092
4093                Freeze_Itype (Atyp, N);
4094                return Atyp;
4095
4096             --  Otherwise we did not build a declaration, so return original
4097
4098             else
4099                return Typ;
4100             end if;
4101          end if;
4102
4103       --  For all remaining cases, the actual subtype is the same as
4104       --  the nominal type.
4105
4106       else
4107          return Typ;
4108       end if;
4109    end Get_Actual_Subtype;
4110
4111    -------------------------------------
4112    -- Get_Actual_Subtype_If_Available --
4113    -------------------------------------
4114
4115    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
4116       Typ  : constant Entity_Id := Etype (N);
4117
4118    begin
4119       --  If what we have is an identifier that references a subprogram
4120       --  formal, or a variable or constant object, then we get the actual
4121       --  subtype from the referenced entity if one has been built.
4122
4123       if Nkind (N) = N_Identifier
4124         and then
4125           (Is_Formal (Entity (N))
4126             or else Ekind (Entity (N)) = E_Constant
4127             or else Ekind (Entity (N)) = E_Variable)
4128         and then Present (Actual_Subtype (Entity (N)))
4129       then
4130          return Actual_Subtype (Entity (N));
4131
4132       --  Otherwise the Etype of N is returned unchanged
4133
4134       else
4135          return Typ;
4136       end if;
4137    end Get_Actual_Subtype_If_Available;
4138
4139    -------------------------------
4140    -- Get_Default_External_Name --
4141    -------------------------------
4142
4143    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
4144    begin
4145       Get_Decoded_Name_String (Chars (E));
4146
4147       if Opt.External_Name_Imp_Casing = Uppercase then
4148          Set_Casing (All_Upper_Case);
4149       else
4150          Set_Casing (All_Lower_Case);
4151       end if;
4152
4153       return
4154         Make_String_Literal (Sloc (E),
4155           Strval => String_From_Name_Buffer);
4156    end Get_Default_External_Name;
4157
4158    ---------------------------
4159    -- Get_Enum_Lit_From_Pos --
4160    ---------------------------
4161
4162    function Get_Enum_Lit_From_Pos
4163      (T   : Entity_Id;
4164       Pos : Uint;
4165       Loc : Source_Ptr) return Node_Id
4166    is
4167       Lit : Node_Id;
4168
4169    begin
4170       --  In the case where the literal is of type Character, Wide_Character
4171       --  or Wide_Wide_Character or of a type derived from them, there needs
4172       --  to be some special handling since there is no explicit chain of
4173       --  literals to search. Instead, an N_Character_Literal node is created
4174       --  with the appropriate Char_Code and Chars fields.
4175
4176       if Is_Standard_Character_Type (T) then
4177          Set_Character_Literal_Name (UI_To_CC (Pos));
4178          return
4179            Make_Character_Literal (Loc,
4180              Chars              => Name_Find,
4181              Char_Literal_Value => Pos);
4182
4183       --  For all other cases, we have a complete table of literals, and
4184       --  we simply iterate through the chain of literal until the one
4185       --  with the desired position value is found.
4186       --
4187
4188       else
4189          Lit := First_Literal (Base_Type (T));
4190          for J in 1 .. UI_To_Int (Pos) loop
4191             Next_Literal (Lit);
4192          end loop;
4193
4194          return New_Occurrence_Of (Lit, Loc);
4195       end if;
4196    end Get_Enum_Lit_From_Pos;
4197
4198    ------------------------
4199    -- Get_Generic_Entity --
4200    ------------------------
4201
4202    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
4203       Ent : constant Entity_Id := Entity (Name (N));
4204    begin
4205       if Present (Renamed_Object (Ent)) then
4206          return Renamed_Object (Ent);
4207       else
4208          return Ent;
4209       end if;
4210    end Get_Generic_Entity;
4211
4212    ----------------------
4213    -- Get_Index_Bounds --
4214    ----------------------
4215
4216    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
4217       Kind : constant Node_Kind := Nkind (N);
4218       R    : Node_Id;
4219
4220    begin
4221       if Kind = N_Range then
4222          L := Low_Bound (N);
4223          H := High_Bound (N);
4224
4225       elsif Kind = N_Subtype_Indication then
4226          R := Range_Expression (Constraint (N));
4227
4228          if R = Error then
4229             L := Error;
4230             H := Error;
4231             return;
4232
4233          else
4234             L := Low_Bound  (Range_Expression (Constraint (N)));
4235             H := High_Bound (Range_Expression (Constraint (N)));
4236          end if;
4237
4238       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
4239          if Error_Posted (Scalar_Range (Entity (N))) then
4240             L := Error;
4241             H := Error;
4242
4243          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
4244             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
4245
4246          else
4247             L := Low_Bound  (Scalar_Range (Entity (N)));
4248             H := High_Bound (Scalar_Range (Entity (N)));
4249          end if;
4250
4251       else
4252          --  N is an expression, indicating a range with one value
4253
4254          L := N;
4255          H := N;
4256       end if;
4257    end Get_Index_Bounds;
4258
4259    ----------------------------------
4260    -- Get_Library_Unit_Name_string --
4261    ----------------------------------
4262
4263    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
4264       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
4265
4266    begin
4267       Get_Unit_Name_String (Unit_Name_Id);
4268
4269       --  Remove seven last character (" (spec)" or " (body)")
4270
4271       Name_Len := Name_Len - 7;
4272       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
4273    end Get_Library_Unit_Name_String;
4274
4275    ------------------------
4276    -- Get_Name_Entity_Id --
4277    ------------------------
4278
4279    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
4280    begin
4281       return Entity_Id (Get_Name_Table_Info (Id));
4282    end Get_Name_Entity_Id;
4283
4284    -------------------
4285    -- Get_Pragma_Id --
4286    -------------------
4287
4288    function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
4289    begin
4290       return Get_Pragma_Id (Pragma_Name (N));
4291    end Get_Pragma_Id;
4292
4293    ---------------------------
4294    -- Get_Referenced_Object --
4295    ---------------------------
4296
4297    function Get_Referenced_Object (N : Node_Id) return Node_Id is
4298       R : Node_Id;
4299
4300    begin
4301       R := N;
4302       while Is_Entity_Name (R)
4303         and then Present (Renamed_Object (Entity (R)))
4304       loop
4305          R := Renamed_Object (Entity (R));
4306       end loop;
4307
4308       return R;
4309    end Get_Referenced_Object;
4310
4311    ------------------------
4312    -- Get_Renamed_Entity --
4313    ------------------------
4314
4315    function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
4316       R : Entity_Id;
4317
4318    begin
4319       R := E;
4320       while Present (Renamed_Entity (R)) loop
4321          R := Renamed_Entity (R);
4322       end loop;
4323
4324       return R;
4325    end Get_Renamed_Entity;
4326
4327    -------------------------
4328    -- Get_Subprogram_Body --
4329    -------------------------
4330
4331    function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
4332       Decl : Node_Id;
4333
4334    begin
4335       Decl := Unit_Declaration_Node (E);
4336
4337       if Nkind (Decl) = N_Subprogram_Body then
4338          return Decl;
4339
4340       --  The below comment is bad, because it is possible for
4341       --  Nkind (Decl) to be an N_Subprogram_Body_Stub ???
4342
4343       else           --  Nkind (Decl) = N_Subprogram_Declaration
4344
4345          if Present (Corresponding_Body (Decl)) then
4346             return Unit_Declaration_Node (Corresponding_Body (Decl));
4347
4348          --  Imported subprogram case
4349
4350          else
4351             return Empty;
4352          end if;
4353       end if;
4354    end Get_Subprogram_Body;
4355
4356    ---------------------------
4357    -- Get_Subprogram_Entity --
4358    ---------------------------
4359
4360    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
4361       Nam  : Node_Id;
4362       Proc : Entity_Id;
4363
4364    begin
4365       if Nkind (Nod) = N_Accept_Statement then
4366          Nam := Entry_Direct_Name (Nod);
4367
4368       --  For an entry call, the prefix of the call is a selected component.
4369       --  Need additional code for internal calls ???
4370
4371       elsif Nkind (Nod) = N_Entry_Call_Statement then
4372          if Nkind (Name (Nod)) = N_Selected_Component then
4373             Nam := Entity (Selector_Name (Name (Nod)));
4374          else
4375             Nam := Empty;
4376          end if;
4377
4378       else
4379          Nam := Name (Nod);
4380       end if;
4381
4382       if Nkind (Nam) = N_Explicit_Dereference then
4383          Proc := Etype (Prefix (Nam));
4384       elsif Is_Entity_Name (Nam) then
4385          Proc := Entity (Nam);
4386       else
4387          return Empty;
4388       end if;
4389
4390       if Is_Object (Proc) then
4391          Proc := Etype (Proc);
4392       end if;
4393
4394       if Ekind (Proc) = E_Access_Subprogram_Type then
4395          Proc := Directly_Designated_Type (Proc);
4396       end if;
4397
4398       if not Is_Subprogram (Proc)
4399         and then Ekind (Proc) /= E_Subprogram_Type
4400       then
4401          return Empty;
4402       else
4403          return Proc;
4404       end if;
4405    end Get_Subprogram_Entity;
4406
4407    -----------------------------
4408    -- Get_Task_Body_Procedure --
4409    -----------------------------
4410
4411    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
4412    begin
4413       --  Note: A task type may be the completion of a private type with
4414       --  discriminants. When performing elaboration checks on a task
4415       --  declaration, the current view of the type may be the private one,
4416       --  and the procedure that holds the body of the task is held in its
4417       --  underlying type.
4418
4419       --  This is an odd function, why not have Task_Body_Procedure do
4420       --  the following digging???
4421
4422       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
4423    end Get_Task_Body_Procedure;
4424
4425    -----------------------
4426    -- Has_Access_Values --
4427    -----------------------
4428
4429    function Has_Access_Values (T : Entity_Id) return Boolean is
4430       Typ : constant Entity_Id := Underlying_Type (T);
4431
4432    begin
4433       --  Case of a private type which is not completed yet. This can only
4434       --  happen in the case of a generic format type appearing directly, or
4435       --  as a component of the type to which this function is being applied
4436       --  at the top level. Return False in this case, since we certainly do
4437       --  not know that the type contains access types.
4438
4439       if No (Typ) then
4440          return False;
4441
4442       elsif Is_Access_Type (Typ) then
4443          return True;
4444
4445       elsif Is_Array_Type (Typ) then
4446          return Has_Access_Values (Component_Type (Typ));
4447
4448       elsif Is_Record_Type (Typ) then
4449          declare
4450             Comp : Entity_Id;
4451
4452          begin
4453             --  Loop to Check components
4454
4455             Comp := First_Component_Or_Discriminant (Typ);
4456             while Present (Comp) loop
4457
4458                --  Check for access component, tag field does not count, even
4459                --  though it is implemented internally using an access type.
4460
4461                if Has_Access_Values (Etype (Comp))
4462                  and then Chars (Comp) /= Name_uTag
4463                then
4464                   return True;
4465                end if;
4466
4467                Next_Component_Or_Discriminant (Comp);
4468             end loop;
4469          end;
4470
4471          return False;
4472
4473       else
4474          return False;
4475       end if;
4476    end Has_Access_Values;
4477
4478    ------------------------------
4479    -- Has_Compatible_Alignment --
4480    ------------------------------
4481
4482    function Has_Compatible_Alignment
4483      (Obj  : Entity_Id;
4484       Expr : Node_Id) return Alignment_Result
4485    is
4486       function Has_Compatible_Alignment_Internal
4487         (Obj     : Entity_Id;
4488          Expr    : Node_Id;
4489          Default : Alignment_Result) return Alignment_Result;
4490       --  This is the internal recursive function that actually does the work.
4491       --  There is one additional parameter, which says what the result should
4492       --  be if no alignment information is found, and there is no definite
4493       --  indication of compatible alignments. At the outer level, this is set
4494       --  to Unknown, but for internal recursive calls in the case where types
4495       --  are known to be correct, it is set to Known_Compatible.
4496
4497       ---------------------------------------
4498       -- Has_Compatible_Alignment_Internal --
4499       ---------------------------------------
4500
4501       function Has_Compatible_Alignment_Internal
4502         (Obj     : Entity_Id;
4503          Expr    : Node_Id;
4504          Default : Alignment_Result) return Alignment_Result
4505       is
4506          Result : Alignment_Result := Known_Compatible;
4507          --  Holds the current status of the result. Note that once a value of
4508          --  Known_Incompatible is set, it is sticky and does not get changed
4509          --  to Unknown (the value in Result only gets worse as we go along,
4510          --  never better).
4511
4512          Offs : Uint := No_Uint;
4513          --  Set to a factor of the offset from the base object when Expr is a
4514          --  selected or indexed component, based on Component_Bit_Offset and
4515          --  Component_Size respectively. A negative value is used to represent
4516          --  a value which is not known at compile time.
4517
4518          procedure Check_Prefix;
4519          --  Checks the prefix recursively in the case where the expression
4520          --  is an indexed or selected component.
4521
4522          procedure Set_Result (R : Alignment_Result);
4523          --  If R represents a worse outcome (unknown instead of known
4524          --  compatible, or known incompatible), then set Result to R.
4525
4526          ------------------
4527          -- Check_Prefix --
4528          ------------------
4529
4530          procedure Check_Prefix is
4531          begin
4532             --  The subtlety here is that in doing a recursive call to check
4533             --  the prefix, we have to decide what to do in the case where we
4534             --  don't find any specific indication of an alignment problem.
4535
4536             --  At the outer level, we normally set Unknown as the result in
4537             --  this case, since we can only set Known_Compatible if we really
4538             --  know that the alignment value is OK, but for the recursive
4539             --  call, in the case where the types match, and we have not
4540             --  specified a peculiar alignment for the object, we are only
4541             --  concerned about suspicious rep clauses, the default case does
4542             --  not affect us, since the compiler will, in the absence of such
4543             --  rep clauses, ensure that the alignment is correct.
4544
4545             if Default = Known_Compatible
4546               or else
4547                 (Etype (Obj) = Etype (Expr)
4548                   and then (Unknown_Alignment (Obj)
4549                              or else
4550                                Alignment (Obj) = Alignment (Etype (Obj))))
4551             then
4552                Set_Result
4553                  (Has_Compatible_Alignment_Internal
4554                     (Obj, Prefix (Expr), Known_Compatible));
4555
4556             --  In all other cases, we need a full check on the prefix
4557
4558             else
4559                Set_Result
4560                  (Has_Compatible_Alignment_Internal
4561                     (Obj, Prefix (Expr), Unknown));
4562             end if;
4563          end Check_Prefix;
4564
4565          ----------------
4566          -- Set_Result --
4567          ----------------
4568
4569          procedure Set_Result (R : Alignment_Result) is
4570          begin
4571             if R > Result then
4572                Result := R;
4573             end if;
4574          end Set_Result;
4575
4576       --  Start of processing for Has_Compatible_Alignment_Internal
4577
4578       begin
4579          --  If Expr is a selected component, we must make sure there is no
4580          --  potentially troublesome component clause, and that the record is
4581          --  not packed.
4582
4583          if Nkind (Expr) = N_Selected_Component then
4584
4585             --  Packed record always generate unknown alignment
4586
4587             if Is_Packed (Etype (Prefix (Expr))) then
4588                Set_Result (Unknown);
4589             end if;
4590
4591             --  Check prefix and component offset
4592
4593             Check_Prefix;
4594             Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
4595
4596          --  If Expr is an indexed component, we must make sure there is no
4597          --  potentially troublesome Component_Size clause and that the array
4598          --  is not bit-packed.
4599
4600          elsif Nkind (Expr) = N_Indexed_Component then
4601             declare
4602                Typ : constant Entity_Id := Etype (Prefix (Expr));
4603                Ind : constant Node_Id   := First_Index (Typ);
4604
4605             begin
4606                --  Bit packed array always generates unknown alignment
4607
4608                if Is_Bit_Packed_Array (Typ) then
4609                   Set_Result (Unknown);
4610                end if;
4611
4612                --  Check prefix and component offset
4613
4614                Check_Prefix;
4615                Offs := Component_Size (Typ);
4616
4617                --  Small optimization: compute the full offset when possible
4618
4619                if Offs /= No_Uint
4620                  and then Offs > Uint_0
4621                  and then Present (Ind)
4622                  and then Nkind (Ind) = N_Range
4623                  and then Compile_Time_Known_Value (Low_Bound (Ind))
4624                  and then Compile_Time_Known_Value (First (Expressions (Expr)))
4625                then
4626                   Offs := Offs * (Expr_Value (First (Expressions (Expr)))
4627                                     - Expr_Value (Low_Bound ((Ind))));
4628                end if;
4629             end;
4630          end if;
4631
4632          --  If we have a null offset, the result is entirely determined by
4633          --  the base object and has already been computed recursively.
4634
4635          if Offs = Uint_0 then
4636             null;
4637
4638          --  Case where we know the alignment of the object
4639
4640          elsif Known_Alignment (Obj) then
4641             declare
4642                ObjA : constant Uint := Alignment (Obj);
4643                ExpA : Uint          := No_Uint;
4644                SizA : Uint          := No_Uint;
4645
4646             begin
4647                --  If alignment of Obj is 1, then we are always OK
4648
4649                if ObjA = 1 then
4650                   Set_Result (Known_Compatible);
4651
4652                --  Alignment of Obj is greater than 1, so we need to check
4653
4654                else
4655                   --  If we have an offset, see if it is compatible
4656
4657                   if Offs /= No_Uint and Offs > Uint_0 then
4658                      if Offs mod (System_Storage_Unit * ObjA) /= 0 then
4659                         Set_Result (Known_Incompatible);
4660                      end if;
4661
4662                      --  See if Expr is an object with known alignment
4663
4664                   elsif Is_Entity_Name (Expr)
4665                     and then Known_Alignment (Entity (Expr))
4666                   then
4667                      ExpA := Alignment (Entity (Expr));
4668
4669                      --  Otherwise, we can use the alignment of the type of
4670                      --  Expr given that we already checked for
4671                      --  discombobulating rep clauses for the cases of indexed
4672                      --  and selected components above.
4673
4674                   elsif Known_Alignment (Etype (Expr)) then
4675                      ExpA := Alignment (Etype (Expr));
4676
4677                      --  Otherwise the alignment is unknown
4678
4679                   else
4680                      Set_Result (Default);
4681                   end if;
4682
4683                   --  If we got an alignment, see if it is acceptable
4684
4685                   if ExpA /= No_Uint and then ExpA < ObjA then
4686                      Set_Result (Known_Incompatible);
4687                   end if;
4688
4689                   --  If Expr is not a piece of a larger object, see if size
4690                   --  is given. If so, check that it is not too small for the
4691                   --  required alignment.
4692
4693                   if Offs /= No_Uint then
4694                      null;
4695
4696                      --  See if Expr is an object with known size
4697
4698                   elsif Is_Entity_Name (Expr)
4699                     and then Known_Static_Esize (Entity (Expr))
4700                   then
4701                      SizA := Esize (Entity (Expr));
4702
4703                      --  Otherwise, we check the object size of the Expr type
4704
4705                   elsif Known_Static_Esize (Etype (Expr)) then
4706                      SizA := Esize (Etype (Expr));
4707                   end if;
4708
4709                   --  If we got a size, see if it is a multiple of the Obj
4710                   --  alignment, if not, then the alignment cannot be
4711                   --  acceptable, since the size is always a multiple of the
4712                   --  alignment.
4713
4714                   if SizA /= No_Uint then
4715                      if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
4716                         Set_Result (Known_Incompatible);
4717                      end if;
4718                   end if;
4719                end if;
4720             end;
4721
4722          --  If we do not know required alignment, any non-zero offset is a
4723          --  potential problem (but certainly may be OK, so result is unknown).
4724
4725          elsif Offs /= No_Uint then
4726             Set_Result (Unknown);
4727
4728          --  If we can't find the result by direct comparison of alignment
4729          --  values, then there is still one case that we can determine known
4730          --  result, and that is when we can determine that the types are the
4731          --  same, and no alignments are specified. Then we known that the
4732          --  alignments are compatible, even if we don't know the alignment
4733          --  value in the front end.
4734
4735          elsif Etype (Obj) = Etype (Expr) then
4736
4737             --  Types are the same, but we have to check for possible size
4738             --  and alignments on the Expr object that may make the alignment
4739             --  different, even though the types are the same.
4740
4741             if Is_Entity_Name (Expr) then
4742
4743                --  First check alignment of the Expr object. Any alignment less
4744                --  than Maximum_Alignment is worrisome since this is the case
4745                --  where we do not know the alignment of Obj.
4746
4747                if Known_Alignment (Entity (Expr))
4748                  and then
4749                    UI_To_Int (Alignment (Entity (Expr))) <
4750                                                     Ttypes.Maximum_Alignment
4751                then
4752                   Set_Result (Unknown);
4753
4754                   --  Now check size of Expr object. Any size that is not an
4755                   --  even multiple of Maximum_Alignment is also worrisome
4756                   --  since it may cause the alignment of the object to be less
4757                   --  than the alignment of the type.
4758
4759                elsif Known_Static_Esize (Entity (Expr))
4760                  and then
4761                    (UI_To_Int (Esize (Entity (Expr))) mod
4762                      (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
4763                                                                         /= 0
4764                then
4765                   Set_Result (Unknown);
4766
4767                   --  Otherwise same type is decisive
4768
4769                else
4770                   Set_Result (Known_Compatible);
4771                end if;
4772             end if;
4773
4774          --  Another case to deal with is when there is an explicit size or
4775          --  alignment clause when the types are not the same. If so, then the
4776          --  result is Unknown. We don't need to do this test if the Default is
4777          --  Unknown, since that result will be set in any case.
4778
4779          elsif Default /= Unknown
4780            and then (Has_Size_Clause      (Etype (Expr))
4781                       or else
4782                      Has_Alignment_Clause (Etype (Expr)))
4783          then
4784             Set_Result (Unknown);
4785
4786          --  If no indication found, set default
4787
4788          else
4789             Set_Result (Default);
4790          end if;
4791
4792          --  Return worst result found
4793
4794          return Result;
4795       end Has_Compatible_Alignment_Internal;
4796
4797    --  Start of processing for Has_Compatible_Alignment
4798
4799    begin
4800       --  If Obj has no specified alignment, then set alignment from the type
4801       --  alignment. Perhaps we should always do this, but for sure we should
4802       --  do it when there is an address clause since we can do more if the
4803       --  alignment is known.
4804
4805       if Unknown_Alignment (Obj) then
4806          Set_Alignment (Obj, Alignment (Etype (Obj)));
4807       end if;
4808
4809       --  Now do the internal call that does all the work
4810
4811       return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
4812    end Has_Compatible_Alignment;
4813
4814    ----------------------
4815    -- Has_Declarations --
4816    ----------------------
4817
4818    function Has_Declarations (N : Node_Id) return Boolean is
4819    begin
4820       return Nkind_In (Nkind (N), N_Accept_Statement,
4821                                   N_Block_Statement,
4822                                   N_Compilation_Unit_Aux,
4823                                   N_Entry_Body,
4824                                   N_Package_Body,
4825                                   N_Protected_Body,
4826                                   N_Subprogram_Body,
4827                                   N_Task_Body,
4828                                   N_Package_Specification);
4829    end Has_Declarations;
4830
4831    -------------------------------------------
4832    -- Has_Discriminant_Dependent_Constraint --
4833    -------------------------------------------
4834
4835    function Has_Discriminant_Dependent_Constraint
4836      (Comp : Entity_Id) return Boolean
4837    is
4838       Comp_Decl  : constant Node_Id := Parent (Comp);
4839       Subt_Indic : constant Node_Id :=
4840                      Subtype_Indication (Component_Definition (Comp_Decl));
4841       Constr     : Node_Id;
4842       Assn       : Node_Id;
4843
4844    begin
4845       if Nkind (Subt_Indic) = N_Subtype_Indication then
4846          Constr := Constraint (Subt_Indic);
4847
4848          if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
4849             Assn := First (Constraints (Constr));
4850             while Present (Assn) loop
4851                case Nkind (Assn) is
4852                   when N_Subtype_Indication |
4853                        N_Range              |
4854                        N_Identifier
4855                   =>
4856                      if Depends_On_Discriminant (Assn) then
4857                         return True;
4858                      end if;
4859
4860                   when N_Discriminant_Association =>
4861                      if Depends_On_Discriminant (Expression (Assn)) then
4862                         return True;
4863                      end if;
4864
4865                   when others =>
4866                      null;
4867
4868                end case;
4869
4870                Next (Assn);
4871             end loop;
4872          end if;
4873       end if;
4874
4875       return False;
4876    end Has_Discriminant_Dependent_Constraint;
4877
4878    --------------------
4879    -- Has_Infinities --
4880    --------------------
4881
4882    function Has_Infinities (E : Entity_Id) return Boolean is
4883    begin
4884       return
4885         Is_Floating_Point_Type (E)
4886           and then Nkind (Scalar_Range (E)) = N_Range
4887           and then Includes_Infinities (Scalar_Range (E));
4888    end Has_Infinities;
4889
4890    --------------------
4891    -- Has_Interfaces --
4892    --------------------
4893
4894    function Has_Interfaces
4895      (T             : Entity_Id;
4896       Use_Full_View : Boolean := True) return Boolean
4897    is
4898       Typ : Entity_Id := Base_Type (T);
4899
4900    begin
4901       --  Handle concurrent types
4902
4903       if Is_Concurrent_Type (Typ) then
4904          Typ := Corresponding_Record_Type (Typ);
4905       end if;
4906
4907       if not Present (Typ)
4908         or else not Is_Record_Type (Typ)
4909         or else not Is_Tagged_Type (Typ)
4910       then
4911          return False;
4912       end if;
4913
4914       --  Handle private types
4915
4916       if Use_Full_View
4917         and then Present (Full_View (Typ))
4918       then
4919          Typ := Full_View (Typ);
4920       end if;
4921
4922       --  Handle concurrent record types
4923
4924       if Is_Concurrent_Record_Type (Typ)
4925         and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
4926       then
4927          return True;
4928       end if;
4929
4930       loop
4931          if Is_Interface (Typ)
4932            or else
4933              (Is_Record_Type (Typ)
4934                and then Present (Interfaces (Typ))
4935                and then not Is_Empty_Elmt_List (Interfaces (Typ)))
4936          then
4937             return True;
4938          end if;
4939
4940          exit when Etype (Typ) = Typ
4941
4942             --  Handle private types
4943
4944             or else (Present (Full_View (Etype (Typ)))
4945                        and then Full_View (Etype (Typ)) = Typ)
4946
4947             --  Protect the frontend against wrong source with cyclic
4948             --  derivations
4949
4950             or else Etype (Typ) = T;
4951
4952          --  Climb to the ancestor type handling private types
4953
4954          if Present (Full_View (Etype (Typ))) then
4955             Typ := Full_View (Etype (Typ));
4956          else
4957             Typ := Etype (Typ);
4958          end if;
4959       end loop;
4960
4961       return False;
4962    end Has_Interfaces;
4963
4964    ------------------------
4965    -- Has_Null_Exclusion --
4966    ------------------------
4967
4968    function Has_Null_Exclusion (N : Node_Id) return Boolean is
4969    begin
4970       case Nkind (N) is
4971          when N_Access_Definition               |
4972               N_Access_Function_Definition      |
4973               N_Access_Procedure_Definition     |
4974               N_Access_To_Object_Definition     |
4975               N_Allocator                       |
4976               N_Derived_Type_Definition         |
4977               N_Function_Specification          |
4978               N_Subtype_Declaration             =>
4979             return Null_Exclusion_Present (N);
4980
4981          when N_Component_Definition            |
4982               N_Formal_Object_Declaration       |
4983               N_Object_Renaming_Declaration     =>
4984             if Present (Subtype_Mark (N)) then
4985                return Null_Exclusion_Present (N);
4986             else pragma Assert (Present (Access_Definition (N)));
4987                return Null_Exclusion_Present (Access_Definition (N));
4988             end if;
4989
4990          when N_Discriminant_Specification =>
4991             if Nkind (Discriminant_Type (N)) = N_Access_Definition then
4992                return Null_Exclusion_Present (Discriminant_Type (N));
4993             else
4994                return Null_Exclusion_Present (N);
4995             end if;
4996
4997          when N_Object_Declaration =>
4998             if Nkind (Object_Definition (N)) = N_Access_Definition then
4999                return Null_Exclusion_Present (Object_Definition (N));
5000             else
5001                return Null_Exclusion_Present (N);
5002             end if;
5003
5004          when N_Parameter_Specification =>
5005             if Nkind (Parameter_Type (N)) = N_Access_Definition then
5006                return Null_Exclusion_Present (Parameter_Type (N));
5007             else
5008                return Null_Exclusion_Present (N);
5009             end if;
5010
5011          when others =>
5012             return False;
5013
5014       end case;
5015    end Has_Null_Exclusion;
5016
5017    ------------------------
5018    -- Has_Null_Extension --
5019    ------------------------
5020
5021    function Has_Null_Extension (T : Entity_Id) return Boolean is
5022       B     : constant Entity_Id := Base_Type (T);
5023       Comps : Node_Id;
5024       Ext   : Node_Id;
5025
5026    begin
5027       if Nkind (Parent (B)) = N_Full_Type_Declaration
5028         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
5029       then
5030          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
5031
5032          if Present (Ext) then
5033             if Null_Present (Ext) then
5034                return True;
5035             else
5036                Comps := Component_List (Ext);
5037
5038                --  The null component list is rewritten during analysis to
5039                --  include the parent component. Any other component indicates
5040                --  that the extension was not originally null.
5041
5042                return Null_Present (Comps)
5043                  or else No (Next (First (Component_Items (Comps))));
5044             end if;
5045          else
5046             return False;
5047          end if;
5048
5049       else
5050          return False;
5051       end if;
5052    end Has_Null_Extension;
5053
5054    -------------------------------
5055    -- Has_Overriding_Initialize --
5056    -------------------------------
5057
5058    function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
5059       BT   : constant Entity_Id := Base_Type (T);
5060       P    : Elmt_Id;
5061
5062    begin
5063       if Is_Controlled (BT) then
5064          if Is_RTU (Scope (BT), Ada_Finalization) then
5065             return False;
5066
5067          elsif Present (Primitive_Operations (BT)) then
5068             P := First_Elmt (Primitive_Operations (BT));
5069             while Present (P) loop
5070                declare
5071                   Init : constant Entity_Id := Node (P);
5072                   Formal : constant Entity_Id := First_Formal (Init);
5073                begin
5074                   if Ekind (Init) = E_Procedure
5075                        and then Chars (Init) = Name_Initialize
5076                        and then Comes_From_Source (Init)
5077                        and then Present (Formal)
5078                        and then Etype (Formal) = BT
5079                        and then No (Next_Formal (Formal))
5080                        and then (Ada_Version < Ada_2012
5081                                    or else not Null_Present (Parent (Init)))
5082                   then
5083                      return True;
5084                   end if;
5085                end;
5086
5087                Next_Elmt (P);
5088             end loop;
5089          end if;
5090
5091          --  Here if type itself does not have a non-null Initialize operation:
5092          --  check immediate ancestor.
5093
5094          if Is_Derived_Type (BT)
5095            and then Has_Overriding_Initialize (Etype (BT))
5096          then
5097             return True;
5098          end if;
5099       end if;
5100
5101       return False;
5102    end Has_Overriding_Initialize;
5103
5104    --------------------------------------
5105    -- Has_Preelaborable_Initialization --
5106    --------------------------------------
5107
5108    function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
5109       Has_PE : Boolean;
5110
5111       procedure Check_Components (E : Entity_Id);
5112       --  Check component/discriminant chain, sets Has_PE False if a component
5113       --  or discriminant does not meet the preelaborable initialization rules.
5114
5115       ----------------------
5116       -- Check_Components --
5117       ----------------------
5118
5119       procedure Check_Components (E : Entity_Id) is
5120          Ent : Entity_Id;
5121          Exp : Node_Id;
5122
5123          function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
5124          --  Returns True if and only if the expression denoted by N does not
5125          --  violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
5126
5127          ---------------------------------
5128          -- Is_Preelaborable_Expression --
5129          ---------------------------------
5130
5131          function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
5132             Exp           : Node_Id;
5133             Assn          : Node_Id;
5134             Choice        : Node_Id;
5135             Comp_Type     : Entity_Id;
5136             Is_Array_Aggr : Boolean;
5137
5138          begin
5139             if Is_Static_Expression (N) then
5140                return True;
5141
5142             elsif Nkind (N) = N_Null then
5143                return True;
5144
5145             --  Attributes are allowed in general, even if their prefix is a
5146             --  formal type. (It seems that certain attributes known not to be
5147             --  static might not be allowed, but there are no rules to prevent
5148             --  them.)
5149
5150             elsif Nkind (N) = N_Attribute_Reference then
5151                return True;
5152
5153             --  The name of a discriminant evaluated within its parent type is
5154             --  defined to be preelaborable (10.2.1(8)). Note that we test for
5155             --  names that denote discriminals as well as discriminants to
5156             --  catch references occurring within init procs.
5157
5158             elsif Is_Entity_Name (N)
5159               and then
5160                 (Ekind (Entity (N)) = E_Discriminant
5161                   or else
5162                     ((Ekind (Entity (N)) = E_Constant
5163                        or else Ekind (Entity (N)) = E_In_Parameter)
5164                      and then Present (Discriminal_Link (Entity (N)))))
5165             then
5166                return True;
5167
5168             elsif Nkind (N) = N_Qualified_Expression then
5169                return Is_Preelaborable_Expression (Expression (N));
5170
5171             --  For aggregates we have to check that each of the associations
5172             --  is preelaborable.
5173
5174             elsif Nkind (N) = N_Aggregate
5175               or else Nkind (N) = N_Extension_Aggregate
5176             then
5177                Is_Array_Aggr := Is_Array_Type (Etype (N));
5178
5179                if Is_Array_Aggr then
5180                   Comp_Type := Component_Type (Etype (N));
5181                end if;
5182
5183                --  Check the ancestor part of extension aggregates, which must
5184                --  be either the name of a type that has preelaborable init or
5185                --  an expression that is preelaborable.
5186
5187                if Nkind (N) = N_Extension_Aggregate then
5188                   declare
5189                      Anc_Part : constant Node_Id := Ancestor_Part (N);
5190
5191                   begin
5192                      if Is_Entity_Name (Anc_Part)
5193                        and then Is_Type (Entity (Anc_Part))
5194                      then
5195                         if not Has_Preelaborable_Initialization
5196                                  (Entity (Anc_Part))
5197                         then
5198                            return False;
5199                         end if;
5200
5201                      elsif not Is_Preelaborable_Expression (Anc_Part) then
5202                         return False;
5203                      end if;
5204                   end;
5205                end if;
5206
5207                --  Check positional associations
5208
5209                Exp := First (Expressions (N));
5210                while Present (Exp) loop
5211                   if not Is_Preelaborable_Expression (Exp) then
5212                      return False;
5213                   end if;
5214
5215                   Next (Exp);
5216                end loop;
5217
5218                --  Check named associations
5219
5220                Assn := First (Component_Associations (N));
5221                while Present (Assn) loop
5222                   Choice := First (Choices (Assn));
5223                   while Present (Choice) loop
5224                      if Is_Array_Aggr then
5225                         if Nkind (Choice) = N_Others_Choice then
5226                            null;
5227
5228                         elsif Nkind (Choice) = N_Range then
5229                            if not Is_Static_Range (Choice) then
5230                               return False;
5231                            end if;
5232
5233                         elsif not Is_Static_Expression (Choice) then
5234                            return False;
5235                         end if;
5236
5237                      else
5238                         Comp_Type := Etype (Choice);
5239                      end if;
5240
5241                      Next (Choice);
5242                   end loop;
5243
5244                   --  If the association has a <> at this point, then we have
5245                   --  to check whether the component's type has preelaborable
5246                   --  initialization. Note that this only occurs when the
5247                   --  association's corresponding component does not have a
5248                   --  default expression, the latter case having already been
5249                   --  expanded as an expression for the association.
5250
5251                   if Box_Present (Assn) then
5252                      if not Has_Preelaborable_Initialization (Comp_Type) then
5253                         return False;
5254                      end if;
5255
5256                   --  In the expression case we check whether the expression
5257                   --  is preelaborable.
5258
5259                   elsif
5260                     not Is_Preelaborable_Expression (Expression (Assn))
5261                   then
5262                      return False;
5263                   end if;
5264
5265                   Next (Assn);
5266                end loop;
5267
5268                --  If we get here then aggregate as a whole is preelaborable
5269
5270                return True;
5271
5272             --  All other cases are not preelaborable
5273
5274             else
5275                return False;
5276             end if;
5277          end Is_Preelaborable_Expression;
5278
5279       --  Start of processing for Check_Components
5280
5281       begin
5282          --  Loop through entities of record or protected type
5283
5284          Ent := E;
5285          while Present (Ent) loop
5286
5287             --  We are interested only in components and discriminants
5288
5289             Exp := Empty;
5290
5291             case Ekind (Ent) is
5292                when E_Component =>
5293
5294                   --  Get default expression if any. If there is no declaration
5295                   --  node, it means we have an internal entity. The parent and
5296                   --  tag fields are examples of such entities. For such cases,
5297                   --  we just test the type of the entity.
5298
5299                   if Present (Declaration_Node (Ent)) then
5300                      Exp := Expression (Declaration_Node (Ent));
5301                   end if;
5302
5303                when E_Discriminant =>
5304
5305                   --  Note: for a renamed discriminant, the Declaration_Node
5306                   --  may point to the one from the ancestor, and have a
5307                   --  different expression, so use the proper attribute to
5308                   --  retrieve the expression from the derived constraint.
5309
5310                   Exp := Discriminant_Default_Value (Ent);
5311
5312                when others =>
5313                   goto Check_Next_Entity;
5314             end case;
5315
5316             --  A component has PI if it has no default expression and the
5317             --  component type has PI.
5318
5319             if No (Exp) then
5320                if not Has_Preelaborable_Initialization (Etype (Ent)) then
5321                   Has_PE := False;
5322                   exit;
5323                end if;
5324
5325             --  Require the default expression to be preelaborable
5326
5327             elsif not Is_Preelaborable_Expression (Exp) then
5328                Has_PE := False;
5329                exit;
5330             end if;
5331
5332          <<Check_Next_Entity>>
5333             Next_Entity (Ent);
5334          end loop;
5335       end Check_Components;
5336
5337    --  Start of processing for Has_Preelaborable_Initialization
5338
5339    begin
5340       --  Immediate return if already marked as known preelaborable init. This
5341       --  covers types for which this function has already been called once
5342       --  and returned True (in which case the result is cached), and also
5343       --  types to which a pragma Preelaborable_Initialization applies.
5344
5345       if Known_To_Have_Preelab_Init (E) then
5346          return True;
5347       end if;
5348
5349       --  If the type is a subtype representing a generic actual type, then
5350       --  test whether its base type has preelaborable initialization since
5351       --  the subtype representing the actual does not inherit this attribute
5352       --  from the actual or formal. (but maybe it should???)
5353
5354       if Is_Generic_Actual_Type (E) then
5355          return Has_Preelaborable_Initialization (Base_Type (E));
5356       end if;
5357
5358       --  All elementary types have preelaborable initialization
5359
5360       if Is_Elementary_Type (E) then
5361          Has_PE := True;
5362
5363       --  Array types have PI if the component type has PI
5364
5365       elsif Is_Array_Type (E) then
5366          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
5367
5368       --  A derived type has preelaborable initialization if its parent type
5369       --  has preelaborable initialization and (in the case of a derived record
5370       --  extension) if the non-inherited components all have preelaborable
5371       --  initialization. However, a user-defined controlled type with an
5372       --  overriding Initialize procedure does not have preelaborable
5373       --  initialization.
5374
5375       elsif Is_Derived_Type (E) then
5376
5377          --  If the derived type is a private extension then it doesn't have
5378          --  preelaborable initialization.
5379
5380          if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
5381             return False;
5382          end if;
5383
5384          --  First check whether ancestor type has preelaborable initialization
5385
5386          Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
5387
5388          --  If OK, check extension components (if any)
5389
5390          if Has_PE and then Is_Record_Type (E) then
5391             Check_Components (First_Entity (E));
5392          end if;
5393
5394          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
5395          --  with a user defined Initialize procedure does not have PI.
5396
5397          if Has_PE
5398            and then Is_Controlled (E)
5399            and then Has_Overriding_Initialize (E)
5400          then
5401             Has_PE := False;
5402          end if;
5403
5404       --  Private types not derived from a type having preelaborable init and
5405       --  that are not marked with pragma Preelaborable_Initialization do not
5406       --  have preelaborable initialization.
5407
5408       elsif Is_Private_Type (E) then
5409          return False;
5410
5411       --  Record type has PI if it is non private and all components have PI
5412
5413       elsif Is_Record_Type (E) then
5414          Has_PE := True;
5415          Check_Components (First_Entity (E));
5416
5417       --  Protected types must not have entries, and components must meet
5418       --  same set of rules as for record components.
5419
5420       elsif Is_Protected_Type (E) then
5421          if Has_Entries (E) then
5422             Has_PE := False;
5423          else
5424             Has_PE := True;
5425             Check_Components (First_Entity (E));
5426             Check_Components (First_Private_Entity (E));
5427          end if;
5428
5429       --  Type System.Address always has preelaborable initialization
5430
5431       elsif Is_RTE (E, RE_Address) then
5432          Has_PE := True;
5433
5434       --  In all other cases, type does not have preelaborable initialization
5435
5436       else
5437          return False;
5438       end if;
5439
5440       --  If type has preelaborable initialization, cache result
5441
5442       if Has_PE then
5443          Set_Known_To_Have_Preelab_Init (E);
5444       end if;
5445
5446       return Has_PE;
5447    end Has_Preelaborable_Initialization;
5448
5449    ---------------------------
5450    -- Has_Private_Component --
5451    ---------------------------
5452
5453    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
5454       Btype     : Entity_Id := Base_Type (Type_Id);
5455       Component : Entity_Id;
5456
5457    begin
5458       if Error_Posted (Type_Id)
5459         or else Error_Posted (Btype)
5460       then
5461          return False;
5462       end if;
5463
5464       if Is_Class_Wide_Type (Btype) then
5465          Btype := Root_Type (Btype);
5466       end if;
5467
5468       if Is_Private_Type (Btype) then
5469          declare
5470             UT : constant Entity_Id := Underlying_Type (Btype);
5471          begin
5472             if No (UT) then
5473                if No (Full_View (Btype)) then
5474                   return not Is_Generic_Type (Btype)
5475                     and then not Is_Generic_Type (Root_Type (Btype));
5476                else
5477                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
5478                end if;
5479             else
5480                return not Is_Frozen (UT) and then Has_Private_Component (UT);
5481             end if;
5482          end;
5483
5484       elsif Is_Array_Type (Btype) then
5485          return Has_Private_Component (Component_Type (Btype));
5486
5487       elsif Is_Record_Type (Btype) then
5488          Component := First_Component (Btype);
5489          while Present (Component) loop
5490             if Has_Private_Component (Etype (Component)) then
5491                return True;
5492             end if;
5493
5494             Next_Component (Component);
5495          end loop;
5496
5497          return False;
5498
5499       elsif Is_Protected_Type (Btype)
5500         and then Present (Corresponding_Record_Type (Btype))
5501       then
5502          return Has_Private_Component (Corresponding_Record_Type (Btype));
5503
5504       else
5505          return False;
5506       end if;
5507    end Has_Private_Component;
5508
5509    ----------------
5510    -- Has_Stream --
5511    ----------------
5512
5513    function Has_Stream (T : Entity_Id) return Boolean is
5514       E : Entity_Id;
5515
5516    begin
5517       if No (T) then
5518          return False;
5519
5520       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
5521          return True;
5522
5523       elsif Is_Array_Type (T) then
5524          return Has_Stream (Component_Type (T));
5525
5526       elsif Is_Record_Type (T) then
5527          E := First_Component (T);
5528          while Present (E) loop
5529             if Has_Stream (Etype (E)) then
5530                return True;
5531             else
5532                Next_Component (E);
5533             end if;
5534          end loop;
5535
5536          return False;
5537
5538       elsif Is_Private_Type (T) then
5539          return Has_Stream (Underlying_Type (T));
5540
5541       else
5542          return False;
5543       end if;
5544    end Has_Stream;
5545
5546    ----------------
5547    -- Has_Suffix --
5548    ----------------
5549
5550    function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
5551    begin
5552       Get_Name_String (Chars (E));
5553       return Name_Buffer (Name_Len) = Suffix;
5554    end Has_Suffix;
5555
5556    --------------------------
5557    -- Has_Tagged_Component --
5558    --------------------------
5559
5560    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
5561       Comp : Entity_Id;
5562
5563    begin
5564       if Is_Private_Type (Typ)
5565         and then Present (Underlying_Type (Typ))
5566       then
5567          return Has_Tagged_Component (Underlying_Type (Typ));
5568
5569       elsif Is_Array_Type (Typ) then
5570          return Has_Tagged_Component (Component_Type (Typ));
5571
5572       elsif Is_Tagged_Type (Typ) then
5573          return True;
5574
5575       elsif Is_Record_Type (Typ) then
5576          Comp := First_Component (Typ);
5577          while Present (Comp) loop
5578             if Has_Tagged_Component (Etype (Comp)) then
5579                return True;
5580             end if;
5581
5582             Next_Component (Comp);
5583          end loop;
5584
5585          return False;
5586
5587       else
5588          return False;
5589       end if;
5590    end Has_Tagged_Component;
5591
5592    -------------------------
5593    -- Implementation_Kind --
5594    -------------------------
5595
5596    function Implementation_Kind (Subp : Entity_Id) return Name_Id is
5597       Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
5598    begin
5599       pragma Assert (Present (Impl_Prag));
5600       return
5601         Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
5602    end Implementation_Kind;
5603
5604    --------------------------
5605    -- Implements_Interface --
5606    --------------------------
5607
5608    function Implements_Interface
5609      (Typ_Ent         : Entity_Id;
5610       Iface_Ent       : Entity_Id;
5611       Exclude_Parents : Boolean := False) return Boolean
5612    is
5613       Ifaces_List : Elist_Id;
5614       Elmt        : Elmt_Id;
5615       Iface       : Entity_Id := Base_Type (Iface_Ent);
5616       Typ         : Entity_Id := Base_Type (Typ_Ent);
5617
5618    begin
5619       if Is_Class_Wide_Type (Typ) then
5620          Typ := Root_Type (Typ);
5621       end if;
5622
5623       if not Has_Interfaces (Typ) then
5624          return False;
5625       end if;
5626
5627       if Is_Class_Wide_Type (Iface) then
5628          Iface := Root_Type (Iface);
5629       end if;
5630
5631       Collect_Interfaces (Typ, Ifaces_List);
5632
5633       Elmt := First_Elmt (Ifaces_List);
5634       while Present (Elmt) loop
5635          if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
5636            and then Exclude_Parents
5637          then
5638             null;
5639
5640          elsif Node (Elmt) = Iface then
5641             return True;
5642          end if;
5643
5644          Next_Elmt (Elmt);
5645       end loop;
5646
5647       return False;
5648    end Implements_Interface;
5649
5650    -----------------
5651    -- In_Instance --
5652    -----------------
5653
5654    function In_Instance return Boolean is
5655       Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
5656       S         : Entity_Id;
5657
5658    begin
5659       S := Current_Scope;
5660       while Present (S)
5661         and then S /= Standard_Standard
5662       loop
5663          if (Ekind (S) = E_Function
5664               or else Ekind (S) = E_Package
5665               or else Ekind (S) = E_Procedure)
5666            and then Is_Generic_Instance (S)
5667          then
5668             --  A child instance is always compiled in the context of a parent
5669             --  instance. Nevertheless, the actuals are not analyzed in an
5670             --  instance context. We detect this case by examining the current
5671             --  compilation unit, which must be a child instance, and checking
5672             --  that it is not currently on the scope stack.
5673
5674             if Is_Child_Unit (Curr_Unit)
5675               and then
5676                 Nkind (Unit (Cunit (Current_Sem_Unit)))
5677                   = N_Package_Instantiation
5678               and then not In_Open_Scopes (Curr_Unit)
5679             then
5680                return False;
5681             else
5682                return True;
5683             end if;
5684          end if;
5685
5686          S := Scope (S);
5687       end loop;
5688
5689       return False;
5690    end In_Instance;
5691
5692    ----------------------
5693    -- In_Instance_Body --
5694    ----------------------
5695
5696    function In_Instance_Body return Boolean is
5697       S : Entity_Id;
5698
5699    begin
5700       S := Current_Scope;
5701       while Present (S)
5702         and then S /= Standard_Standard
5703       loop
5704          if (Ekind (S) = E_Function
5705               or else Ekind (S) = E_Procedure)
5706            and then Is_Generic_Instance (S)
5707          then
5708             return True;
5709
5710          elsif Ekind (S) = E_Package
5711            and then In_Package_Body (S)
5712            and then Is_Generic_Instance (S)
5713          then
5714             return True;
5715          end if;
5716
5717          S := Scope (S);
5718       end loop;
5719
5720       return False;
5721    end In_Instance_Body;
5722
5723    -----------------------------
5724    -- In_Instance_Not_Visible --
5725    -----------------------------
5726
5727    function In_Instance_Not_Visible return Boolean is
5728       S : Entity_Id;
5729
5730    begin
5731       S := Current_Scope;
5732       while Present (S)
5733         and then S /= Standard_Standard
5734       loop
5735          if (Ekind (S) = E_Function
5736               or else Ekind (S) = E_Procedure)
5737            and then Is_Generic_Instance (S)
5738          then
5739             return True;
5740
5741          elsif Ekind (S) = E_Package
5742            and then (In_Package_Body (S) or else In_Private_Part (S))
5743            and then Is_Generic_Instance (S)
5744          then
5745             return True;
5746          end if;
5747
5748          S := Scope (S);
5749       end loop;
5750
5751       return False;
5752    end In_Instance_Not_Visible;
5753
5754    ------------------------------
5755    -- In_Instance_Visible_Part --
5756    ------------------------------
5757
5758    function In_Instance_Visible_Part return Boolean is
5759       S : Entity_Id;
5760
5761    begin
5762       S := Current_Scope;
5763       while Present (S)
5764         and then S /= Standard_Standard
5765       loop
5766          if Ekind (S) = E_Package
5767            and then Is_Generic_Instance (S)
5768            and then not In_Package_Body (S)
5769            and then not In_Private_Part (S)
5770          then
5771             return True;
5772          end if;
5773
5774          S := Scope (S);
5775       end loop;
5776
5777       return False;
5778    end In_Instance_Visible_Part;
5779
5780    ---------------------
5781    -- In_Package_Body --
5782    ---------------------
5783
5784    function In_Package_Body return Boolean is
5785       S : Entity_Id;
5786
5787    begin
5788       S := Current_Scope;
5789       while Present (S)
5790         and then S /= Standard_Standard
5791       loop
5792          if Ekind (S) = E_Package
5793            and then In_Package_Body (S)
5794          then
5795             return True;
5796          else
5797             S := Scope (S);
5798          end if;
5799       end loop;
5800
5801       return False;
5802    end In_Package_Body;
5803
5804    --------------------------------
5805    -- In_Parameter_Specification --
5806    --------------------------------
5807
5808    function In_Parameter_Specification (N : Node_Id) return Boolean is
5809       PN : Node_Id;
5810
5811    begin
5812       PN := Parent (N);
5813       while Present (PN) loop
5814          if Nkind (PN) = N_Parameter_Specification then
5815             return True;
5816          end if;
5817
5818          PN := Parent (PN);
5819       end loop;
5820
5821       return False;
5822    end In_Parameter_Specification;
5823
5824    --------------------------------------
5825    -- In_Subprogram_Or_Concurrent_Unit --
5826    --------------------------------------
5827
5828    function In_Subprogram_Or_Concurrent_Unit return Boolean is
5829       E : Entity_Id;
5830       K : Entity_Kind;
5831
5832    begin
5833       --  Use scope chain to check successively outer scopes
5834
5835       E := Current_Scope;
5836       loop
5837          K := Ekind (E);
5838
5839          if K in Subprogram_Kind
5840            or else K in Concurrent_Kind
5841            or else K in Generic_Subprogram_Kind
5842          then
5843             return True;
5844
5845          elsif E = Standard_Standard then
5846             return False;
5847          end if;
5848
5849          E := Scope (E);
5850       end loop;
5851    end In_Subprogram_Or_Concurrent_Unit;
5852
5853    ---------------------
5854    -- In_Visible_Part --
5855    ---------------------
5856
5857    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
5858    begin
5859       return
5860         Is_Package_Or_Generic_Package (Scope_Id)
5861           and then In_Open_Scopes (Scope_Id)
5862           and then not In_Package_Body (Scope_Id)
5863           and then not In_Private_Part (Scope_Id);
5864    end In_Visible_Part;
5865
5866    ---------------------------------
5867    -- Insert_Explicit_Dereference --
5868    ---------------------------------
5869
5870    procedure Insert_Explicit_Dereference (N : Node_Id) is
5871       New_Prefix : constant Node_Id := Relocate_Node (N);
5872       Ent        : Entity_Id := Empty;
5873       Pref       : Node_Id;
5874       I          : Interp_Index;
5875       It         : Interp;
5876       T          : Entity_Id;
5877
5878    begin
5879       Save_Interps (N, New_Prefix);
5880
5881       Rewrite (N,
5882         Make_Explicit_Dereference (Sloc (Parent (N)),
5883           Prefix => New_Prefix));
5884
5885       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
5886
5887       if Is_Overloaded (New_Prefix) then
5888
5889          --  The dereference is also overloaded, and its interpretations are
5890          --  the designated types of the interpretations of the original node.
5891
5892          Set_Etype (N, Any_Type);
5893
5894          Get_First_Interp (New_Prefix, I, It);
5895          while Present (It.Nam) loop
5896             T := It.Typ;
5897
5898             if Is_Access_Type (T) then
5899                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
5900             end if;
5901
5902             Get_Next_Interp (I, It);
5903          end loop;
5904
5905          End_Interp_List;
5906
5907       else
5908          --  Prefix is unambiguous: mark the original prefix (which might
5909          --  Come_From_Source) as a reference, since the new (relocated) one
5910          --  won't be taken into account.
5911
5912          if Is_Entity_Name (New_Prefix) then
5913             Ent := Entity (New_Prefix);
5914             Pref := New_Prefix;
5915
5916          --  For a retrieval of a subcomponent of some composite object,
5917          --  retrieve the ultimate entity if there is one.
5918
5919          elsif Nkind (New_Prefix) = N_Selected_Component
5920            or else Nkind (New_Prefix) = N_Indexed_Component
5921          then
5922             Pref := Prefix (New_Prefix);
5923             while Present (Pref)
5924               and then
5925                 (Nkind (Pref) = N_Selected_Component
5926                   or else Nkind (Pref) = N_Indexed_Component)
5927             loop
5928                Pref := Prefix (Pref);
5929             end loop;
5930
5931             if Present (Pref) and then Is_Entity_Name (Pref) then
5932                Ent := Entity (Pref);
5933             end if;
5934          end if;
5935
5936          --  Place the reference on the entity node
5937
5938          if Present (Ent) then
5939             Generate_Reference (Ent, Pref);
5940          end if;
5941       end if;
5942    end Insert_Explicit_Dereference;
5943
5944    ------------------------------------------
5945    -- Inspect_Deferred_Constant_Completion --
5946    ------------------------------------------
5947
5948    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
5949       Decl   : Node_Id;
5950
5951    begin
5952       Decl := First (Decls);
5953       while Present (Decl) loop
5954
5955          --  Deferred constant signature
5956
5957          if Nkind (Decl) = N_Object_Declaration
5958            and then Constant_Present (Decl)
5959            and then No (Expression (Decl))
5960
5961             --  No need to check internally generated constants
5962
5963            and then Comes_From_Source (Decl)
5964
5965             --  The constant is not completed. A full object declaration or a
5966             --  pragma Import complete a deferred constant.
5967
5968            and then not Has_Completion (Defining_Identifier (Decl))
5969          then
5970             Error_Msg_N
5971               ("constant declaration requires initialization expression",
5972               Defining_Identifier (Decl));
5973          end if;
5974
5975          Decl := Next (Decl);
5976       end loop;
5977    end Inspect_Deferred_Constant_Completion;
5978
5979    -----------------------------
5980    -- Is_Actual_Out_Parameter --
5981    -----------------------------
5982
5983    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
5984       Formal : Entity_Id;
5985       Call   : Node_Id;
5986    begin
5987       Find_Actual (N, Formal, Call);
5988       return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
5989    end Is_Actual_Out_Parameter;
5990
5991    -------------------------
5992    -- Is_Actual_Parameter --
5993    -------------------------
5994
5995    function Is_Actual_Parameter (N : Node_Id) return Boolean is
5996       PK : constant Node_Kind := Nkind (Parent (N));
5997
5998    begin
5999       case PK is
6000          when N_Parameter_Association =>
6001             return N = Explicit_Actual_Parameter (Parent (N));
6002
6003          when N_Function_Call | N_Procedure_Call_Statement =>
6004             return Is_List_Member (N)
6005               and then
6006                 List_Containing (N) = Parameter_Associations (Parent (N));
6007
6008          when others =>
6009             return False;
6010       end case;
6011    end Is_Actual_Parameter;
6012
6013    --------------------------------
6014    -- Is_Actual_Tagged_Parameter --
6015    --------------------------------
6016
6017    function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
6018       Formal : Entity_Id;
6019       Call   : Node_Id;
6020    begin
6021       Find_Actual (N, Formal, Call);
6022       return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
6023    end Is_Actual_Tagged_Parameter;
6024
6025    ---------------------
6026    -- Is_Aliased_View --
6027    ---------------------
6028
6029    function Is_Aliased_View (Obj : Node_Id) return Boolean is
6030       E : Entity_Id;
6031
6032    begin
6033       if Is_Entity_Name (Obj) then
6034
6035          E := Entity (Obj);
6036
6037          return
6038            (Is_Object (E)
6039              and then
6040                (Is_Aliased (E)
6041                   or else (Present (Renamed_Object (E))
6042                              and then Is_Aliased_View (Renamed_Object (E)))))
6043
6044            or else ((Is_Formal (E)
6045                       or else Ekind (E) = E_Generic_In_Out_Parameter
6046                       or else Ekind (E) = E_Generic_In_Parameter)
6047                     and then Is_Tagged_Type (Etype (E)))
6048
6049            or else (Is_Concurrent_Type (E)
6050                      and then In_Open_Scopes (E))
6051
6052             --  Current instance of type, either directly or as rewritten
6053             --  reference to the current object.
6054
6055            or else (Is_Entity_Name (Original_Node (Obj))
6056                      and then Present (Entity (Original_Node (Obj)))
6057                      and then Is_Type (Entity (Original_Node (Obj))))
6058
6059            or else (Is_Type (E) and then E = Current_Scope)
6060
6061            or else (Is_Incomplete_Or_Private_Type (E)
6062                      and then Full_View (E) = Current_Scope);
6063
6064       elsif Nkind (Obj) = N_Selected_Component then
6065          return Is_Aliased (Entity (Selector_Name (Obj)));
6066
6067       elsif Nkind (Obj) = N_Indexed_Component then
6068          return Has_Aliased_Components (Etype (Prefix (Obj)))
6069            or else
6070              (Is_Access_Type (Etype (Prefix (Obj)))
6071                and then
6072               Has_Aliased_Components
6073                 (Designated_Type (Etype (Prefix (Obj)))));
6074
6075       elsif Nkind (Obj) = N_Unchecked_Type_Conversion
6076         or else Nkind (Obj) = N_Type_Conversion
6077       then
6078          return Is_Tagged_Type (Etype (Obj))
6079            and then Is_Aliased_View (Expression (Obj));
6080
6081       elsif Nkind (Obj) = N_Explicit_Dereference then
6082          return Nkind (Original_Node (Obj)) /= N_Function_Call;
6083
6084       else
6085          return False;
6086       end if;
6087    end Is_Aliased_View;
6088
6089    -------------------------
6090    -- Is_Ancestor_Package --
6091    -------------------------
6092
6093    function Is_Ancestor_Package
6094      (E1 : Entity_Id;
6095       E2 : Entity_Id) return Boolean
6096    is
6097       Par : Entity_Id;
6098
6099    begin
6100       Par := E2;
6101       while Present (Par)
6102         and then Par /= Standard_Standard
6103       loop
6104          if Par = E1 then
6105             return True;
6106          end if;
6107
6108          Par := Scope (Par);
6109       end loop;
6110
6111       return False;
6112    end Is_Ancestor_Package;
6113
6114    ----------------------
6115    -- Is_Atomic_Object --
6116    ----------------------
6117
6118    function Is_Atomic_Object (N : Node_Id) return Boolean is
6119
6120       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
6121       --  Determines if given object has atomic components
6122
6123       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
6124       --  If prefix is an implicit dereference, examine designated type
6125
6126       ----------------------
6127       -- Is_Atomic_Prefix --
6128       ----------------------
6129
6130       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
6131       begin
6132          if Is_Access_Type (Etype (N)) then
6133             return
6134               Has_Atomic_Components (Designated_Type (Etype (N)));
6135          else
6136             return Object_Has_Atomic_Components (N);
6137          end if;
6138       end Is_Atomic_Prefix;
6139
6140       ----------------------------------
6141       -- Object_Has_Atomic_Components --
6142       ----------------------------------
6143
6144       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
6145       begin
6146          if Has_Atomic_Components (Etype (N))
6147            or else Is_Atomic (Etype (N))
6148          then
6149             return True;
6150
6151          elsif Is_Entity_Name (N)
6152            and then (Has_Atomic_Components (Entity (N))
6153                       or else Is_Atomic (Entity (N)))
6154          then
6155             return True;
6156
6157          elsif Nkind (N) = N_Indexed_Component
6158            or else Nkind (N) = N_Selected_Component
6159          then
6160             return Is_Atomic_Prefix (Prefix (N));
6161
6162          else
6163             return False;
6164          end if;
6165       end Object_Has_Atomic_Components;
6166
6167    --  Start of processing for Is_Atomic_Object
6168
6169    begin
6170       --  Predicate is not relevant to subprograms
6171
6172       if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
6173          return False;
6174
6175       elsif Is_Atomic (Etype (N))
6176         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
6177       then
6178          return True;
6179
6180       elsif Nkind (N) = N_Indexed_Component
6181         or else Nkind (N) = N_Selected_Component
6182       then
6183          return Is_Atomic_Prefix (Prefix (N));
6184
6185       else
6186          return False;
6187       end if;
6188    end Is_Atomic_Object;
6189
6190    -------------------------
6191    -- Is_Coextension_Root --
6192    -------------------------
6193
6194    function Is_Coextension_Root (N : Node_Id) return Boolean is
6195    begin
6196       return
6197         Nkind (N) = N_Allocator
6198           and then Present (Coextensions (N))
6199
6200          --  Anonymous access discriminants carry a list of all nested
6201          --  controlled coextensions.
6202
6203           and then not Is_Dynamic_Coextension (N)
6204           and then not Is_Static_Coextension (N);
6205    end Is_Coextension_Root;
6206
6207    -----------------------------
6208    -- Is_Concurrent_Interface --
6209    -----------------------------
6210
6211    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
6212    begin
6213       return
6214         Is_Interface (T)
6215           and then
6216             (Is_Protected_Interface (T)
6217                or else Is_Synchronized_Interface (T)
6218                or else Is_Task_Interface (T));
6219    end Is_Concurrent_Interface;
6220
6221    --------------------------------------
6222    -- Is_Controlling_Limited_Procedure --
6223    --------------------------------------
6224
6225    function Is_Controlling_Limited_Procedure
6226      (Proc_Nam : Entity_Id) return Boolean
6227    is
6228       Param_Typ : Entity_Id := Empty;
6229
6230    begin
6231       if Ekind (Proc_Nam) = E_Procedure
6232         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
6233       then
6234          Param_Typ := Etype (Parameter_Type (First (
6235                         Parameter_Specifications (Parent (Proc_Nam)))));
6236
6237       --  In this case where an Itype was created, the procedure call has been
6238       --  rewritten.
6239
6240       elsif Present (Associated_Node_For_Itype (Proc_Nam))
6241         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
6242         and then
6243           Present (Parameter_Associations
6244                      (Associated_Node_For_Itype (Proc_Nam)))
6245       then
6246          Param_Typ :=
6247            Etype (First (Parameter_Associations
6248                           (Associated_Node_For_Itype (Proc_Nam))));
6249       end if;
6250
6251       if Present (Param_Typ) then
6252          return
6253            Is_Interface (Param_Typ)
6254              and then Is_Limited_Record (Param_Typ);
6255       end if;
6256
6257       return False;
6258    end Is_Controlling_Limited_Procedure;
6259
6260    -----------------------------
6261    -- Is_CPP_Constructor_Call --
6262    -----------------------------
6263
6264    function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
6265    begin
6266       return Nkind (N) = N_Function_Call
6267         and then Is_CPP_Class (Etype (Etype (N)))
6268         and then Is_Constructor (Entity (Name (N)))
6269         and then Is_Imported (Entity (Name (N)));
6270    end Is_CPP_Constructor_Call;
6271
6272    -----------------
6273    -- Is_Delegate --
6274    -----------------
6275
6276    function Is_Delegate (T : Entity_Id) return Boolean is
6277       Desig_Type : Entity_Id;
6278
6279    begin
6280       if VM_Target /= CLI_Target then
6281          return False;
6282       end if;
6283
6284       --  Access-to-subprograms are delegates in CIL
6285
6286       if Ekind (T) = E_Access_Subprogram_Type then
6287          return True;
6288       end if;
6289
6290       if Ekind (T) not in Access_Kind then
6291
6292          --  A delegate is a managed pointer. If no designated type is defined
6293          --  it means that it's not a delegate.
6294
6295          return False;
6296       end if;
6297
6298       Desig_Type := Etype (Directly_Designated_Type (T));
6299
6300       if not Is_Tagged_Type (Desig_Type) then
6301          return False;
6302       end if;
6303
6304       --  Test if the type is inherited from [mscorlib]System.Delegate
6305
6306       while Etype (Desig_Type) /= Desig_Type loop
6307          if Chars (Scope (Desig_Type)) /= No_Name
6308            and then Is_Imported (Scope (Desig_Type))
6309            and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
6310          then
6311             return True;
6312          end if;
6313
6314          Desig_Type := Etype (Desig_Type);
6315       end loop;
6316
6317       return False;
6318    end Is_Delegate;
6319
6320    ----------------------------------------------
6321    -- Is_Dependent_Component_Of_Mutable_Object --
6322    ----------------------------------------------
6323
6324    function Is_Dependent_Component_Of_Mutable_Object
6325      (Object : Node_Id) return Boolean
6326    is
6327       P           : Node_Id;
6328       Prefix_Type : Entity_Id;
6329       P_Aliased   : Boolean := False;
6330       Comp        : Entity_Id;
6331
6332       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
6333       --  Returns True if and only if Comp is declared within a variant part
6334
6335       --------------------------------
6336       -- Is_Declared_Within_Variant --
6337       --------------------------------
6338
6339       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
6340          Comp_Decl : constant Node_Id   := Parent (Comp);
6341          Comp_List : constant Node_Id   := Parent (Comp_Decl);
6342       begin
6343          return Nkind (Parent (Comp_List)) = N_Variant;
6344       end Is_Declared_Within_Variant;
6345
6346    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
6347
6348    begin
6349       if Is_Variable (Object) then
6350
6351          if Nkind (Object) = N_Selected_Component then
6352             P := Prefix (Object);
6353             Prefix_Type := Etype (P);
6354
6355             if Is_Entity_Name (P) then
6356
6357                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
6358                   Prefix_Type := Base_Type (Prefix_Type);
6359                end if;
6360
6361                if Is_Aliased (Entity (P)) then
6362                   P_Aliased := True;
6363                end if;
6364
6365             --  A discriminant check on a selected component may be expanded
6366             --  into a dereference when removing side-effects. Recover the
6367             --  original node and its type, which may be unconstrained.
6368
6369             elsif Nkind (P) = N_Explicit_Dereference
6370               and then not (Comes_From_Source (P))
6371             then
6372                P := Original_Node (P);
6373                Prefix_Type := Etype (P);
6374
6375             else
6376                --  Check for prefix being an aliased component???
6377
6378                null;
6379
6380             end if;
6381
6382             --  A heap object is constrained by its initial value
6383
6384             --  Ada 2005 (AI-363): Always assume the object could be mutable in
6385             --  the dereferenced case, since the access value might denote an
6386             --  unconstrained aliased object, whereas in Ada 95 the designated
6387             --  object is guaranteed to be constrained. A worst-case assumption
6388             --  has to apply in Ada 2005 because we can't tell at compile time
6389             --  whether the object is "constrained by its initial value"
6390             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
6391             --  semantic rules -- these rules are acknowledged to need fixing).
6392
6393             if Ada_Version < Ada_2005 then
6394                if Is_Access_Type (Prefix_Type)
6395                  or else Nkind (P) = N_Explicit_Dereference
6396                then
6397                   return False;
6398                end if;
6399
6400             elsif Ada_Version >= Ada_2005 then
6401                if Is_Access_Type (Prefix_Type) then
6402
6403                   --  If the access type is pool-specific, and there is no
6404                   --  constrained partial view of the designated type, then the
6405                   --  designated object is known to be constrained.
6406
6407                   if Ekind (Prefix_Type) = E_Access_Type
6408                     and then not Has_Constrained_Partial_View
6409                                    (Designated_Type (Prefix_Type))
6410                   then
6411                      return False;
6412
6413                   --  Otherwise (general access type, or there is a constrained
6414                   --  partial view of the designated type), we need to check
6415                   --  based on the designated type.
6416
6417                   else
6418                      Prefix_Type := Designated_Type (Prefix_Type);
6419                   end if;
6420                end if;
6421             end if;
6422
6423             Comp :=
6424               Original_Record_Component (Entity (Selector_Name (Object)));
6425
6426             --  As per AI-0017, the renaming is illegal in a generic body, even
6427             --  if the subtype is indefinite.
6428
6429             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
6430
6431             if not Is_Constrained (Prefix_Type)
6432               and then (not Is_Indefinite_Subtype (Prefix_Type)
6433                          or else
6434                           (Is_Generic_Type (Prefix_Type)
6435                             and then Ekind (Current_Scope) = E_Generic_Package
6436                             and then In_Package_Body (Current_Scope)))
6437
6438               and then (Is_Declared_Within_Variant (Comp)
6439                           or else Has_Discriminant_Dependent_Constraint (Comp))
6440               and then (not P_Aliased or else Ada_Version >= Ada_2005)
6441             then
6442                return True;
6443
6444             else
6445                return
6446                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6447
6448             end if;
6449
6450          elsif Nkind (Object) = N_Indexed_Component
6451            or else Nkind (Object) = N_Slice
6452          then
6453             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6454
6455          --  A type conversion that Is_Variable is a view conversion:
6456          --  go back to the denoted object.
6457
6458          elsif Nkind (Object) = N_Type_Conversion then
6459             return
6460               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
6461          end if;
6462       end if;
6463
6464       return False;
6465    end Is_Dependent_Component_Of_Mutable_Object;
6466
6467    ---------------------
6468    -- Is_Dereferenced --
6469    ---------------------
6470
6471    function Is_Dereferenced (N : Node_Id) return Boolean is
6472       P : constant Node_Id := Parent (N);
6473    begin
6474       return
6475          (Nkind (P) = N_Selected_Component
6476             or else
6477           Nkind (P) = N_Explicit_Dereference
6478             or else
6479           Nkind (P) = N_Indexed_Component
6480             or else
6481           Nkind (P) = N_Slice)
6482         and then Prefix (P) = N;
6483    end Is_Dereferenced;
6484
6485    ----------------------
6486    -- Is_Descendent_Of --
6487    ----------------------
6488
6489    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
6490       T    : Entity_Id;
6491       Etyp : Entity_Id;
6492
6493    begin
6494       pragma Assert (Nkind (T1) in N_Entity);
6495       pragma Assert (Nkind (T2) in N_Entity);
6496
6497       T := Base_Type (T1);
6498
6499       --  Immediate return if the types match
6500
6501       if T = T2 then
6502          return True;
6503
6504       --  Comment needed here ???
6505
6506       elsif Ekind (T) = E_Class_Wide_Type then
6507          return Etype (T) = T2;
6508
6509       --  All other cases
6510
6511       else
6512          loop
6513             Etyp := Etype (T);
6514
6515             --  Done if we found the type we are looking for
6516
6517             if Etyp = T2 then
6518                return True;
6519
6520             --  Done if no more derivations to check
6521
6522             elsif T = T1
6523               or else T = Etyp
6524             then
6525                return False;
6526
6527             --  Following test catches error cases resulting from prev errors
6528
6529             elsif No (Etyp) then
6530                return False;
6531
6532             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
6533                return False;
6534
6535             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
6536                return False;
6537             end if;
6538
6539             T := Base_Type (Etyp);
6540          end loop;
6541       end if;
6542    end Is_Descendent_Of;
6543
6544    --------------
6545    -- Is_False --
6546    --------------
6547
6548    function Is_False (U : Uint) return Boolean is
6549    begin
6550       return (U = 0);
6551    end Is_False;
6552
6553    ---------------------------
6554    -- Is_Fixed_Model_Number --
6555    ---------------------------
6556
6557    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
6558       S : constant Ureal := Small_Value (T);
6559       M : Urealp.Save_Mark;
6560       R : Boolean;
6561    begin
6562       M := Urealp.Mark;
6563       R := (U = UR_Trunc (U / S) * S);
6564       Urealp.Release (M);
6565       return R;
6566    end Is_Fixed_Model_Number;
6567
6568    -------------------------------
6569    -- Is_Fully_Initialized_Type --
6570    -------------------------------
6571
6572    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
6573    begin
6574       if Is_Scalar_Type (Typ) then
6575          return False;
6576
6577       elsif Is_Access_Type (Typ) then
6578          return True;
6579
6580       elsif Is_Array_Type (Typ) then
6581          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
6582             return True;
6583          end if;
6584
6585          --  An interesting case, if we have a constrained type one of whose
6586          --  bounds is known to be null, then there are no elements to be
6587          --  initialized, so all the elements are initialized!
6588
6589          if Is_Constrained (Typ) then
6590             declare
6591                Indx     : Node_Id;
6592                Indx_Typ : Entity_Id;
6593                Lbd, Hbd : Node_Id;
6594
6595             begin
6596                Indx := First_Index (Typ);
6597                while Present (Indx) loop
6598                   if Etype (Indx) = Any_Type then
6599                      return False;
6600
6601                   --  If index is a range, use directly
6602
6603                   elsif Nkind (Indx) = N_Range then
6604                      Lbd := Low_Bound  (Indx);
6605                      Hbd := High_Bound (Indx);
6606
6607                   else
6608                      Indx_Typ := Etype (Indx);
6609
6610                      if Is_Private_Type (Indx_Typ)  then
6611                         Indx_Typ := Full_View (Indx_Typ);
6612                      end if;
6613
6614                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
6615                         return False;
6616                      else
6617                         Lbd := Type_Low_Bound  (Indx_Typ);
6618                         Hbd := Type_High_Bound (Indx_Typ);
6619                      end if;
6620                   end if;
6621
6622                   if Compile_Time_Known_Value (Lbd)
6623                     and then Compile_Time_Known_Value (Hbd)
6624                   then
6625                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
6626                         return True;
6627                      end if;
6628                   end if;
6629
6630                   Next_Index (Indx);
6631                end loop;
6632             end;
6633          end if;
6634
6635          --  If no null indexes, then type is not fully initialized
6636
6637          return False;
6638
6639       --  Record types
6640
6641       elsif Is_Record_Type (Typ) then
6642          if Has_Discriminants (Typ)
6643            and then
6644              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
6645            and then Is_Fully_Initialized_Variant (Typ)
6646          then
6647             return True;
6648          end if;
6649
6650          --  Controlled records are considered to be fully initialized if
6651          --  there is a user defined Initialize routine. This may not be
6652          --  entirely correct, but as the spec notes, we are guessing here
6653          --  what is best from the point of view of issuing warnings.
6654
6655          if Is_Controlled (Typ) then
6656             declare
6657                Utyp : constant Entity_Id := Underlying_Type (Typ);
6658
6659             begin
6660                if Present (Utyp) then
6661                   declare
6662                      Init : constant Entity_Id :=
6663                               (Find_Prim_Op
6664                                  (Underlying_Type (Typ), Name_Initialize));
6665
6666                   begin
6667                      if Present (Init)
6668                        and then Comes_From_Source (Init)
6669                        and then not
6670                          Is_Predefined_File_Name
6671                            (File_Name (Get_Source_File_Index (Sloc (Init))))
6672                      then
6673                         return True;
6674
6675                      elsif Has_Null_Extension (Typ)
6676                         and then
6677                           Is_Fully_Initialized_Type
6678                             (Etype (Base_Type (Typ)))
6679                      then
6680                         return True;
6681                      end if;
6682                   end;
6683                end if;
6684             end;
6685          end if;
6686
6687          --  Otherwise see if all record components are initialized
6688
6689          declare
6690             Ent : Entity_Id;
6691
6692          begin
6693             Ent := First_Entity (Typ);
6694             while Present (Ent) loop
6695                if Chars (Ent) = Name_uController then
6696                   null;
6697
6698                elsif Ekind (Ent) = E_Component
6699                  and then (No (Parent (Ent))
6700                              or else No (Expression (Parent (Ent))))
6701                  and then not Is_Fully_Initialized_Type (Etype (Ent))
6702
6703                   --  Special VM case for tag components, which need to be
6704                   --  defined in this case, but are never initialized as VMs
6705                   --  are using other dispatching mechanisms. Ignore this
6706                   --  uninitialized case. Note that this applies both to the
6707                   --  uTag entry and the main vtable pointer (CPP_Class case).
6708
6709                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
6710                then
6711                   return False;
6712                end if;
6713
6714                Next_Entity (Ent);
6715             end loop;
6716          end;
6717
6718          --  No uninitialized components, so type is fully initialized.
6719          --  Note that this catches the case of no components as well.
6720
6721          return True;
6722
6723       elsif Is_Concurrent_Type (Typ) then
6724          return True;
6725
6726       elsif Is_Private_Type (Typ) then
6727          declare
6728             U : constant Entity_Id := Underlying_Type (Typ);
6729
6730          begin
6731             if No (U) then
6732                return False;
6733             else
6734                return Is_Fully_Initialized_Type (U);
6735             end if;
6736          end;
6737
6738       else
6739          return False;
6740       end if;
6741    end Is_Fully_Initialized_Type;
6742
6743    ----------------------------------
6744    -- Is_Fully_Initialized_Variant --
6745    ----------------------------------
6746
6747    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
6748       Loc           : constant Source_Ptr := Sloc (Typ);
6749       Constraints   : constant List_Id    := New_List;
6750       Components    : constant Elist_Id   := New_Elmt_List;
6751       Comp_Elmt     : Elmt_Id;
6752       Comp_Id       : Node_Id;
6753       Comp_List     : Node_Id;
6754       Discr         : Entity_Id;
6755       Discr_Val     : Node_Id;
6756
6757       Report_Errors : Boolean;
6758       pragma Warnings (Off, Report_Errors);
6759
6760    begin
6761       if Serious_Errors_Detected > 0 then
6762          return False;
6763       end if;
6764
6765       if Is_Record_Type (Typ)
6766         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
6767         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
6768       then
6769          Comp_List := Component_List (Type_Definition (Parent (Typ)));
6770
6771          Discr := First_Discriminant (Typ);
6772          while Present (Discr) loop
6773             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
6774                Discr_Val := Expression (Parent (Discr));
6775
6776                if Present (Discr_Val)
6777                  and then Is_OK_Static_Expression (Discr_Val)
6778                then
6779                   Append_To (Constraints,
6780                     Make_Component_Association (Loc,
6781                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
6782                       Expression => New_Copy (Discr_Val)));
6783                else
6784                   return False;
6785                end if;
6786             else
6787                return False;
6788             end if;
6789
6790             Next_Discriminant (Discr);
6791          end loop;
6792
6793          Gather_Components
6794            (Typ           => Typ,
6795             Comp_List     => Comp_List,
6796             Governed_By   => Constraints,
6797             Into          => Components,
6798             Report_Errors => Report_Errors);
6799
6800          --  Check that each component present is fully initialized
6801
6802          Comp_Elmt := First_Elmt (Components);
6803          while Present (Comp_Elmt) loop
6804             Comp_Id := Node (Comp_Elmt);
6805
6806             if Ekind (Comp_Id) = E_Component
6807               and then (No (Parent (Comp_Id))
6808                          or else No (Expression (Parent (Comp_Id))))
6809               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
6810             then
6811                return False;
6812             end if;
6813
6814             Next_Elmt (Comp_Elmt);
6815          end loop;
6816
6817          return True;
6818
6819       elsif Is_Private_Type (Typ) then
6820          declare
6821             U : constant Entity_Id := Underlying_Type (Typ);
6822
6823          begin
6824             if No (U) then
6825                return False;
6826             else
6827                return Is_Fully_Initialized_Variant (U);
6828             end if;
6829          end;
6830       else
6831          return False;
6832       end if;
6833    end Is_Fully_Initialized_Variant;
6834
6835    ------------
6836    -- Is_LHS --
6837    ------------
6838
6839    --  We seem to have a lot of overlapping functions that do similar things
6840    --  (testing for left hand sides or lvalues???). Anyway, since this one is
6841    --  purely syntactic, it should be in Sem_Aux I would think???
6842
6843    function Is_LHS (N : Node_Id) return Boolean is
6844       P : constant Node_Id := Parent (N);
6845
6846    begin
6847       if Nkind (P) = N_Assignment_Statement then
6848          return Name (P) = N;
6849
6850       elsif
6851         Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
6852       then
6853          return N = Prefix (P) and then Is_LHS (P);
6854
6855       else
6856          return False;
6857       end if;
6858    end Is_LHS;
6859
6860    ----------------------------
6861    -- Is_Inherited_Operation --
6862    ----------------------------
6863
6864    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
6865       Kind : constant Node_Kind := Nkind (Parent (E));
6866    begin
6867       pragma Assert (Is_Overloadable (E));
6868       return Kind = N_Full_Type_Declaration
6869         or else Kind = N_Private_Extension_Declaration
6870         or else Kind = N_Subtype_Declaration
6871         or else (Ekind (E) = E_Enumeration_Literal
6872                   and then Is_Derived_Type (Etype (E)));
6873    end Is_Inherited_Operation;
6874
6875    -------------------------------------
6876    -- Is_Inherited_Operation_For_Type --
6877    -------------------------------------
6878
6879    function Is_Inherited_Operation_For_Type
6880      (E : Entity_Id; Typ : Entity_Id) return Boolean
6881    is
6882    begin
6883       return Is_Inherited_Operation (E)
6884         and then Etype (Parent (E)) = Typ;
6885    end Is_Inherited_Operation_For_Type;
6886
6887    -----------------------------
6888    -- Is_Library_Level_Entity --
6889    -----------------------------
6890
6891    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
6892    begin
6893       --  The following is a small optimization, and it also properly handles
6894       --  discriminals, which in task bodies might appear in expressions before
6895       --  the corresponding procedure has been created, and which therefore do
6896       --  not have an assigned scope.
6897
6898       if Is_Formal (E) then
6899          return False;
6900       end if;
6901
6902       --  Normal test is simply that the enclosing dynamic scope is Standard
6903
6904       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
6905    end Is_Library_Level_Entity;
6906
6907    ---------------------------------
6908    -- Is_Local_Variable_Reference --
6909    ---------------------------------
6910
6911    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
6912    begin
6913       if not Is_Entity_Name (Expr) then
6914          return False;
6915
6916       else
6917          declare
6918             Ent : constant Entity_Id := Entity (Expr);
6919             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
6920          begin
6921             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
6922                return False;
6923             else
6924                return Present (Sub) and then Sub = Current_Subprogram;
6925             end if;
6926          end;
6927       end if;
6928    end Is_Local_Variable_Reference;
6929
6930    -------------------------
6931    -- Is_Object_Reference --
6932    -------------------------
6933
6934    function Is_Object_Reference (N : Node_Id) return Boolean is
6935    begin
6936       if Is_Entity_Name (N) then
6937          return Present (Entity (N)) and then Is_Object (Entity (N));
6938
6939       else
6940          case Nkind (N) is
6941             when N_Indexed_Component | N_Slice =>
6942                return
6943                  Is_Object_Reference (Prefix (N))
6944                    or else Is_Access_Type (Etype (Prefix (N)));
6945
6946             --  In Ada95, a function call is a constant object; a procedure
6947             --  call is not.
6948
6949             when N_Function_Call =>
6950                return Etype (N) /= Standard_Void_Type;
6951
6952             --  A reference to the stream attribute Input is a function call
6953
6954             when N_Attribute_Reference =>
6955                return Attribute_Name (N) = Name_Input;
6956
6957             when N_Selected_Component =>
6958                return
6959                  Is_Object_Reference (Selector_Name (N))
6960                    and then
6961                      (Is_Object_Reference (Prefix (N))
6962                         or else Is_Access_Type (Etype (Prefix (N))));
6963
6964             when N_Explicit_Dereference =>
6965                return True;
6966
6967             --  A view conversion of a tagged object is an object reference
6968
6969             when N_Type_Conversion =>
6970                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
6971                  and then Is_Tagged_Type (Etype (Expression (N)))
6972                  and then Is_Object_Reference (Expression (N));
6973
6974             --  An unchecked type conversion is considered to be an object if
6975             --  the operand is an object (this construction arises only as a
6976             --  result of expansion activities).
6977
6978             when N_Unchecked_Type_Conversion =>
6979                return True;
6980
6981             when others =>
6982                return False;
6983          end case;
6984       end if;
6985    end Is_Object_Reference;
6986
6987    -----------------------------------
6988    -- Is_OK_Variable_For_Out_Formal --
6989    -----------------------------------
6990
6991    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
6992    begin
6993       Note_Possible_Modification (AV, Sure => True);
6994
6995       --  We must reject parenthesized variable names. The check for
6996       --  Comes_From_Source is present because there are currently
6997       --  cases where the compiler violates this rule (e.g. passing
6998       --  a task object to its controlled Initialize routine).
6999
7000       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
7001          return False;
7002
7003       --  A variable is always allowed
7004
7005       elsif Is_Variable (AV) then
7006          return True;
7007
7008       --  Unchecked conversions are allowed only if they come from the
7009       --  generated code, which sometimes uses unchecked conversions for out
7010       --  parameters in cases where code generation is unaffected. We tell
7011       --  source unchecked conversions by seeing if they are rewrites of an
7012       --  original Unchecked_Conversion function call, or of an explicit
7013       --  conversion of a function call.
7014
7015       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
7016          if Nkind (Original_Node (AV)) = N_Function_Call then
7017             return False;
7018
7019          elsif Comes_From_Source (AV)
7020            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
7021          then
7022             return False;
7023
7024          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
7025             return Is_OK_Variable_For_Out_Formal (Expression (AV));
7026
7027          else
7028             return True;
7029          end if;
7030
7031       --  Normal type conversions are allowed if argument is a variable
7032
7033       elsif Nkind (AV) = N_Type_Conversion then
7034          if Is_Variable (Expression (AV))
7035            and then Paren_Count (Expression (AV)) = 0
7036          then
7037             Note_Possible_Modification (Expression (AV), Sure => True);
7038             return True;
7039
7040          --  We also allow a non-parenthesized expression that raises
7041          --  constraint error if it rewrites what used to be a variable
7042
7043          elsif Raises_Constraint_Error (Expression (AV))
7044             and then Paren_Count (Expression (AV)) = 0
7045             and then Is_Variable (Original_Node (Expression (AV)))
7046          then
7047             return True;
7048
7049          --  Type conversion of something other than a variable
7050
7051          else
7052             return False;
7053          end if;
7054
7055       --  If this node is rewritten, then test the original form, if that is
7056       --  OK, then we consider the rewritten node OK (for example, if the
7057       --  original node is a conversion, then Is_Variable will not be true
7058       --  but we still want to allow the conversion if it converts a variable).
7059
7060       elsif Original_Node (AV) /= AV then
7061          return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
7062
7063       --  All other non-variables are rejected
7064
7065       else
7066          return False;
7067       end if;
7068    end Is_OK_Variable_For_Out_Formal;
7069
7070    -----------------------------------
7071    -- Is_Partially_Initialized_Type --
7072    -----------------------------------
7073
7074    function Is_Partially_Initialized_Type
7075      (Typ              : Entity_Id;
7076       Include_Implicit : Boolean := True) return Boolean
7077    is
7078    begin
7079       if Is_Scalar_Type (Typ) then
7080          return False;
7081
7082       elsif Is_Access_Type (Typ) then
7083          return Include_Implicit;
7084
7085       elsif Is_Array_Type (Typ) then
7086
7087          --  If component type is partially initialized, so is array type
7088
7089          if Is_Partially_Initialized_Type
7090               (Component_Type (Typ), Include_Implicit)
7091          then
7092             return True;
7093
7094          --  Otherwise we are only partially initialized if we are fully
7095          --  initialized (this is the empty array case, no point in us
7096          --  duplicating that code here).
7097
7098          else
7099             return Is_Fully_Initialized_Type (Typ);
7100          end if;
7101
7102       elsif Is_Record_Type (Typ) then
7103
7104          --  A discriminated type is always partially initialized if in
7105          --  all mode
7106
7107          if Has_Discriminants (Typ) and then Include_Implicit then
7108             return True;
7109
7110          --  A tagged type is always partially initialized
7111
7112          elsif Is_Tagged_Type (Typ) then
7113             return True;
7114
7115          --  Case of non-discriminated record
7116
7117          else
7118             declare
7119                Ent : Entity_Id;
7120
7121                Component_Present : Boolean := False;
7122                --  Set True if at least one component is present. If no
7123                --  components are present, then record type is fully
7124                --  initialized (another odd case, like the null array).
7125
7126             begin
7127                --  Loop through components
7128
7129                Ent := First_Entity (Typ);
7130                while Present (Ent) loop
7131                   if Ekind (Ent) = E_Component then
7132                      Component_Present := True;
7133
7134                      --  If a component has an initialization expression then
7135                      --  the enclosing record type is partially initialized
7136
7137                      if Present (Parent (Ent))
7138                        and then Present (Expression (Parent (Ent)))
7139                      then
7140                         return True;
7141
7142                      --  If a component is of a type which is itself partially
7143                      --  initialized, then the enclosing record type is also.
7144
7145                      elsif Is_Partially_Initialized_Type
7146                              (Etype (Ent), Include_Implicit)
7147                      then
7148                         return True;
7149                      end if;
7150                   end if;
7151
7152                   Next_Entity (Ent);
7153                end loop;
7154
7155                --  No initialized components found. If we found any components
7156                --  they were all uninitialized so the result is false.
7157
7158                if Component_Present then
7159                   return False;
7160
7161                --  But if we found no components, then all the components are
7162                --  initialized so we consider the type to be initialized.
7163
7164                else
7165                   return True;
7166                end if;
7167             end;
7168          end if;
7169
7170       --  Concurrent types are always fully initialized
7171
7172       elsif Is_Concurrent_Type (Typ) then
7173          return True;
7174
7175       --  For a private type, go to underlying type. If there is no underlying
7176       --  type then just assume this partially initialized. Not clear if this
7177       --  can happen in a non-error case, but no harm in testing for this.
7178
7179       elsif Is_Private_Type (Typ) then
7180          declare
7181             U : constant Entity_Id := Underlying_Type (Typ);
7182          begin
7183             if No (U) then
7184                return True;
7185             else
7186                return Is_Partially_Initialized_Type (U, Include_Implicit);
7187             end if;
7188          end;
7189
7190       --  For any other type (are there any?) assume partially initialized
7191
7192       else
7193          return True;
7194       end if;
7195    end Is_Partially_Initialized_Type;
7196
7197    ------------------------------------
7198    -- Is_Potentially_Persistent_Type --
7199    ------------------------------------
7200
7201    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
7202       Comp : Entity_Id;
7203       Indx : Node_Id;
7204
7205    begin
7206       --  For private type, test corresponding full type
7207
7208       if Is_Private_Type (T) then
7209          return Is_Potentially_Persistent_Type (Full_View (T));
7210
7211       --  Scalar types are potentially persistent
7212
7213       elsif Is_Scalar_Type (T) then
7214          return True;
7215
7216       --  Record type is potentially persistent if not tagged and the types of
7217       --  all it components are potentially persistent, and no component has
7218       --  an initialization expression.
7219
7220       elsif Is_Record_Type (T)
7221         and then not Is_Tagged_Type (T)
7222         and then not Is_Partially_Initialized_Type (T)
7223       then
7224          Comp := First_Component (T);
7225          while Present (Comp) loop
7226             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
7227                return False;
7228             else
7229                Next_Entity (Comp);
7230             end if;
7231          end loop;
7232
7233          return True;
7234
7235       --  Array type is potentially persistent if its component type is
7236       --  potentially persistent and if all its constraints are static.
7237
7238       elsif Is_Array_Type (T) then
7239          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
7240             return False;
7241          end if;
7242
7243          Indx := First_Index (T);
7244          while Present (Indx) loop
7245             if not Is_OK_Static_Subtype (Etype (Indx)) then
7246                return False;
7247             else
7248                Next_Index (Indx);
7249             end if;
7250          end loop;
7251
7252          return True;
7253
7254       --  All other types are not potentially persistent
7255
7256       else
7257          return False;
7258       end if;
7259    end Is_Potentially_Persistent_Type;
7260
7261    ---------------------------------
7262    -- Is_Protected_Self_Reference --
7263    ---------------------------------
7264
7265    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
7266
7267       function In_Access_Definition (N : Node_Id) return Boolean;
7268       --  Returns true if N belongs to an access definition
7269
7270       --------------------------
7271       -- In_Access_Definition --
7272       --------------------------
7273
7274       function In_Access_Definition (N : Node_Id) return Boolean is
7275          P : Node_Id;
7276
7277       begin
7278          P := Parent (N);
7279          while Present (P) loop
7280             if Nkind (P) = N_Access_Definition then
7281                return True;
7282             end if;
7283
7284             P := Parent (P);
7285          end loop;
7286
7287          return False;
7288       end In_Access_Definition;
7289
7290    --  Start of processing for Is_Protected_Self_Reference
7291
7292    begin
7293       --  Verify that prefix is analyzed and has the proper form. Note that
7294       --  the attributes Elab_Spec, Elab_Body, and UET_Address, which also
7295       --  produce the address of an entity, do not analyze their prefix
7296       --  because they denote entities that are not necessarily visible.
7297       --  Neither of them can apply to a protected type.
7298
7299       return Ada_Version >= Ada_2005
7300         and then Is_Entity_Name (N)
7301         and then Present (Entity (N))
7302         and then Is_Protected_Type (Entity (N))
7303         and then In_Open_Scopes (Entity (N))
7304         and then not In_Access_Definition (N);
7305    end Is_Protected_Self_Reference;
7306
7307    -----------------------------
7308    -- Is_RCI_Pkg_Spec_Or_Body --
7309    -----------------------------
7310
7311    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
7312
7313       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
7314       --  Return True if the unit of Cunit is an RCI package declaration
7315
7316       ---------------------------
7317       -- Is_RCI_Pkg_Decl_Cunit --
7318       ---------------------------
7319
7320       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
7321          The_Unit : constant Node_Id := Unit (Cunit);
7322
7323       begin
7324          if Nkind (The_Unit) /= N_Package_Declaration then
7325             return False;
7326          end if;
7327
7328          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
7329       end Is_RCI_Pkg_Decl_Cunit;
7330
7331    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
7332
7333    begin
7334       return Is_RCI_Pkg_Decl_Cunit (Cunit)
7335         or else
7336          (Nkind (Unit (Cunit)) = N_Package_Body
7337            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
7338    end Is_RCI_Pkg_Spec_Or_Body;
7339
7340    -----------------------------------------
7341    -- Is_Remote_Access_To_Class_Wide_Type --
7342    -----------------------------------------
7343
7344    function Is_Remote_Access_To_Class_Wide_Type
7345      (E : Entity_Id) return Boolean
7346    is
7347    begin
7348       --  A remote access to class-wide type is a general access to object type
7349       --  declared in the visible part of a Remote_Types or Remote_Call_
7350       --  Interface unit.
7351
7352       return Ekind (E) = E_General_Access_Type
7353         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7354    end Is_Remote_Access_To_Class_Wide_Type;
7355
7356    -----------------------------------------
7357    -- Is_Remote_Access_To_Subprogram_Type --
7358    -----------------------------------------
7359
7360    function Is_Remote_Access_To_Subprogram_Type
7361      (E : Entity_Id) return Boolean
7362    is
7363    begin
7364       return (Ekind (E) = E_Access_Subprogram_Type
7365                 or else (Ekind (E) = E_Record_Type
7366                            and then Present (Corresponding_Remote_Type (E))))
7367         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7368    end Is_Remote_Access_To_Subprogram_Type;
7369
7370    --------------------
7371    -- Is_Remote_Call --
7372    --------------------
7373
7374    function Is_Remote_Call (N : Node_Id) return Boolean is
7375    begin
7376       if Nkind (N) /= N_Procedure_Call_Statement
7377         and then Nkind (N) /= N_Function_Call
7378       then
7379          --  An entry call cannot be remote
7380
7381          return False;
7382
7383       elsif Nkind (Name (N)) in N_Has_Entity
7384         and then Is_Remote_Call_Interface (Entity (Name (N)))
7385       then
7386          --  A subprogram declared in the spec of a RCI package is remote
7387
7388          return True;
7389
7390       elsif Nkind (Name (N)) = N_Explicit_Dereference
7391         and then Is_Remote_Access_To_Subprogram_Type
7392                    (Etype (Prefix (Name (N))))
7393       then
7394          --  The dereference of a RAS is a remote call
7395
7396          return True;
7397
7398       elsif Present (Controlling_Argument (N))
7399         and then Is_Remote_Access_To_Class_Wide_Type
7400           (Etype (Controlling_Argument (N)))
7401       then
7402          --  Any primitive operation call with a controlling argument of
7403          --  a RACW type is a remote call.
7404
7405          return True;
7406       end if;
7407
7408       --  All other calls are local calls
7409
7410       return False;
7411    end Is_Remote_Call;
7412
7413    ----------------------
7414    -- Is_Renamed_Entry --
7415    ----------------------
7416
7417    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
7418       Orig_Node : Node_Id := Empty;
7419       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
7420
7421       function Is_Entry (Nam : Node_Id) return Boolean;
7422       --  Determine whether Nam is an entry. Traverse selectors if there are
7423       --  nested selected components.
7424
7425       --------------
7426       -- Is_Entry --
7427       --------------
7428
7429       function Is_Entry (Nam : Node_Id) return Boolean is
7430       begin
7431          if Nkind (Nam) = N_Selected_Component then
7432             return Is_Entry (Selector_Name (Nam));
7433          end if;
7434
7435          return Ekind (Entity (Nam)) = E_Entry;
7436       end Is_Entry;
7437
7438    --  Start of processing for Is_Renamed_Entry
7439
7440    begin
7441       if Present (Alias (Proc_Nam)) then
7442          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
7443       end if;
7444
7445       --  Look for a rewritten subprogram renaming declaration
7446
7447       if Nkind (Subp_Decl) = N_Subprogram_Declaration
7448         and then Present (Original_Node (Subp_Decl))
7449       then
7450          Orig_Node := Original_Node (Subp_Decl);
7451       end if;
7452
7453       --  The rewritten subprogram is actually an entry
7454
7455       if Present (Orig_Node)
7456         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
7457         and then Is_Entry (Name (Orig_Node))
7458       then
7459          return True;
7460       end if;
7461
7462       return False;
7463    end Is_Renamed_Entry;
7464
7465    ----------------------
7466    -- Is_Selector_Name --
7467    ----------------------
7468
7469    function Is_Selector_Name (N : Node_Id) return Boolean is
7470    begin
7471       if not Is_List_Member (N) then
7472          declare
7473             P : constant Node_Id   := Parent (N);
7474             K : constant Node_Kind := Nkind (P);
7475          begin
7476             return
7477               (K = N_Expanded_Name          or else
7478                K = N_Generic_Association    or else
7479                K = N_Parameter_Association  or else
7480                K = N_Selected_Component)
7481               and then Selector_Name (P) = N;
7482          end;
7483
7484       else
7485          declare
7486             L : constant List_Id := List_Containing (N);
7487             P : constant Node_Id := Parent (L);
7488          begin
7489             return (Nkind (P) = N_Discriminant_Association
7490                      and then Selector_Names (P) = L)
7491               or else
7492                    (Nkind (P) = N_Component_Association
7493                      and then Choices (P) = L);
7494          end;
7495       end if;
7496    end Is_Selector_Name;
7497
7498    ----------------------------------
7499    -- Is_SPARK_Initialization_Expr --
7500    ----------------------------------
7501
7502    function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
7503       Is_Ok     : Boolean;
7504       Expr      : Node_Id;
7505       Comp_Assn : Node_Id;
7506       Orig_N    : constant Node_Id := Original_Node (N);
7507
7508    begin
7509       Is_Ok := True;
7510
7511       if not Comes_From_Source (Orig_N) then
7512          goto Done;
7513       end if;
7514
7515       pragma Assert (Nkind (Orig_N) in N_Subexpr);
7516
7517       case Nkind (Orig_N) is
7518          when N_Character_Literal |
7519               N_Integer_Literal   |
7520               N_Real_Literal      |
7521               N_String_Literal    =>
7522             null;
7523
7524          when N_Identifier    |
7525               N_Expanded_Name =>
7526             if Is_Entity_Name (Orig_N)
7527               and then Present (Entity (Orig_N))  --  needed in some cases
7528             then
7529                case Ekind (Entity (Orig_N)) is
7530                   when E_Constant            |
7531                        E_Enumeration_Literal |
7532                        E_Named_Integer       |
7533                        E_Named_Real          =>
7534                      null;
7535                   when others =>
7536                      if Is_Type (Entity (Orig_N)) then
7537                         null;
7538                      else
7539                         Is_Ok := False;
7540                      end if;
7541                end case;
7542             end if;
7543
7544          when N_Qualified_Expression |
7545               N_Type_Conversion      =>
7546             Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
7547
7548          when N_Unary_Op =>
7549             Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
7550
7551          when N_Binary_Op       |
7552               N_Short_Circuit   |
7553               N_Membership_Test =>
7554             Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
7555               and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
7556
7557          when N_Aggregate           |
7558               N_Extension_Aggregate =>
7559             if Nkind (Orig_N) = N_Extension_Aggregate then
7560                Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
7561             end if;
7562
7563             Expr := First (Expressions (Orig_N));
7564             while Present (Expr) loop
7565                if not Is_SPARK_Initialization_Expr (Expr) then
7566                   Is_Ok := False;
7567                   goto Done;
7568                end if;
7569
7570                Next (Expr);
7571             end loop;
7572
7573             Comp_Assn := First (Component_Associations (Orig_N));
7574             while Present (Comp_Assn) loop
7575                Expr := Expression (Comp_Assn);
7576                if Present (Expr)  --  needed for box association
7577                  and then not Is_SPARK_Initialization_Expr (Expr)
7578                then
7579                   Is_Ok := False;
7580                   goto Done;
7581                end if;
7582
7583                Next (Comp_Assn);
7584             end loop;
7585
7586          when N_Attribute_Reference =>
7587             if Nkind (Prefix (Orig_N)) in N_Subexpr then
7588                Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
7589             end if;
7590
7591             Expr := First (Expressions (Orig_N));
7592             while Present (Expr) loop
7593                if not Is_SPARK_Initialization_Expr (Expr) then
7594                   Is_Ok := False;
7595                   goto Done;
7596                end if;
7597
7598                Next (Expr);
7599             end loop;
7600
7601          --  Selected components might be expanded named not yet resolved, so
7602          --  default on the safe side. (Eg on sparklex.ads)
7603
7604          when N_Selected_Component =>
7605             null;
7606
7607          when others =>
7608             Is_Ok := False;
7609       end case;
7610
7611    <<Done>>
7612       return Is_Ok;
7613    end Is_SPARK_Initialization_Expr;
7614
7615    -------------------------------
7616    -- Is_SPARK_Object_Reference --
7617    -------------------------------
7618
7619    function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
7620    begin
7621       if Is_Entity_Name (N) then
7622          return Present (Entity (N))
7623            and then
7624              (Ekind_In (Entity (N), E_Constant, E_Variable)
7625               or else Ekind (Entity (N)) in Formal_Kind);
7626
7627       else
7628          case Nkind (N) is
7629             when N_Selected_Component =>
7630                return Is_SPARK_Object_Reference (Prefix (N));
7631
7632             when others =>
7633                return False;
7634          end case;
7635       end if;
7636    end Is_SPARK_Object_Reference;
7637
7638    ------------------
7639    -- Is_Statement --
7640    ------------------
7641
7642    function Is_Statement (N : Node_Id) return Boolean is
7643    begin
7644       return
7645         Nkind (N) in N_Statement_Other_Than_Procedure_Call
7646           or else Nkind (N) = N_Procedure_Call_Statement;
7647    end Is_Statement;
7648
7649    ---------------------------------
7650    -- Is_Synchronized_Tagged_Type --
7651    ---------------------------------
7652
7653    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
7654       Kind : constant Entity_Kind := Ekind (Base_Type (E));
7655
7656    begin
7657       --  A task or protected type derived from an interface is a tagged type.
7658       --  Such a tagged type is called a synchronized tagged type, as are
7659       --  synchronized interfaces and private extensions whose declaration
7660       --  includes the reserved word synchronized.
7661
7662       return (Is_Tagged_Type (E)
7663                 and then (Kind = E_Task_Type
7664                            or else Kind = E_Protected_Type))
7665             or else
7666              (Is_Interface (E)
7667                 and then Is_Synchronized_Interface (E))
7668             or else
7669              (Ekind (E) = E_Record_Type_With_Private
7670                 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
7671                 and then (Synchronized_Present (Parent (E))
7672                            or else Is_Synchronized_Interface (Etype (E))));
7673    end Is_Synchronized_Tagged_Type;
7674
7675    -----------------
7676    -- Is_Transfer --
7677    -----------------
7678
7679    function Is_Transfer (N : Node_Id) return Boolean is
7680       Kind : constant Node_Kind := Nkind (N);
7681
7682    begin
7683       if Kind = N_Simple_Return_Statement
7684            or else
7685          Kind = N_Extended_Return_Statement
7686            or else
7687          Kind = N_Goto_Statement
7688            or else
7689          Kind = N_Raise_Statement
7690            or else
7691          Kind = N_Requeue_Statement
7692       then
7693          return True;
7694
7695       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
7696         and then No (Condition (N))
7697       then
7698          return True;
7699
7700       elsif Kind = N_Procedure_Call_Statement
7701         and then Is_Entity_Name (Name (N))
7702         and then Present (Entity (Name (N)))
7703         and then No_Return (Entity (Name (N)))
7704       then
7705          return True;
7706
7707       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
7708          return True;
7709
7710       else
7711          return False;
7712       end if;
7713    end Is_Transfer;
7714
7715    -------------
7716    -- Is_True --
7717    -------------
7718
7719    function Is_True (U : Uint) return Boolean is
7720    begin
7721       return (U /= 0);
7722    end Is_True;
7723
7724    -------------------------------
7725    -- Is_Universal_Numeric_Type --
7726    -------------------------------
7727
7728    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
7729    begin
7730       return T = Universal_Integer or else T = Universal_Real;
7731    end Is_Universal_Numeric_Type;
7732
7733    -------------------
7734    -- Is_Value_Type --
7735    -------------------
7736
7737    function Is_Value_Type (T : Entity_Id) return Boolean is
7738    begin
7739       return VM_Target = CLI_Target
7740         and then Nkind (T) in N_Has_Chars
7741         and then Chars (T) /= No_Name
7742         and then Get_Name_String (Chars (T)) = "valuetype";
7743    end Is_Value_Type;
7744
7745    ---------------------
7746    -- Is_VMS_Operator --
7747    ---------------------
7748
7749    function Is_VMS_Operator (Op : Entity_Id) return Boolean is
7750    begin
7751       --  The VMS operators are declared in a child of System that is loaded
7752       --  through pragma Extend_System. In some rare cases a program is run
7753       --  with this extension but without indicating that the target is VMS.
7754
7755       return Ekind (Op) = E_Function
7756         and then Is_Intrinsic_Subprogram (Op)
7757         and then
7758           ((Present_System_Aux
7759             and then Scope (Op) = System_Aux_Id)
7760            or else
7761            (True_VMS_Target
7762              and then Scope (Scope (Op)) = RTU_Entity (System)));
7763    end Is_VMS_Operator;
7764
7765    -----------------
7766    -- Is_Variable --
7767    -----------------
7768
7769    function Is_Variable
7770      (N                 : Node_Id;
7771       Use_Original_Node : Boolean := True) return Boolean
7772    is
7773       Orig_Node : Node_Id;
7774
7775       function In_Protected_Function (E : Entity_Id) return Boolean;
7776       --  Within a protected function, the private components of the enclosing
7777       --  protected type are constants. A function nested within a (protected)
7778       --  procedure is not itself protected.
7779
7780       function Is_Variable_Prefix (P : Node_Id) return Boolean;
7781       --  Prefixes can involve implicit dereferences, in which case we must
7782       --  test for the case of a reference of a constant access type, which can
7783       --  can never be a variable.
7784
7785       ---------------------------
7786       -- In_Protected_Function --
7787       ---------------------------
7788
7789       function In_Protected_Function (E : Entity_Id) return Boolean is
7790          Prot : constant Entity_Id := Scope (E);
7791          S    : Entity_Id;
7792
7793       begin
7794          if not Is_Protected_Type (Prot) then
7795             return False;
7796          else
7797             S := Current_Scope;
7798             while Present (S) and then S /= Prot loop
7799                if Ekind (S) = E_Function and then Scope (S) = Prot then
7800                   return True;
7801                end if;
7802
7803                S := Scope (S);
7804             end loop;
7805
7806             return False;
7807          end if;
7808       end In_Protected_Function;
7809
7810       ------------------------
7811       -- Is_Variable_Prefix --
7812       ------------------------
7813
7814       function Is_Variable_Prefix (P : Node_Id) return Boolean is
7815       begin
7816          if Is_Access_Type (Etype (P)) then
7817             return not Is_Access_Constant (Root_Type (Etype (P)));
7818
7819          --  For the case of an indexed component whose prefix has a packed
7820          --  array type, the prefix has been rewritten into a type conversion.
7821          --  Determine variable-ness from the converted expression.
7822
7823          elsif Nkind (P) = N_Type_Conversion
7824            and then not Comes_From_Source (P)
7825            and then Is_Array_Type (Etype (P))
7826            and then Is_Packed (Etype (P))
7827          then
7828             return Is_Variable (Expression (P));
7829
7830          else
7831             return Is_Variable (P);
7832          end if;
7833       end Is_Variable_Prefix;
7834
7835    --  Start of processing for Is_Variable
7836
7837    begin
7838       --  Check if we perform the test on the original node since this may be a
7839       --  test of syntactic categories which must not be disturbed by whatever
7840       --  rewriting might have occurred. For example, an aggregate, which is
7841       --  certainly NOT a variable, could be turned into a variable by
7842       --  expansion.
7843
7844       if Use_Original_Node then
7845          Orig_Node := Original_Node (N);
7846       else
7847          Orig_Node := N;
7848       end if;
7849
7850       --  Definitely OK if Assignment_OK is set. Since this is something that
7851       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
7852
7853       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
7854          return True;
7855
7856       --  Normally we go to the original node, but there is one exception where
7857       --  we use the rewritten node, namely when it is an explicit dereference.
7858       --  The generated code may rewrite a prefix which is an access type with
7859       --  an explicit dereference. The dereference is a variable, even though
7860       --  the original node may not be (since it could be a constant of the
7861       --  access type).
7862
7863       --  In Ada 2005 we have a further case to consider: the prefix may be a
7864       --  function call given in prefix notation. The original node appears to
7865       --  be a selected component, but we need to examine the call.
7866
7867       elsif Nkind (N) = N_Explicit_Dereference
7868         and then Nkind (Orig_Node) /= N_Explicit_Dereference
7869         and then Present (Etype (Orig_Node))
7870         and then Is_Access_Type (Etype (Orig_Node))
7871       then
7872          --  Note that if the prefix is an explicit dereference that does not
7873          --  come from source, we must check for a rewritten function call in
7874          --  prefixed notation before other forms of rewriting, to prevent a
7875          --  compiler crash.
7876
7877          return
7878            (Nkind (Orig_Node) = N_Function_Call
7879              and then not Is_Access_Constant (Etype (Prefix (N))))
7880            or else
7881              Is_Variable_Prefix (Original_Node (Prefix (N)));
7882
7883       --  A function call is never a variable
7884
7885       elsif Nkind (N) = N_Function_Call then
7886          return False;
7887
7888       --  All remaining checks use the original node
7889
7890       elsif Is_Entity_Name (Orig_Node)
7891         and then Present (Entity (Orig_Node))
7892       then
7893          declare
7894             E : constant Entity_Id := Entity (Orig_Node);
7895             K : constant Entity_Kind := Ekind (E);
7896
7897          begin
7898             return (K = E_Variable
7899                       and then Nkind (Parent (E)) /= N_Exception_Handler)
7900               or else  (K = E_Component
7901                           and then not In_Protected_Function (E))
7902               or else  K = E_Out_Parameter
7903               or else  K = E_In_Out_Parameter
7904               or else  K = E_Generic_In_Out_Parameter
7905
7906                --  Current instance of type:
7907
7908               or else (Is_Type (E) and then In_Open_Scopes (E))
7909               or else (Is_Incomplete_Or_Private_Type (E)
7910                         and then In_Open_Scopes (Full_View (E)));
7911          end;
7912
7913       else
7914          case Nkind (Orig_Node) is
7915             when N_Indexed_Component | N_Slice =>
7916                return Is_Variable_Prefix (Prefix (Orig_Node));
7917
7918             when N_Selected_Component =>
7919                return Is_Variable_Prefix (Prefix (Orig_Node))
7920                  and then Is_Variable (Selector_Name (Orig_Node));
7921
7922             --  For an explicit dereference, the type of the prefix cannot
7923             --  be an access to constant or an access to subprogram.
7924
7925             when N_Explicit_Dereference =>
7926                declare
7927                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
7928                begin
7929                   return Is_Access_Type (Typ)
7930                     and then not Is_Access_Constant (Root_Type (Typ))
7931                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
7932                end;
7933
7934             --  The type conversion is the case where we do not deal with the
7935             --  context dependent special case of an actual parameter. Thus
7936             --  the type conversion is only considered a variable for the
7937             --  purposes of this routine if the target type is tagged. However,
7938             --  a type conversion is considered to be a variable if it does not
7939             --  come from source (this deals for example with the conversions
7940             --  of expressions to their actual subtypes).
7941
7942             when N_Type_Conversion =>
7943                return Is_Variable (Expression (Orig_Node))
7944                  and then
7945                    (not Comes_From_Source (Orig_Node)
7946                       or else
7947                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
7948                           and then
7949                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
7950
7951             --  GNAT allows an unchecked type conversion as a variable. This
7952             --  only affects the generation of internal expanded code, since
7953             --  calls to instantiations of Unchecked_Conversion are never
7954             --  considered variables (since they are function calls).
7955             --  This is also true for expression actions.
7956
7957             when N_Unchecked_Type_Conversion =>
7958                return Is_Variable (Expression (Orig_Node));
7959
7960             when others =>
7961                return False;
7962          end case;
7963       end if;
7964    end Is_Variable;
7965
7966    ---------------------------
7967    -- Is_Visibly_Controlled --
7968    ---------------------------
7969
7970    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
7971       Root : constant Entity_Id := Root_Type (T);
7972    begin
7973       return Chars (Scope (Root)) = Name_Finalization
7974         and then Chars (Scope (Scope (Root))) = Name_Ada
7975         and then Scope (Scope (Scope (Root))) = Standard_Standard;
7976    end Is_Visibly_Controlled;
7977
7978    ------------------------
7979    -- Is_Volatile_Object --
7980    ------------------------
7981
7982    function Is_Volatile_Object (N : Node_Id) return Boolean is
7983
7984       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
7985       --  Determines if given object has volatile components
7986
7987       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
7988       --  If prefix is an implicit dereference, examine designated type
7989
7990       ------------------------
7991       -- Is_Volatile_Prefix --
7992       ------------------------
7993
7994       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
7995          Typ  : constant Entity_Id := Etype (N);
7996
7997       begin
7998          if Is_Access_Type (Typ) then
7999             declare
8000                Dtyp : constant Entity_Id := Designated_Type (Typ);
8001
8002             begin
8003                return Is_Volatile (Dtyp)
8004                  or else Has_Volatile_Components (Dtyp);
8005             end;
8006
8007          else
8008             return Object_Has_Volatile_Components (N);
8009          end if;
8010       end Is_Volatile_Prefix;
8011
8012       ------------------------------------
8013       -- Object_Has_Volatile_Components --
8014       ------------------------------------
8015
8016       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
8017          Typ : constant Entity_Id := Etype (N);
8018
8019       begin
8020          if Is_Volatile (Typ)
8021            or else Has_Volatile_Components (Typ)
8022          then
8023             return True;
8024
8025          elsif Is_Entity_Name (N)
8026            and then (Has_Volatile_Components (Entity (N))
8027                       or else Is_Volatile (Entity (N)))
8028          then
8029             return True;
8030
8031          elsif Nkind (N) = N_Indexed_Component
8032            or else Nkind (N) = N_Selected_Component
8033          then
8034             return Is_Volatile_Prefix (Prefix (N));
8035
8036          else
8037             return False;
8038          end if;
8039       end Object_Has_Volatile_Components;
8040
8041    --  Start of processing for Is_Volatile_Object
8042
8043    begin
8044       if Is_Volatile (Etype (N))
8045         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
8046       then
8047          return True;
8048
8049       elsif Nkind (N) = N_Indexed_Component
8050         or else Nkind (N) = N_Selected_Component
8051       then
8052          return Is_Volatile_Prefix (Prefix (N));
8053
8054       else
8055          return False;
8056       end if;
8057    end Is_Volatile_Object;
8058
8059    -------------------------
8060    -- Kill_Current_Values --
8061    -------------------------
8062
8063    procedure Kill_Current_Values
8064      (Ent                  : Entity_Id;
8065       Last_Assignment_Only : Boolean := False)
8066    is
8067    begin
8068       --  ??? do we have to worry about clearing cached checks?
8069
8070       if Is_Assignable (Ent) then
8071          Set_Last_Assignment (Ent, Empty);
8072       end if;
8073
8074       if Is_Object (Ent) then
8075          if not Last_Assignment_Only then
8076             Kill_Checks (Ent);
8077             Set_Current_Value (Ent, Empty);
8078
8079             if not Can_Never_Be_Null (Ent) then
8080                Set_Is_Known_Non_Null (Ent, False);
8081             end if;
8082
8083             Set_Is_Known_Null (Ent, False);
8084
8085             --  Reset Is_Known_Valid unless type is always valid, or if we have
8086             --  a loop parameter (loop parameters are always valid, since their
8087             --  bounds are defined by the bounds given in the loop header).
8088
8089             if not Is_Known_Valid (Etype (Ent))
8090               and then Ekind (Ent) /= E_Loop_Parameter
8091             then
8092                Set_Is_Known_Valid (Ent, False);
8093             end if;
8094          end if;
8095       end if;
8096    end Kill_Current_Values;
8097
8098    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
8099       S : Entity_Id;
8100
8101       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
8102       --  Clear current value for entity E and all entities chained to E
8103
8104       ------------------------------------------
8105       -- Kill_Current_Values_For_Entity_Chain --
8106       ------------------------------------------
8107
8108       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
8109          Ent : Entity_Id;
8110       begin
8111          Ent := E;
8112          while Present (Ent) loop
8113             Kill_Current_Values (Ent, Last_Assignment_Only);
8114             Next_Entity (Ent);
8115          end loop;
8116       end Kill_Current_Values_For_Entity_Chain;
8117
8118    --  Start of processing for Kill_Current_Values
8119
8120    begin
8121       --  Kill all saved checks, a special case of killing saved values
8122
8123       if not Last_Assignment_Only then
8124          Kill_All_Checks;
8125       end if;
8126
8127       --  Loop through relevant scopes, which includes the current scope and
8128       --  any parent scopes if the current scope is a block or a package.
8129
8130       S := Current_Scope;
8131       Scope_Loop : loop
8132
8133          --  Clear current values of all entities in current scope
8134
8135          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
8136
8137          --  If scope is a package, also clear current values of all
8138          --  private entities in the scope.
8139
8140          if Is_Package_Or_Generic_Package (S)
8141            or else Is_Concurrent_Type (S)
8142          then
8143             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
8144          end if;
8145
8146          --  If this is a not a subprogram, deal with parents
8147
8148          if not Is_Subprogram (S) then
8149             S := Scope (S);
8150             exit Scope_Loop when S = Standard_Standard;
8151          else
8152             exit Scope_Loop;
8153          end if;
8154       end loop Scope_Loop;
8155    end Kill_Current_Values;
8156
8157    --------------------------
8158    -- Kill_Size_Check_Code --
8159    --------------------------
8160
8161    procedure Kill_Size_Check_Code (E : Entity_Id) is
8162    begin
8163       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8164         and then Present (Size_Check_Code (E))
8165       then
8166          Remove (Size_Check_Code (E));
8167          Set_Size_Check_Code (E, Empty);
8168       end if;
8169    end Kill_Size_Check_Code;
8170
8171    --------------------------
8172    -- Known_To_Be_Assigned --
8173    --------------------------
8174
8175    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
8176       P : constant Node_Id := Parent (N);
8177
8178    begin
8179       case Nkind (P) is
8180
8181          --  Test left side of assignment
8182
8183          when N_Assignment_Statement =>
8184             return N = Name (P);
8185
8186             --  Function call arguments are never lvalues
8187
8188          when N_Function_Call =>
8189             return False;
8190
8191          --  Positional parameter for procedure or accept call
8192
8193          when N_Procedure_Call_Statement |
8194               N_Accept_Statement
8195           =>
8196             declare
8197                Proc : Entity_Id;
8198                Form : Entity_Id;
8199                Act  : Node_Id;
8200
8201             begin
8202                Proc := Get_Subprogram_Entity (P);
8203
8204                if No (Proc) then
8205                   return False;
8206                end if;
8207
8208                --  If we are not a list member, something is strange, so
8209                --  be conservative and return False.
8210
8211                if not Is_List_Member (N) then
8212                   return False;
8213                end if;
8214
8215                --  We are going to find the right formal by stepping forward
8216                --  through the formals, as we step backwards in the actuals.
8217
8218                Form := First_Formal (Proc);
8219                Act  := N;
8220                loop
8221                   --  If no formal, something is weird, so be conservative
8222                   --  and return False.
8223
8224                   if No (Form) then
8225                      return False;
8226                   end if;
8227
8228                   Prev (Act);
8229                   exit when No (Act);
8230                   Next_Formal (Form);
8231                end loop;
8232
8233                return Ekind (Form) /= E_In_Parameter;
8234             end;
8235
8236          --  Named parameter for procedure or accept call
8237
8238          when N_Parameter_Association =>
8239             declare
8240                Proc : Entity_Id;
8241                Form : Entity_Id;
8242
8243             begin
8244                Proc := Get_Subprogram_Entity (Parent (P));
8245
8246                if No (Proc) then
8247                   return False;
8248                end if;
8249
8250                --  Loop through formals to find the one that matches
8251
8252                Form := First_Formal (Proc);
8253                loop
8254                   --  If no matching formal, that's peculiar, some kind of
8255                   --  previous error, so return False to be conservative.
8256
8257                   if No (Form) then
8258                      return False;
8259                   end if;
8260
8261                   --  Else test for match
8262
8263                   if Chars (Form) = Chars (Selector_Name (P)) then
8264                      return Ekind (Form) /= E_In_Parameter;
8265                   end if;
8266
8267                   Next_Formal (Form);
8268                end loop;
8269             end;
8270
8271          --  Test for appearing in a conversion that itself appears
8272          --  in an lvalue context, since this should be an lvalue.
8273
8274          when N_Type_Conversion =>
8275             return Known_To_Be_Assigned (P);
8276
8277          --  All other references are definitely not known to be modifications
8278
8279          when others =>
8280             return False;
8281
8282       end case;
8283    end Known_To_Be_Assigned;
8284
8285    ---------------------------
8286    -- Last_Source_Statement --
8287    ---------------------------
8288
8289    function Last_Source_Statement (HSS : Node_Id) return Node_Id is
8290       N : Node_Id;
8291
8292    begin
8293       N := Last (Statements (HSS));
8294       while Present (N) loop
8295          exit when Comes_From_Source (N);
8296          Prev (N);
8297       end loop;
8298
8299       return N;
8300    end Last_Source_Statement;
8301
8302    ----------------------------------
8303    -- Matching_Static_Array_Bounds --
8304    ----------------------------------
8305
8306    function Matching_Static_Array_Bounds
8307      (L_Typ : Node_Id;
8308       R_Typ : Node_Id) return Boolean
8309    is
8310       L_Ndims : constant Nat := Number_Dimensions (L_Typ);
8311       R_Ndims : constant Nat := Number_Dimensions (R_Typ);
8312
8313       L_Index : Node_Id;
8314       R_Index : Node_Id;
8315       L_Low   : Node_Id;
8316       L_High  : Node_Id;
8317       L_Len   : Uint;
8318       R_Low   : Node_Id;
8319       R_High  : Node_Id;
8320       R_Len   : Uint;
8321
8322    begin
8323       if L_Ndims /= R_Ndims then
8324          return False;
8325       end if;
8326
8327       --  Unconstrained types do not have static bounds
8328
8329       if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
8330          return False;
8331       end if;
8332
8333       --  First treat specially the first dimension, as the lower bound and
8334       --  length of string literals are not stored like those of arrays.
8335
8336       if Ekind (L_Typ) = E_String_Literal_Subtype then
8337          L_Low := String_Literal_Low_Bound (L_Typ);
8338          L_Len := String_Literal_Length (L_Typ);
8339       else
8340          L_Index := First_Index (L_Typ);
8341          Get_Index_Bounds (L_Index, L_Low, L_High);
8342
8343          if         Is_OK_Static_Expression (L_Low)
8344            and then Is_OK_Static_Expression (L_High)
8345          then
8346             if Expr_Value (L_High) < Expr_Value (L_Low) then
8347                L_Len := Uint_0;
8348             else
8349                L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
8350             end if;
8351          else
8352             return False;
8353          end if;
8354       end if;
8355
8356       if Ekind (R_Typ) = E_String_Literal_Subtype then
8357          R_Low := String_Literal_Low_Bound (R_Typ);
8358          R_Len := String_Literal_Length (R_Typ);
8359       else
8360          R_Index := First_Index (R_Typ);
8361          Get_Index_Bounds (R_Index, R_Low, R_High);
8362
8363          if         Is_OK_Static_Expression (R_Low)
8364            and then Is_OK_Static_Expression (R_High)
8365          then
8366             if Expr_Value (R_High) < Expr_Value (R_Low) then
8367                R_Len := Uint_0;
8368             else
8369                R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
8370             end if;
8371          else
8372             return False;
8373          end if;
8374       end if;
8375
8376       if         Is_OK_Static_Expression (L_Low)
8377         and then Is_OK_Static_Expression (R_Low)
8378         and then Expr_Value (L_Low) = Expr_Value (R_Low)
8379         and then L_Len = R_Len
8380       then
8381          null;
8382       else
8383          return False;
8384       end if;
8385
8386       --  Then treat all other dimensions
8387
8388       for Indx in 2 .. L_Ndims loop
8389          Next (L_Index);
8390          Next (R_Index);
8391
8392          Get_Index_Bounds (L_Index, L_Low, L_High);
8393          Get_Index_Bounds (R_Index, R_Low, R_High);
8394
8395          if         Is_OK_Static_Expression (L_Low)
8396            and then Is_OK_Static_Expression (L_High)
8397            and then Is_OK_Static_Expression (R_Low)
8398            and then Is_OK_Static_Expression (R_High)
8399            and then Expr_Value (L_Low)  = Expr_Value (R_Low)
8400            and then Expr_Value (L_High) = Expr_Value (R_High)
8401          then
8402             null;
8403          else
8404             return False;
8405          end if;
8406       end loop;
8407
8408       --  If we fall through the loop, all indexes matched
8409
8410       return True;
8411    end Matching_Static_Array_Bounds;
8412
8413    -------------------
8414    -- May_Be_Lvalue --
8415    -------------------
8416
8417    function May_Be_Lvalue (N : Node_Id) return Boolean is
8418       P : constant Node_Id := Parent (N);
8419
8420    begin
8421       case Nkind (P) is
8422
8423          --  Test left side of assignment
8424
8425          when N_Assignment_Statement =>
8426             return N = Name (P);
8427
8428          --  Test prefix of component or attribute. Note that the prefix of an
8429          --  explicit or implicit dereference cannot be an l-value.
8430
8431          when N_Attribute_Reference =>
8432             return N = Prefix (P)
8433               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
8434
8435          --  For an expanded name, the name is an lvalue if the expanded name
8436          --  is an lvalue, but the prefix is never an lvalue, since it is just
8437          --  the scope where the name is found.
8438
8439          when N_Expanded_Name        =>
8440             if N = Prefix (P) then
8441                return May_Be_Lvalue (P);
8442             else
8443                return False;
8444             end if;
8445
8446          --  For a selected component A.B, A is certainly an lvalue if A.B is.
8447          --  B is a little interesting, if we have A.B := 3, there is some
8448          --  discussion as to whether B is an lvalue or not, we choose to say
8449          --  it is. Note however that A is not an lvalue if it is of an access
8450          --  type since this is an implicit dereference.
8451
8452          when N_Selected_Component   =>
8453             if N = Prefix (P)
8454               and then Present (Etype (N))
8455               and then Is_Access_Type (Etype (N))
8456             then
8457                return False;
8458             else
8459                return May_Be_Lvalue (P);
8460             end if;
8461
8462          --  For an indexed component or slice, the index or slice bounds is
8463          --  never an lvalue. The prefix is an lvalue if the indexed component
8464          --  or slice is an lvalue, except if it is an access type, where we
8465          --  have an implicit dereference.
8466
8467          when N_Indexed_Component    =>
8468             if N /= Prefix (P)
8469               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
8470             then
8471                return False;
8472             else
8473                return May_Be_Lvalue (P);
8474             end if;
8475
8476          --  Prefix of a reference is an lvalue if the reference is an lvalue
8477
8478          when N_Reference            =>
8479             return May_Be_Lvalue (P);
8480
8481          --  Prefix of explicit dereference is never an lvalue
8482
8483          when N_Explicit_Dereference =>
8484             return False;
8485
8486          --  Positional parameter for subprogram, entry, or accept call.
8487          --  In older versions of Ada function call arguments are never
8488          --  lvalues. In Ada 2012 functions can have in-out parameters.
8489
8490          when N_Function_Call            |
8491               N_Procedure_Call_Statement |
8492               N_Entry_Call_Statement     |
8493               N_Accept_Statement
8494          =>
8495             if Nkind (P) = N_Function_Call
8496               and then Ada_Version < Ada_2012
8497             then
8498                return False;
8499             end if;
8500
8501             --  The following mechanism is clumsy and fragile. A single
8502             --  flag set in Resolve_Actuals would be preferable ???
8503
8504             declare
8505                Proc : Entity_Id;
8506                Form : Entity_Id;
8507                Act  : Node_Id;
8508
8509             begin
8510                Proc := Get_Subprogram_Entity (P);
8511
8512                if No (Proc) then
8513                   return True;
8514                end if;
8515
8516                --  If we are not a list member, something is strange, so
8517                --  be conservative and return True.
8518
8519                if not Is_List_Member (N) then
8520                   return True;
8521                end if;
8522
8523                --  We are going to find the right formal by stepping forward
8524                --  through the formals, as we step backwards in the actuals.
8525
8526                Form := First_Formal (Proc);
8527                Act  := N;
8528                loop
8529                   --  If no formal, something is weird, so be conservative
8530                   --  and return True.
8531
8532                   if No (Form) then
8533                      return True;
8534                   end if;
8535
8536                   Prev (Act);
8537                   exit when No (Act);
8538                   Next_Formal (Form);
8539                end loop;
8540
8541                return Ekind (Form) /= E_In_Parameter;
8542             end;
8543
8544          --  Named parameter for procedure or accept call
8545
8546          when N_Parameter_Association =>
8547             declare
8548                Proc : Entity_Id;
8549                Form : Entity_Id;
8550
8551             begin
8552                Proc := Get_Subprogram_Entity (Parent (P));
8553
8554                if No (Proc) then
8555                   return True;
8556                end if;
8557
8558                --  Loop through formals to find the one that matches
8559
8560                Form := First_Formal (Proc);
8561                loop
8562                   --  If no matching formal, that's peculiar, some kind of
8563                   --  previous error, so return True to be conservative.
8564
8565                   if No (Form) then
8566                      return True;
8567                   end if;
8568
8569                   --  Else test for match
8570
8571                   if Chars (Form) = Chars (Selector_Name (P)) then
8572                      return Ekind (Form) /= E_In_Parameter;
8573                   end if;
8574
8575                   Next_Formal (Form);
8576                end loop;
8577             end;
8578
8579          --  Test for appearing in a conversion that itself appears in an
8580          --  lvalue context, since this should be an lvalue.
8581
8582          when N_Type_Conversion =>
8583             return May_Be_Lvalue (P);
8584
8585          --  Test for appearance in object renaming declaration
8586
8587          when N_Object_Renaming_Declaration =>
8588             return True;
8589
8590          --  All other references are definitely not lvalues
8591
8592          when others =>
8593             return False;
8594
8595       end case;
8596    end May_Be_Lvalue;
8597
8598    -----------------------
8599    -- Mark_Coextensions --
8600    -----------------------
8601
8602    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
8603       Is_Dynamic : Boolean;
8604       --  Indicates whether the context causes nested coextensions to be
8605       --  dynamic or static
8606
8607       function Mark_Allocator (N : Node_Id) return Traverse_Result;
8608       --  Recognize an allocator node and label it as a dynamic coextension
8609
8610       --------------------
8611       -- Mark_Allocator --
8612       --------------------
8613
8614       function Mark_Allocator (N : Node_Id) return Traverse_Result is
8615       begin
8616          if Nkind (N) = N_Allocator then
8617             if Is_Dynamic then
8618                Set_Is_Dynamic_Coextension (N);
8619
8620             --  If the allocator expression is potentially dynamic, it may
8621             --  be expanded out of order and require dynamic allocation
8622             --  anyway, so we treat the coextension itself as dynamic.
8623             --  Potential optimization ???
8624
8625             elsif Nkind (Expression (N)) = N_Qualified_Expression
8626               and then Nkind (Expression (Expression (N))) = N_Op_Concat
8627             then
8628                Set_Is_Dynamic_Coextension (N);
8629
8630             else
8631                Set_Is_Static_Coextension (N);
8632             end if;
8633          end if;
8634
8635          return OK;
8636       end Mark_Allocator;
8637
8638       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
8639
8640    --  Start of processing Mark_Coextensions
8641
8642    begin
8643       case Nkind (Context_Nod) is
8644          when N_Assignment_Statement    |
8645               N_Simple_Return_Statement =>
8646             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
8647
8648          when N_Object_Declaration =>
8649             Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
8650
8651          --  This routine should not be called for constructs which may not
8652          --  contain coextensions.
8653
8654          when others =>
8655             raise Program_Error;
8656       end case;
8657
8658       Mark_Allocators (Root_Nod);
8659    end Mark_Coextensions;
8660
8661    ----------------------
8662    -- Needs_One_Actual --
8663    ----------------------
8664
8665    function Needs_One_Actual (E : Entity_Id) return Boolean is
8666       Formal : Entity_Id;
8667
8668    begin
8669       if Ada_Version >= Ada_2005
8670         and then Present (First_Formal (E))
8671       then
8672          Formal := Next_Formal (First_Formal (E));
8673          while Present (Formal) loop
8674             if No (Default_Value (Formal)) then
8675                return False;
8676             end if;
8677
8678             Next_Formal (Formal);
8679          end loop;
8680
8681          return True;
8682
8683       else
8684          return False;
8685       end if;
8686    end Needs_One_Actual;
8687
8688    ------------------------
8689    -- New_Copy_List_Tree --
8690    ------------------------
8691
8692    function New_Copy_List_Tree (List : List_Id) return List_Id is
8693       NL : List_Id;
8694       E  : Node_Id;
8695
8696    begin
8697       if List = No_List then
8698          return No_List;
8699
8700       else
8701          NL := New_List;
8702          E := First (List);
8703
8704          while Present (E) loop
8705             Append (New_Copy_Tree (E), NL);
8706             E := Next (E);
8707          end loop;
8708
8709          return NL;
8710       end if;
8711    end New_Copy_List_Tree;
8712
8713    -------------------
8714    -- New_Copy_Tree --
8715    -------------------
8716
8717    use Atree.Unchecked_Access;
8718    use Atree_Private_Part;
8719
8720    --  Our approach here requires a two pass traversal of the tree. The
8721    --  first pass visits all nodes that eventually will be copied looking
8722    --  for defining Itypes. If any defining Itypes are found, then they are
8723    --  copied, and an entry is added to the replacement map. In the second
8724    --  phase, the tree is copied, using the replacement map to replace any
8725    --  Itype references within the copied tree.
8726
8727    --  The following hash tables are used if the Map supplied has more
8728    --  than hash threshold entries to speed up access to the map. If
8729    --  there are fewer entries, then the map is searched sequentially
8730    --  (because setting up a hash table for only a few entries takes
8731    --  more time than it saves.
8732
8733    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
8734    --  Hash function used for hash operations
8735
8736    -------------------
8737    -- New_Copy_Hash --
8738    -------------------
8739
8740    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
8741    begin
8742       return Nat (E) mod (NCT_Header_Num'Last + 1);
8743    end New_Copy_Hash;
8744
8745    ---------------
8746    -- NCT_Assoc --
8747    ---------------
8748
8749    --  The hash table NCT_Assoc associates old entities in the table
8750    --  with their corresponding new entities (i.e. the pairs of entries
8751    --  presented in the original Map argument are Key-Element pairs).
8752
8753    package NCT_Assoc is new Simple_HTable (
8754      Header_Num => NCT_Header_Num,
8755      Element    => Entity_Id,
8756      No_Element => Empty,
8757      Key        => Entity_Id,
8758      Hash       => New_Copy_Hash,
8759      Equal      => Types."=");
8760
8761    ---------------------
8762    -- NCT_Itype_Assoc --
8763    ---------------------
8764
8765    --  The hash table NCT_Itype_Assoc contains entries only for those
8766    --  old nodes which have a non-empty Associated_Node_For_Itype set.
8767    --  The key is the associated node, and the element is the new node
8768    --  itself (NOT the associated node for the new node).
8769
8770    package NCT_Itype_Assoc is new Simple_HTable (
8771      Header_Num => NCT_Header_Num,
8772      Element    => Entity_Id,
8773      No_Element => Empty,
8774      Key        => Entity_Id,
8775      Hash       => New_Copy_Hash,
8776      Equal      => Types."=");
8777
8778    --  Start of processing for New_Copy_Tree function
8779
8780    function New_Copy_Tree
8781      (Source    : Node_Id;
8782       Map       : Elist_Id := No_Elist;
8783       New_Sloc  : Source_Ptr := No_Location;
8784       New_Scope : Entity_Id := Empty) return Node_Id
8785    is
8786       Actual_Map : Elist_Id := Map;
8787       --  This is the actual map for the copy. It is initialized with the
8788       --  given elements, and then enlarged as required for Itypes that are
8789       --  copied during the first phase of the copy operation. The visit
8790       --  procedures add elements to this map as Itypes are encountered.
8791       --  The reason we cannot use Map directly, is that it may well be
8792       --  (and normally is) initialized to No_Elist, and if we have mapped
8793       --  entities, we have to reset it to point to a real Elist.
8794
8795       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
8796       --  Called during second phase to map entities into their corresponding
8797       --  copies using Actual_Map. If the argument is not an entity, or is not
8798       --  in Actual_Map, then it is returned unchanged.
8799
8800       procedure Build_NCT_Hash_Tables;
8801       --  Builds hash tables (number of elements >= threshold value)
8802
8803       function Copy_Elist_With_Replacement
8804         (Old_Elist : Elist_Id) return Elist_Id;
8805       --  Called during second phase to copy element list doing replacements
8806
8807       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
8808       --  Called during the second phase to process a copied Itype. The actual
8809       --  copy happened during the first phase (so that we could make the entry
8810       --  in the mapping), but we still have to deal with the descendents of
8811       --  the copied Itype and copy them where necessary.
8812
8813       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
8814       --  Called during second phase to copy list doing replacements
8815
8816       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
8817       --  Called during second phase to copy node doing replacements
8818
8819       procedure Visit_Elist (E : Elist_Id);
8820       --  Called during first phase to visit all elements of an Elist
8821
8822       procedure Visit_Field (F : Union_Id; N : Node_Id);
8823       --  Visit a single field, recursing to call Visit_Node or Visit_List
8824       --  if the field is a syntactic descendent of the current node (i.e.
8825       --  its parent is Node N).
8826
8827       procedure Visit_Itype (Old_Itype : Entity_Id);
8828       --  Called during first phase to visit subsidiary fields of a defining
8829       --  Itype, and also create a copy and make an entry in the replacement
8830       --  map for the new copy.
8831
8832       procedure Visit_List (L : List_Id);
8833       --  Called during first phase to visit all elements of a List
8834
8835       procedure Visit_Node (N : Node_Or_Entity_Id);
8836       --  Called during first phase to visit a node and all its subtrees
8837
8838       -----------
8839       -- Assoc --
8840       -----------
8841
8842       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
8843          E   : Elmt_Id;
8844          Ent : Entity_Id;
8845
8846       begin
8847          if not Has_Extension (N) or else No (Actual_Map) then
8848             return N;
8849
8850          elsif NCT_Hash_Tables_Used then
8851             Ent := NCT_Assoc.Get (Entity_Id (N));
8852
8853             if Present (Ent) then
8854                return Ent;
8855             else
8856                return N;
8857             end if;
8858
8859          --  No hash table used, do serial search
8860
8861          else
8862             E := First_Elmt (Actual_Map);
8863             while Present (E) loop
8864                if Node (E) = N then
8865                   return Node (Next_Elmt (E));
8866                else
8867                   E := Next_Elmt (Next_Elmt (E));
8868                end if;
8869             end loop;
8870          end if;
8871
8872          return N;
8873       end Assoc;
8874
8875       ---------------------------
8876       -- Build_NCT_Hash_Tables --
8877       ---------------------------
8878
8879       procedure Build_NCT_Hash_Tables is
8880          Elmt : Elmt_Id;
8881          Ent  : Entity_Id;
8882       begin
8883          if NCT_Hash_Table_Setup then
8884             NCT_Assoc.Reset;
8885             NCT_Itype_Assoc.Reset;
8886          end if;
8887
8888          Elmt := First_Elmt (Actual_Map);
8889          while Present (Elmt) loop
8890             Ent := Node (Elmt);
8891
8892             --  Get new entity, and associate old and new
8893
8894             Next_Elmt (Elmt);
8895             NCT_Assoc.Set (Ent, Node (Elmt));
8896
8897             if Is_Type (Ent) then
8898                declare
8899                   Anode : constant Entity_Id :=
8900                             Associated_Node_For_Itype (Ent);
8901
8902                begin
8903                   if Present (Anode) then
8904
8905                      --  Enter a link between the associated node of the
8906                      --  old Itype and the new Itype, for updating later
8907                      --  when node is copied.
8908
8909                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
8910                   end if;
8911                end;
8912             end if;
8913
8914             Next_Elmt (Elmt);
8915          end loop;
8916
8917          NCT_Hash_Tables_Used := True;
8918          NCT_Hash_Table_Setup := True;
8919       end Build_NCT_Hash_Tables;
8920
8921       ---------------------------------
8922       -- Copy_Elist_With_Replacement --
8923       ---------------------------------
8924
8925       function Copy_Elist_With_Replacement
8926         (Old_Elist : Elist_Id) return Elist_Id
8927       is
8928          M         : Elmt_Id;
8929          New_Elist : Elist_Id;
8930
8931       begin
8932          if No (Old_Elist) then
8933             return No_Elist;
8934
8935          else
8936             New_Elist := New_Elmt_List;
8937
8938             M := First_Elmt (Old_Elist);
8939             while Present (M) loop
8940                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
8941                Next_Elmt (M);
8942             end loop;
8943          end if;
8944
8945          return New_Elist;
8946       end Copy_Elist_With_Replacement;
8947
8948       ---------------------------------
8949       -- Copy_Itype_With_Replacement --
8950       ---------------------------------
8951
8952       --  This routine exactly parallels its phase one analog Visit_Itype,
8953
8954       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
8955       begin
8956          --  Translate Next_Entity, Scope and Etype fields, in case they
8957          --  reference entities that have been mapped into copies.
8958
8959          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
8960          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
8961
8962          if Present (New_Scope) then
8963             Set_Scope    (New_Itype, New_Scope);
8964          else
8965             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
8966          end if;
8967
8968          --  Copy referenced fields
8969
8970          if Is_Discrete_Type (New_Itype) then
8971             Set_Scalar_Range (New_Itype,
8972               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
8973
8974          elsif Has_Discriminants (Base_Type (New_Itype)) then
8975             Set_Discriminant_Constraint (New_Itype,
8976               Copy_Elist_With_Replacement
8977                 (Discriminant_Constraint (New_Itype)));
8978
8979          elsif Is_Array_Type (New_Itype) then
8980             if Present (First_Index (New_Itype)) then
8981                Set_First_Index (New_Itype,
8982                  First (Copy_List_With_Replacement
8983                          (List_Containing (First_Index (New_Itype)))));
8984             end if;
8985
8986             if Is_Packed (New_Itype) then
8987                Set_Packed_Array_Type (New_Itype,
8988                  Copy_Node_With_Replacement
8989                    (Packed_Array_Type (New_Itype)));
8990             end if;
8991          end if;
8992       end Copy_Itype_With_Replacement;
8993
8994       --------------------------------
8995       -- Copy_List_With_Replacement --
8996       --------------------------------
8997
8998       function Copy_List_With_Replacement
8999         (Old_List : List_Id) return List_Id
9000       is
9001          New_List : List_Id;
9002          E        : Node_Id;
9003
9004       begin
9005          if Old_List = No_List then
9006             return No_List;
9007
9008          else
9009             New_List := Empty_List;
9010
9011             E := First (Old_List);
9012             while Present (E) loop
9013                Append (Copy_Node_With_Replacement (E), New_List);
9014                Next (E);
9015             end loop;
9016
9017             return New_List;
9018          end if;
9019       end Copy_List_With_Replacement;
9020
9021       --------------------------------
9022       -- Copy_Node_With_Replacement --
9023       --------------------------------
9024
9025       function Copy_Node_With_Replacement
9026         (Old_Node : Node_Id) return Node_Id
9027       is
9028          New_Node : Node_Id;
9029
9030          procedure Adjust_Named_Associations
9031            (Old_Node : Node_Id;
9032             New_Node : Node_Id);
9033          --  If a call node has named associations, these are chained through
9034          --  the First_Named_Actual, Next_Named_Actual links. These must be
9035          --  propagated separately to the new parameter list, because these
9036          --  are not syntactic fields.
9037
9038          function Copy_Field_With_Replacement
9039            (Field : Union_Id) return Union_Id;
9040          --  Given Field, which is a field of Old_Node, return a copy of it
9041          --  if it is a syntactic field (i.e. its parent is Node), setting
9042          --  the parent of the copy to poit to New_Node. Otherwise returns
9043          --  the field (possibly mapped if it is an entity).
9044
9045          -------------------------------
9046          -- Adjust_Named_Associations --
9047          -------------------------------
9048
9049          procedure Adjust_Named_Associations
9050            (Old_Node : Node_Id;
9051             New_Node : Node_Id)
9052          is
9053             Old_E : Node_Id;
9054             New_E : Node_Id;
9055
9056             Old_Next : Node_Id;
9057             New_Next : Node_Id;
9058
9059          begin
9060             Old_E := First (Parameter_Associations (Old_Node));
9061             New_E := First (Parameter_Associations (New_Node));
9062             while Present (Old_E) loop
9063                if Nkind (Old_E) = N_Parameter_Association
9064                  and then Present (Next_Named_Actual (Old_E))
9065                then
9066                   if First_Named_Actual (Old_Node)
9067                     =  Explicit_Actual_Parameter (Old_E)
9068                   then
9069                      Set_First_Named_Actual
9070                        (New_Node, Explicit_Actual_Parameter (New_E));
9071                   end if;
9072
9073                   --  Now scan parameter list from the beginning,to locate
9074                   --  next named actual, which can be out of order.
9075
9076                   Old_Next := First (Parameter_Associations (Old_Node));
9077                   New_Next := First (Parameter_Associations (New_Node));
9078
9079                   while Nkind (Old_Next) /= N_Parameter_Association
9080                     or else  Explicit_Actual_Parameter (Old_Next)
9081                       /= Next_Named_Actual (Old_E)
9082                   loop
9083                      Next (Old_Next);
9084                      Next (New_Next);
9085                   end loop;
9086
9087                   Set_Next_Named_Actual
9088                     (New_E, Explicit_Actual_Parameter (New_Next));
9089                end if;
9090
9091                Next (Old_E);
9092                Next (New_E);
9093             end loop;
9094          end Adjust_Named_Associations;
9095
9096          ---------------------------------
9097          -- Copy_Field_With_Replacement --
9098          ---------------------------------
9099
9100          function Copy_Field_With_Replacement
9101            (Field : Union_Id) return Union_Id
9102          is
9103          begin
9104             if Field = Union_Id (Empty) then
9105                return Field;
9106
9107             elsif Field in Node_Range then
9108                declare
9109                   Old_N : constant Node_Id := Node_Id (Field);
9110                   New_N : Node_Id;
9111
9112                begin
9113                   --  If syntactic field, as indicated by the parent pointer
9114                   --  being set, then copy the referenced node recursively.
9115
9116                   if Parent (Old_N) = Old_Node then
9117                      New_N := Copy_Node_With_Replacement (Old_N);
9118
9119                      if New_N /= Old_N then
9120                         Set_Parent (New_N, New_Node);
9121                      end if;
9122
9123                   --  For semantic fields, update possible entity reference
9124                   --  from the replacement map.
9125
9126                   else
9127                      New_N := Assoc (Old_N);
9128                   end if;
9129
9130                   return Union_Id (New_N);
9131                end;
9132
9133             elsif Field in List_Range then
9134                declare
9135                   Old_L : constant List_Id := List_Id (Field);
9136                   New_L : List_Id;
9137
9138                begin
9139                   --  If syntactic field, as indicated by the parent pointer,
9140                   --  then recursively copy the entire referenced list.
9141
9142                   if Parent (Old_L) = Old_Node then
9143                      New_L := Copy_List_With_Replacement (Old_L);
9144                      Set_Parent (New_L, New_Node);
9145
9146                   --  For semantic list, just returned unchanged
9147
9148                   else
9149                      New_L := Old_L;
9150                   end if;
9151
9152                   return Union_Id (New_L);
9153                end;
9154
9155             --  Anything other than a list or a node is returned unchanged
9156
9157             else
9158                return Field;
9159             end if;
9160          end Copy_Field_With_Replacement;
9161
9162       --  Start of processing for Copy_Node_With_Replacement
9163
9164       begin
9165          if Old_Node <= Empty_Or_Error then
9166             return Old_Node;
9167
9168          elsif Has_Extension (Old_Node) then
9169             return Assoc (Old_Node);
9170
9171          else
9172             New_Node := New_Copy (Old_Node);
9173
9174             --  If the node we are copying is the associated node of a
9175             --  previously copied Itype, then adjust the associated node
9176             --  of the copy of that Itype accordingly.
9177
9178             if Present (Actual_Map) then
9179                declare
9180                   E   : Elmt_Id;
9181                   Ent : Entity_Id;
9182
9183                begin
9184                   --  Case of hash table used
9185
9186                   if NCT_Hash_Tables_Used then
9187                      Ent := NCT_Itype_Assoc.Get (Old_Node);
9188
9189                      if Present (Ent) then
9190                         Set_Associated_Node_For_Itype (Ent, New_Node);
9191                      end if;
9192
9193                   --  Case of no hash table used
9194
9195                   else
9196                      E := First_Elmt (Actual_Map);
9197                      while Present (E) loop
9198                         if Is_Itype (Node (E))
9199                           and then
9200                             Old_Node = Associated_Node_For_Itype (Node (E))
9201                         then
9202                            Set_Associated_Node_For_Itype
9203                              (Node (Next_Elmt (E)), New_Node);
9204                         end if;
9205
9206                         E := Next_Elmt (Next_Elmt (E));
9207                      end loop;
9208                   end if;
9209                end;
9210             end if;
9211
9212             --  Recursively copy descendents
9213
9214             Set_Field1
9215               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
9216             Set_Field2
9217               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
9218             Set_Field3
9219               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
9220             Set_Field4
9221               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
9222             Set_Field5
9223               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
9224
9225             --  Adjust Sloc of new node if necessary
9226
9227             if New_Sloc /= No_Location then
9228                Set_Sloc (New_Node, New_Sloc);
9229
9230                --  If we adjust the Sloc, then we are essentially making
9231                --  a completely new node, so the Comes_From_Source flag
9232                --  should be reset to the proper default value.
9233
9234                Nodes.Table (New_Node).Comes_From_Source :=
9235                  Default_Node.Comes_From_Source;
9236             end if;
9237
9238             --  If the node is call and has named associations,
9239             --  set the corresponding links in the copy.
9240
9241             if (Nkind (Old_Node) = N_Function_Call
9242                  or else Nkind (Old_Node) = N_Entry_Call_Statement
9243                  or else
9244                    Nkind (Old_Node) = N_Procedure_Call_Statement)
9245               and then Present (First_Named_Actual (Old_Node))
9246             then
9247                Adjust_Named_Associations (Old_Node, New_Node);
9248             end if;
9249
9250             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
9251             --  The replacement mechanism applies to entities, and is not used
9252             --  here. Eventually we may need a more general graph-copying
9253             --  routine. For now, do a sequential search to find desired node.
9254
9255             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
9256               and then Present (First_Real_Statement (Old_Node))
9257             then
9258                declare
9259                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
9260                   N1, N2 : Node_Id;
9261
9262                begin
9263                   N1 := First (Statements (Old_Node));
9264                   N2 := First (Statements (New_Node));
9265
9266                   while N1 /= Old_F loop
9267                      Next (N1);
9268                      Next (N2);
9269                   end loop;
9270
9271                   Set_First_Real_Statement (New_Node, N2);
9272                end;
9273             end if;
9274          end if;
9275
9276          --  All done, return copied node
9277
9278          return New_Node;
9279       end Copy_Node_With_Replacement;
9280
9281       -----------------
9282       -- Visit_Elist --
9283       -----------------
9284
9285       procedure Visit_Elist (E : Elist_Id) is
9286          Elmt : Elmt_Id;
9287       begin
9288          if Present (E) then
9289             Elmt := First_Elmt (E);
9290
9291             while Elmt /= No_Elmt loop
9292                Visit_Node (Node (Elmt));
9293                Next_Elmt (Elmt);
9294             end loop;
9295          end if;
9296       end Visit_Elist;
9297
9298       -----------------
9299       -- Visit_Field --
9300       -----------------
9301
9302       procedure Visit_Field (F : Union_Id; N : Node_Id) is
9303       begin
9304          if F = Union_Id (Empty) then
9305             return;
9306
9307          elsif F in Node_Range then
9308
9309             --  Copy node if it is syntactic, i.e. its parent pointer is
9310             --  set to point to the field that referenced it (certain
9311             --  Itypes will also meet this criterion, which is fine, since
9312             --  these are clearly Itypes that do need to be copied, since
9313             --  we are copying their parent.)
9314
9315             if Parent (Node_Id (F)) = N then
9316                Visit_Node (Node_Id (F));
9317                return;
9318
9319             --  Another case, if we are pointing to an Itype, then we want
9320             --  to copy it if its associated node is somewhere in the tree
9321             --  being copied.
9322
9323             --  Note: the exclusion of self-referential copies is just an
9324             --  optimization, since the search of the already copied list
9325             --  would catch it, but it is a common case (Etype pointing
9326             --  to itself for an Itype that is a base type).
9327
9328             elsif Has_Extension (Node_Id (F))
9329               and then Is_Itype (Entity_Id (F))
9330               and then Node_Id (F) /= N
9331             then
9332                declare
9333                   P : Node_Id;
9334
9335                begin
9336                   P := Associated_Node_For_Itype (Node_Id (F));
9337                   while Present (P) loop
9338                      if P = Source then
9339                         Visit_Node (Node_Id (F));
9340                         return;
9341                      else
9342                         P := Parent (P);
9343                      end if;
9344                   end loop;
9345
9346                   --  An Itype whose parent is not being copied definitely
9347                   --  should NOT be copied, since it does not belong in any
9348                   --  sense to the copied subtree.
9349
9350                   return;
9351                end;
9352             end if;
9353
9354          elsif F in List_Range
9355            and then Parent (List_Id (F)) = N
9356          then
9357             Visit_List (List_Id (F));
9358             return;
9359          end if;
9360       end Visit_Field;
9361
9362       -----------------
9363       -- Visit_Itype --
9364       -----------------
9365
9366       procedure Visit_Itype (Old_Itype : Entity_Id) is
9367          New_Itype : Entity_Id;
9368          E         : Elmt_Id;
9369          Ent       : Entity_Id;
9370
9371       begin
9372          --  Itypes that describe the designated type of access to subprograms
9373          --  have the structure of subprogram declarations, with signatures,
9374          --  etc. Either we duplicate the signatures completely, or choose to
9375          --  share such itypes, which is fine because their elaboration will
9376          --  have no side effects.
9377
9378          if Ekind (Old_Itype) = E_Subprogram_Type then
9379             return;
9380          end if;
9381
9382          New_Itype := New_Copy (Old_Itype);
9383
9384          --  The new Itype has all the attributes of the old one, and
9385          --  we just copy the contents of the entity. However, the back-end
9386          --  needs different names for debugging purposes, so we create a
9387          --  new internal name for it in all cases.
9388
9389          Set_Chars (New_Itype, New_Internal_Name ('T'));
9390
9391          --  If our associated node is an entity that has already been copied,
9392          --  then set the associated node of the copy to point to the right
9393          --  copy. If we have copied an Itype that is itself the associated
9394          --  node of some previously copied Itype, then we set the right
9395          --  pointer in the other direction.
9396
9397          if Present (Actual_Map) then
9398
9399             --  Case of hash tables used
9400
9401             if NCT_Hash_Tables_Used then
9402
9403                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
9404
9405                if Present (Ent) then
9406                   Set_Associated_Node_For_Itype (New_Itype, Ent);
9407                end if;
9408
9409                Ent := NCT_Itype_Assoc.Get (Old_Itype);
9410                if Present (Ent) then
9411                   Set_Associated_Node_For_Itype (Ent, New_Itype);
9412
9413                --  If the hash table has no association for this Itype and
9414                --  its associated node, enter one now.
9415
9416                else
9417                   NCT_Itype_Assoc.Set
9418                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
9419                end if;
9420
9421             --  Case of hash tables not used
9422
9423             else
9424                E := First_Elmt (Actual_Map);
9425                while Present (E) loop
9426                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
9427                      Set_Associated_Node_For_Itype
9428                        (New_Itype, Node (Next_Elmt (E)));
9429                   end if;
9430
9431                   if Is_Type (Node (E))
9432                     and then
9433                       Old_Itype = Associated_Node_For_Itype (Node (E))
9434                   then
9435                      Set_Associated_Node_For_Itype
9436                        (Node (Next_Elmt (E)), New_Itype);
9437                   end if;
9438
9439                   E := Next_Elmt (Next_Elmt (E));
9440                end loop;
9441             end if;
9442          end if;
9443
9444          if Present (Freeze_Node (New_Itype)) then
9445             Set_Is_Frozen (New_Itype, False);
9446             Set_Freeze_Node (New_Itype, Empty);
9447          end if;
9448
9449          --  Add new association to map
9450
9451          if No (Actual_Map) then
9452             Actual_Map := New_Elmt_List;
9453          end if;
9454
9455          Append_Elmt (Old_Itype, Actual_Map);
9456          Append_Elmt (New_Itype, Actual_Map);
9457
9458          if NCT_Hash_Tables_Used then
9459             NCT_Assoc.Set (Old_Itype, New_Itype);
9460
9461          else
9462             NCT_Table_Entries := NCT_Table_Entries + 1;
9463
9464             if NCT_Table_Entries > NCT_Hash_Threshold then
9465                Build_NCT_Hash_Tables;
9466             end if;
9467          end if;
9468
9469          --  If a record subtype is simply copied, the entity list will be
9470          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
9471
9472          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
9473             Set_Cloned_Subtype (New_Itype, Old_Itype);
9474          end if;
9475
9476          --  Visit descendents that eventually get copied
9477
9478          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
9479
9480          if Is_Discrete_Type (Old_Itype) then
9481             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
9482
9483          elsif Has_Discriminants (Base_Type (Old_Itype)) then
9484             --  ??? This should involve call to Visit_Field
9485             Visit_Elist (Discriminant_Constraint (Old_Itype));
9486
9487          elsif Is_Array_Type (Old_Itype) then
9488             if Present (First_Index (Old_Itype)) then
9489                Visit_Field (Union_Id (List_Containing
9490                                 (First_Index (Old_Itype))),
9491                             Old_Itype);
9492             end if;
9493
9494             if Is_Packed (Old_Itype) then
9495                Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
9496                             Old_Itype);
9497             end if;
9498          end if;
9499       end Visit_Itype;
9500
9501       ----------------
9502       -- Visit_List --
9503       ----------------
9504
9505       procedure Visit_List (L : List_Id) is
9506          N : Node_Id;
9507       begin
9508          if L /= No_List then
9509             N := First (L);
9510
9511             while Present (N) loop
9512                Visit_Node (N);
9513                Next (N);
9514             end loop;
9515          end if;
9516       end Visit_List;
9517
9518       ----------------
9519       -- Visit_Node --
9520       ----------------
9521
9522       procedure Visit_Node (N : Node_Or_Entity_Id) is
9523
9524       --  Start of processing for Visit_Node
9525
9526       begin
9527          --  Handle case of an Itype, which must be copied
9528
9529          if Has_Extension (N)
9530            and then Is_Itype (N)
9531          then
9532             --  Nothing to do if already in the list. This can happen with an
9533             --  Itype entity that appears more than once in the tree.
9534             --  Note that we do not want to visit descendents in this case.
9535
9536             --  Test for already in list when hash table is used
9537
9538             if NCT_Hash_Tables_Used then
9539                if Present (NCT_Assoc.Get (Entity_Id (N))) then
9540                   return;
9541                end if;
9542
9543             --  Test for already in list when hash table not used
9544
9545             else
9546                declare
9547                   E : Elmt_Id;
9548                begin
9549                   if Present (Actual_Map) then
9550                      E := First_Elmt (Actual_Map);
9551                      while Present (E) loop
9552                         if Node (E) = N then
9553                            return;
9554                         else
9555                            E := Next_Elmt (Next_Elmt (E));
9556                         end if;
9557                      end loop;
9558                   end if;
9559                end;
9560             end if;
9561
9562             Visit_Itype (N);
9563          end if;
9564
9565          --  Visit descendents
9566
9567          Visit_Field (Field1 (N), N);
9568          Visit_Field (Field2 (N), N);
9569          Visit_Field (Field3 (N), N);
9570          Visit_Field (Field4 (N), N);
9571          Visit_Field (Field5 (N), N);
9572       end Visit_Node;
9573
9574    --  Start of processing for New_Copy_Tree
9575
9576    begin
9577       Actual_Map := Map;
9578
9579       --  See if we should use hash table
9580
9581       if No (Actual_Map) then
9582          NCT_Hash_Tables_Used := False;
9583
9584       else
9585          declare
9586             Elmt : Elmt_Id;
9587
9588          begin
9589             NCT_Table_Entries := 0;
9590
9591             Elmt := First_Elmt (Actual_Map);
9592             while Present (Elmt) loop
9593                NCT_Table_Entries := NCT_Table_Entries + 1;
9594                Next_Elmt (Elmt);
9595                Next_Elmt (Elmt);
9596             end loop;
9597
9598             if NCT_Table_Entries > NCT_Hash_Threshold then
9599                Build_NCT_Hash_Tables;
9600             else
9601                NCT_Hash_Tables_Used := False;
9602             end if;
9603          end;
9604       end if;
9605
9606       --  Hash table set up if required, now start phase one by visiting
9607       --  top node (we will recursively visit the descendents).
9608
9609       Visit_Node (Source);
9610
9611       --  Now the second phase of the copy can start. First we process
9612       --  all the mapped entities, copying their descendents.
9613
9614       if Present (Actual_Map) then
9615          declare
9616             Elmt      : Elmt_Id;
9617             New_Itype : Entity_Id;
9618          begin
9619             Elmt := First_Elmt (Actual_Map);
9620             while Present (Elmt) loop
9621                Next_Elmt (Elmt);
9622                New_Itype := Node (Elmt);
9623                Copy_Itype_With_Replacement (New_Itype);
9624                Next_Elmt (Elmt);
9625             end loop;
9626          end;
9627       end if;
9628
9629       --  Now we can copy the actual tree
9630
9631       return Copy_Node_With_Replacement (Source);
9632    end New_Copy_Tree;
9633
9634    -------------------------
9635    -- New_External_Entity --
9636    -------------------------
9637
9638    function New_External_Entity
9639      (Kind         : Entity_Kind;
9640       Scope_Id     : Entity_Id;
9641       Sloc_Value   : Source_Ptr;
9642       Related_Id   : Entity_Id;
9643       Suffix       : Character;
9644       Suffix_Index : Nat := 0;
9645       Prefix       : Character := ' ') return Entity_Id
9646    is
9647       N : constant Entity_Id :=
9648             Make_Defining_Identifier (Sloc_Value,
9649               New_External_Name
9650                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
9651
9652    begin
9653       Set_Ekind          (N, Kind);
9654       Set_Is_Internal    (N, True);
9655       Append_Entity      (N, Scope_Id);
9656       Set_Public_Status  (N);
9657
9658       if Kind in Type_Kind then
9659          Init_Size_Align (N);
9660       end if;
9661
9662       return N;
9663    end New_External_Entity;
9664
9665    -------------------------
9666    -- New_Internal_Entity --
9667    -------------------------
9668
9669    function New_Internal_Entity
9670      (Kind       : Entity_Kind;
9671       Scope_Id   : Entity_Id;
9672       Sloc_Value : Source_Ptr;
9673       Id_Char    : Character) return Entity_Id
9674    is
9675       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
9676
9677    begin
9678       Set_Ekind          (N, Kind);
9679       Set_Is_Internal    (N, True);
9680       Append_Entity      (N, Scope_Id);
9681
9682       if Kind in Type_Kind then
9683          Init_Size_Align (N);
9684       end if;
9685
9686       return N;
9687    end New_Internal_Entity;
9688
9689    -----------------
9690    -- Next_Actual --
9691    -----------------
9692
9693    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
9694       N  : Node_Id;
9695
9696    begin
9697       --  If we are pointing at a positional parameter, it is a member of a
9698       --  node list (the list of parameters), and the next parameter is the
9699       --  next node on the list, unless we hit a parameter association, then
9700       --  we shift to using the chain whose head is the First_Named_Actual in
9701       --  the parent, and then is threaded using the Next_Named_Actual of the
9702       --  Parameter_Association. All this fiddling is because the original node
9703       --  list is in the textual call order, and what we need is the
9704       --  declaration order.
9705
9706       if Is_List_Member (Actual_Id) then
9707          N := Next (Actual_Id);
9708
9709          if Nkind (N) = N_Parameter_Association then
9710             return First_Named_Actual (Parent (Actual_Id));
9711          else
9712             return N;
9713          end if;
9714
9715       else
9716          return Next_Named_Actual (Parent (Actual_Id));
9717       end if;
9718    end Next_Actual;
9719
9720    procedure Next_Actual (Actual_Id : in out Node_Id) is
9721    begin
9722       Actual_Id := Next_Actual (Actual_Id);
9723    end Next_Actual;
9724
9725    -----------------------
9726    -- Normalize_Actuals --
9727    -----------------------
9728
9729    --  Chain actuals according to formals of subprogram. If there are no named
9730    --  associations, the chain is simply the list of Parameter Associations,
9731    --  since the order is the same as the declaration order. If there are named
9732    --  associations, then the First_Named_Actual field in the N_Function_Call
9733    --  or N_Procedure_Call_Statement node points to the Parameter_Association
9734    --  node for the parameter that comes first in declaration order. The
9735    --  remaining named parameters are then chained in declaration order using
9736    --  Next_Named_Actual.
9737
9738    --  This routine also verifies that the number of actuals is compatible with
9739    --  the number and default values of formals, but performs no type checking
9740    --  (type checking is done by the caller).
9741
9742    --  If the matching succeeds, Success is set to True and the caller proceeds
9743    --  with type-checking. If the match is unsuccessful, then Success is set to
9744    --  False, and the caller attempts a different interpretation, if there is
9745    --  one.
9746
9747    --  If the flag Report is on, the call is not overloaded, and a failure to
9748    --  match can be reported here, rather than in the caller.
9749
9750    procedure Normalize_Actuals
9751      (N       : Node_Id;
9752       S       : Entity_Id;
9753       Report  : Boolean;
9754       Success : out Boolean)
9755    is
9756       Actuals     : constant List_Id := Parameter_Associations (N);
9757       Actual      : Node_Id := Empty;
9758       Formal      : Entity_Id;
9759       Last        : Node_Id := Empty;
9760       First_Named : Node_Id := Empty;
9761       Found       : Boolean;
9762
9763       Formals_To_Match : Integer := 0;
9764       Actuals_To_Match : Integer := 0;
9765
9766       procedure Chain (A : Node_Id);
9767       --  Add named actual at the proper place in the list, using the
9768       --  Next_Named_Actual link.
9769
9770       function Reporting return Boolean;
9771       --  Determines if an error is to be reported. To report an error, we
9772       --  need Report to be True, and also we do not report errors caused
9773       --  by calls to init procs that occur within other init procs. Such
9774       --  errors must always be cascaded errors, since if all the types are
9775       --  declared correctly, the compiler will certainly build decent calls!
9776
9777       -----------
9778       -- Chain --
9779       -----------
9780
9781       procedure Chain (A : Node_Id) is
9782       begin
9783          if No (Last) then
9784
9785             --  Call node points to first actual in list
9786
9787             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
9788
9789          else
9790             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
9791          end if;
9792
9793          Last := A;
9794          Set_Next_Named_Actual (Last, Empty);
9795       end Chain;
9796
9797       ---------------
9798       -- Reporting --
9799       ---------------
9800
9801       function Reporting return Boolean is
9802       begin
9803          if not Report then
9804             return False;
9805
9806          elsif not Within_Init_Proc then
9807             return True;
9808
9809          elsif Is_Init_Proc (Entity (Name (N))) then
9810             return False;
9811
9812          else
9813             return True;
9814          end if;
9815       end Reporting;
9816
9817    --  Start of processing for Normalize_Actuals
9818
9819    begin
9820       if Is_Access_Type (S) then
9821
9822          --  The name in the call is a function call that returns an access
9823          --  to subprogram. The designated type has the list of formals.
9824
9825          Formal := First_Formal (Designated_Type (S));
9826       else
9827          Formal := First_Formal (S);
9828       end if;
9829
9830       while Present (Formal) loop
9831          Formals_To_Match := Formals_To_Match + 1;
9832          Next_Formal (Formal);
9833       end loop;
9834
9835       --  Find if there is a named association, and verify that no positional
9836       --  associations appear after named ones.
9837
9838       if Present (Actuals) then
9839          Actual := First (Actuals);
9840       end if;
9841
9842       while Present (Actual)
9843         and then Nkind (Actual) /= N_Parameter_Association
9844       loop
9845          Actuals_To_Match := Actuals_To_Match + 1;
9846          Next (Actual);
9847       end loop;
9848
9849       if No (Actual) and Actuals_To_Match = Formals_To_Match then
9850
9851          --  Most common case: positional notation, no defaults
9852
9853          Success := True;
9854          return;
9855
9856       elsif Actuals_To_Match > Formals_To_Match then
9857
9858          --  Too many actuals: will not work
9859
9860          if Reporting then
9861             if Is_Entity_Name (Name (N)) then
9862                Error_Msg_N ("too many arguments in call to&", Name (N));
9863             else
9864                Error_Msg_N ("too many arguments in call", N);
9865             end if;
9866          end if;
9867
9868          Success := False;
9869          return;
9870       end if;
9871
9872       First_Named := Actual;
9873
9874       while Present (Actual) loop
9875          if Nkind (Actual) /= N_Parameter_Association then
9876             Error_Msg_N
9877               ("positional parameters not allowed after named ones", Actual);
9878             Success := False;
9879             return;
9880
9881          else
9882             Actuals_To_Match := Actuals_To_Match + 1;
9883          end if;
9884
9885          Next (Actual);
9886       end loop;
9887
9888       if Present (Actuals) then
9889          Actual := First (Actuals);
9890       end if;
9891
9892       Formal := First_Formal (S);
9893       while Present (Formal) loop
9894
9895          --  Match the formals in order. If the corresponding actual is
9896          --  positional, nothing to do. Else scan the list of named actuals
9897          --  to find the one with the right name.
9898
9899          if Present (Actual)
9900            and then Nkind (Actual) /= N_Parameter_Association
9901          then
9902             Next (Actual);
9903             Actuals_To_Match := Actuals_To_Match - 1;
9904             Formals_To_Match := Formals_To_Match - 1;
9905
9906          else
9907             --  For named parameters, search the list of actuals to find
9908             --  one that matches the next formal name.
9909
9910             Actual := First_Named;
9911             Found  := False;
9912             while Present (Actual) loop
9913                if Chars (Selector_Name (Actual)) = Chars (Formal) then
9914                   Found := True;
9915                   Chain (Actual);
9916                   Actuals_To_Match := Actuals_To_Match - 1;
9917                   Formals_To_Match := Formals_To_Match - 1;
9918                   exit;
9919                end if;
9920
9921                Next (Actual);
9922             end loop;
9923
9924             if not Found then
9925                if Ekind (Formal) /= E_In_Parameter
9926                  or else No (Default_Value (Formal))
9927                then
9928                   if Reporting then
9929                      if (Comes_From_Source (S)
9930                           or else Sloc (S) = Standard_Location)
9931                        and then Is_Overloadable (S)
9932                      then
9933                         if No (Actuals)
9934                           and then
9935                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
9936                              or else
9937                            (Nkind (Parent (N)) = N_Function_Call
9938                              or else
9939                             Nkind (Parent (N)) = N_Parameter_Association))
9940                           and then Ekind (S) /= E_Function
9941                         then
9942                            Set_Etype (N, Etype (S));
9943                         else
9944                            Error_Msg_Name_1 := Chars (S);
9945                            Error_Msg_Sloc := Sloc (S);
9946                            Error_Msg_NE
9947                              ("missing argument for parameter & " &
9948                                 "in call to % declared #", N, Formal);
9949                         end if;
9950
9951                      elsif Is_Overloadable (S) then
9952                         Error_Msg_Name_1 := Chars (S);
9953
9954                         --  Point to type derivation that generated the
9955                         --  operation.
9956
9957                         Error_Msg_Sloc := Sloc (Parent (S));
9958
9959                         Error_Msg_NE
9960                           ("missing argument for parameter & " &
9961                              "in call to % (inherited) #", N, Formal);
9962
9963                      else
9964                         Error_Msg_NE
9965                           ("missing argument for parameter &", N, Formal);
9966                      end if;
9967                   end if;
9968
9969                   Success := False;
9970                   return;
9971
9972                else
9973                   Formals_To_Match := Formals_To_Match - 1;
9974                end if;
9975             end if;
9976          end if;
9977
9978          Next_Formal (Formal);
9979       end loop;
9980
9981       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
9982          Success := True;
9983          return;
9984
9985       else
9986          if Reporting then
9987
9988             --  Find some superfluous named actual that did not get
9989             --  attached to the list of associations.
9990
9991             Actual := First (Actuals);
9992             while Present (Actual) loop
9993                if Nkind (Actual) = N_Parameter_Association
9994                  and then Actual /= Last
9995                  and then No (Next_Named_Actual (Actual))
9996                then
9997                   Error_Msg_N ("unmatched actual & in call",
9998                     Selector_Name (Actual));
9999                   exit;
10000                end if;
10001
10002                Next (Actual);
10003             end loop;
10004          end if;
10005
10006          Success := False;
10007          return;
10008       end if;
10009    end Normalize_Actuals;
10010
10011    --------------------------------
10012    -- Note_Possible_Modification --
10013    --------------------------------
10014
10015    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
10016       Modification_Comes_From_Source : constant Boolean :=
10017                                          Comes_From_Source (Parent (N));
10018
10019       Ent : Entity_Id;
10020       Exp : Node_Id;
10021
10022    begin
10023       --  Loop to find referenced entity, if there is one
10024
10025       Exp := N;
10026       loop
10027          <<Continue>>
10028          Ent := Empty;
10029
10030          if Is_Entity_Name (Exp) then
10031             Ent := Entity (Exp);
10032
10033             --  If the entity is missing, it is an undeclared identifier,
10034             --  and there is nothing to annotate.
10035
10036             if No (Ent) then
10037                return;
10038             end if;
10039
10040          elsif Nkind (Exp) = N_Explicit_Dereference then
10041             declare
10042                P : constant Node_Id := Prefix (Exp);
10043
10044             begin
10045                if Nkind (P) = N_Selected_Component
10046                  and then Present (
10047                    Entry_Formal (Entity (Selector_Name (P))))
10048                then
10049                   --  Case of a reference to an entry formal
10050
10051                   Ent := Entry_Formal (Entity (Selector_Name (P)));
10052
10053                elsif Nkind (P) = N_Identifier
10054                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
10055                  and then Present (Expression (Parent (Entity (P))))
10056                  and then Nkind (Expression (Parent (Entity (P))))
10057                    = N_Reference
10058                then
10059                   --  Case of a reference to a value on which side effects have
10060                   --  been removed.
10061
10062                   Exp := Prefix (Expression (Parent (Entity (P))));
10063                   goto Continue;
10064
10065                else
10066                   return;
10067
10068                end if;
10069             end;
10070
10071          elsif     Nkind (Exp) = N_Type_Conversion
10072            or else Nkind (Exp) = N_Unchecked_Type_Conversion
10073          then
10074             Exp := Expression (Exp);
10075             goto Continue;
10076
10077          elsif     Nkind (Exp) = N_Slice
10078            or else Nkind (Exp) = N_Indexed_Component
10079            or else Nkind (Exp) = N_Selected_Component
10080          then
10081             Exp := Prefix (Exp);
10082             goto Continue;
10083
10084          else
10085             return;
10086          end if;
10087
10088          --  Now look for entity being referenced
10089
10090          if Present (Ent) then
10091             if Is_Object (Ent) then
10092                if Comes_From_Source (Exp)
10093                  or else Modification_Comes_From_Source
10094                then
10095                   --  Give warning if pragma unmodified given and we are
10096                   --  sure this is a modification.
10097
10098                   if Has_Pragma_Unmodified (Ent) and then Sure then
10099                      Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
10100                   end if;
10101
10102                   Set_Never_Set_In_Source (Ent, False);
10103                end if;
10104
10105                Set_Is_True_Constant (Ent, False);
10106                Set_Current_Value    (Ent, Empty);
10107                Set_Is_Known_Null    (Ent, False);
10108
10109                if not Can_Never_Be_Null (Ent) then
10110                   Set_Is_Known_Non_Null (Ent, False);
10111                end if;
10112
10113                --  Follow renaming chain
10114
10115                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
10116                  and then Present (Renamed_Object (Ent))
10117                then
10118                   Exp := Renamed_Object (Ent);
10119                   goto Continue;
10120                end if;
10121
10122                --  Generate a reference only if the assignment comes from
10123                --  source. This excludes, for example, calls to a dispatching
10124                --  assignment operation when the left-hand side is tagged.
10125
10126                if Modification_Comes_From_Source then
10127                   Generate_Reference (Ent, Exp, 'm');
10128
10129                   --  If the target of the assignment is the bound variable
10130                   --  in an iterator, indicate that the corresponding array
10131                   --  or container is also modified.
10132
10133                   if Ada_Version >= Ada_2012
10134                     and then
10135                       Nkind (Parent (Ent)) = N_Iterator_Specification
10136                   then
10137                      declare
10138                         Domain : constant Node_Id := Name (Parent (Ent));
10139
10140                      begin
10141                         --  TBD : in the full version of the construct, the
10142                         --  domain of iteration can be given by an expression.
10143
10144                         if Is_Entity_Name (Domain) then
10145                            Generate_Reference      (Entity (Domain), Exp, 'm');
10146                            Set_Is_True_Constant    (Entity (Domain), False);
10147                            Set_Never_Set_In_Source (Entity (Domain), False);
10148                         end if;
10149                      end;
10150                   end if;
10151                end if;
10152
10153                Check_Nested_Access (Ent);
10154             end if;
10155
10156             Kill_Checks (Ent);
10157
10158             --  If we are sure this is a modification from source, and we know
10159             --  this modifies a constant, then give an appropriate warning.
10160
10161             if Overlays_Constant (Ent)
10162               and then Modification_Comes_From_Source
10163               and then Sure
10164             then
10165                declare
10166                   A : constant Node_Id := Address_Clause (Ent);
10167                begin
10168                   if Present (A) then
10169                      declare
10170                         Exp : constant Node_Id := Expression (A);
10171                      begin
10172                         if Nkind (Exp) = N_Attribute_Reference
10173                           and then Attribute_Name (Exp) = Name_Address
10174                           and then Is_Entity_Name (Prefix (Exp))
10175                         then
10176                            Error_Msg_Sloc := Sloc (A);
10177                            Error_Msg_NE
10178                              ("constant& may be modified via address clause#?",
10179                               N, Entity (Prefix (Exp)));
10180                         end if;
10181                      end;
10182                   end if;
10183                end;
10184             end if;
10185
10186             return;
10187          end if;
10188       end loop;
10189    end Note_Possible_Modification;
10190
10191    -------------------------
10192    -- Object_Access_Level --
10193    -------------------------
10194
10195    function Object_Access_Level (Obj : Node_Id) return Uint is
10196       E : Entity_Id;
10197
10198    --  Returns the static accessibility level of the view denoted by Obj. Note
10199    --  that the value returned is the result of a call to Scope_Depth. Only
10200    --  scope depths associated with dynamic scopes can actually be returned.
10201    --  Since only relative levels matter for accessibility checking, the fact
10202    --  that the distance between successive levels of accessibility is not
10203    --  always one is immaterial (invariant: if level(E2) is deeper than
10204    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
10205
10206       function Reference_To (Obj : Node_Id) return Node_Id;
10207       --  An explicit dereference is created when removing side-effects from
10208       --  expressions for constraint checking purposes. In this case a local
10209       --  access type is created for it. The correct access level is that of
10210       --  the original source node. We detect this case by noting that the
10211       --  prefix of the dereference is created by an object declaration whose
10212       --  initial expression is a reference.
10213
10214       ------------------
10215       -- Reference_To --
10216       ------------------
10217
10218       function Reference_To (Obj : Node_Id) return Node_Id is
10219          Pref : constant Node_Id := Prefix (Obj);
10220       begin
10221          if Is_Entity_Name (Pref)
10222            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
10223            and then Present (Expression (Parent (Entity (Pref))))
10224            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
10225          then
10226             return (Prefix (Expression (Parent (Entity (Pref)))));
10227          else
10228             return Empty;
10229          end if;
10230       end Reference_To;
10231
10232    --  Start of processing for Object_Access_Level
10233
10234    begin
10235       if Is_Entity_Name (Obj) then
10236          E := Entity (Obj);
10237
10238          if Is_Prival (E) then
10239             E := Prival_Link (E);
10240          end if;
10241
10242          --  If E is a type then it denotes a current instance. For this case
10243          --  we add one to the normal accessibility level of the type to ensure
10244          --  that current instances are treated as always being deeper than
10245          --  than the level of any visible named access type (see 3.10.2(21)).
10246
10247          if Is_Type (E) then
10248             return Type_Access_Level (E) +  1;
10249
10250          elsif Present (Renamed_Object (E)) then
10251             return Object_Access_Level (Renamed_Object (E));
10252
10253          --  Similarly, if E is a component of the current instance of a
10254          --  protected type, any instance of it is assumed to be at a deeper
10255          --  level than the type. For a protected object (whose type is an
10256          --  anonymous protected type) its components are at the same level
10257          --  as the type itself.
10258
10259          elsif not Is_Overloadable (E)
10260            and then Ekind (Scope (E)) = E_Protected_Type
10261            and then Comes_From_Source (Scope (E))
10262          then
10263             return Type_Access_Level (Scope (E)) + 1;
10264
10265          else
10266             return Scope_Depth (Enclosing_Dynamic_Scope (E));
10267          end if;
10268
10269       elsif Nkind (Obj) = N_Selected_Component then
10270          if Is_Access_Type (Etype (Prefix (Obj))) then
10271             return Type_Access_Level (Etype (Prefix (Obj)));
10272          else
10273             return Object_Access_Level (Prefix (Obj));
10274          end if;
10275
10276       elsif Nkind (Obj) = N_Indexed_Component then
10277          if Is_Access_Type (Etype (Prefix (Obj))) then
10278             return Type_Access_Level (Etype (Prefix (Obj)));
10279          else
10280             return Object_Access_Level (Prefix (Obj));
10281          end if;
10282
10283       elsif Nkind (Obj) = N_Explicit_Dereference then
10284
10285          --  If the prefix is a selected access discriminant then we make a
10286          --  recursive call on the prefix, which will in turn check the level
10287          --  of the prefix object of the selected discriminant.
10288
10289          if Nkind (Prefix (Obj)) = N_Selected_Component
10290            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
10291            and then
10292              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
10293          then
10294             return Object_Access_Level (Prefix (Obj));
10295
10296          elsif not (Comes_From_Source (Obj)) then
10297             declare
10298                Ref : constant Node_Id := Reference_To (Obj);
10299             begin
10300                if Present (Ref) then
10301                   return Object_Access_Level (Ref);
10302                else
10303                   return Type_Access_Level (Etype (Prefix (Obj)));
10304                end if;
10305             end;
10306
10307          else
10308             return Type_Access_Level (Etype (Prefix (Obj)));
10309          end if;
10310
10311       elsif Nkind (Obj) = N_Type_Conversion
10312         or else Nkind (Obj) = N_Unchecked_Type_Conversion
10313       then
10314          return Object_Access_Level (Expression (Obj));
10315
10316       elsif Nkind (Obj) = N_Function_Call then
10317
10318          --  Function results are objects, so we get either the access level of
10319          --  the function or, in the case of an indirect call, the level of the
10320          --  access-to-subprogram type. (This code is used for Ada 95, but it
10321          --  looks wrong, because it seems that we should be checking the level
10322          --  of the call itself, even for Ada 95. However, using the Ada 2005
10323          --  version of the code causes regressions in several tests that are
10324          --  compiled with -gnat95. ???)
10325
10326          if Ada_Version < Ada_2005 then
10327             if Is_Entity_Name (Name (Obj)) then
10328                return Subprogram_Access_Level (Entity (Name (Obj)));
10329             else
10330                return Type_Access_Level (Etype (Prefix (Name (Obj))));
10331             end if;
10332
10333          --  For Ada 2005, the level of the result object of a function call is
10334          --  defined to be the level of the call's innermost enclosing master.
10335          --  We determine that by querying the depth of the innermost enclosing
10336          --  dynamic scope.
10337
10338          else
10339             Return_Master_Scope_Depth_Of_Call : declare
10340
10341                function Innermost_Master_Scope_Depth
10342                  (N : Node_Id) return Uint;
10343                --  Returns the scope depth of the given node's innermost
10344                --  enclosing dynamic scope (effectively the accessibility
10345                --  level of the innermost enclosing master).
10346
10347                ----------------------------------
10348                -- Innermost_Master_Scope_Depth --
10349                ----------------------------------
10350
10351                function Innermost_Master_Scope_Depth
10352                  (N : Node_Id) return Uint
10353                is
10354                   Node_Par : Node_Id := Parent (N);
10355
10356                begin
10357                   --  Locate the nearest enclosing node (by traversing Parents)
10358                   --  that Defining_Entity can be applied to, and return the
10359                   --  depth of that entity's nearest enclosing dynamic scope.
10360
10361                   while Present (Node_Par) loop
10362                      case Nkind (Node_Par) is
10363                         when N_Component_Declaration           |
10364                              N_Entry_Declaration               |
10365                              N_Formal_Object_Declaration       |
10366                              N_Formal_Type_Declaration         |
10367                              N_Full_Type_Declaration           |
10368                              N_Incomplete_Type_Declaration     |
10369                              N_Loop_Parameter_Specification    |
10370                              N_Object_Declaration              |
10371                              N_Protected_Type_Declaration      |
10372                              N_Private_Extension_Declaration   |
10373                              N_Private_Type_Declaration        |
10374                              N_Subtype_Declaration             |
10375                              N_Function_Specification          |
10376                              N_Procedure_Specification         |
10377                              N_Task_Type_Declaration           |
10378                              N_Body_Stub                       |
10379                              N_Generic_Instantiation           |
10380                              N_Proper_Body                     |
10381                              N_Implicit_Label_Declaration      |
10382                              N_Package_Declaration             |
10383                              N_Single_Task_Declaration         |
10384                              N_Subprogram_Declaration          |
10385                              N_Generic_Declaration             |
10386                              N_Renaming_Declaration            |
10387                              N_Block_Statement                 |
10388                              N_Formal_Subprogram_Declaration   |
10389                              N_Abstract_Subprogram_Declaration |
10390                              N_Entry_Body                      |
10391                              N_Exception_Declaration           |
10392                              N_Formal_Package_Declaration      |
10393                              N_Number_Declaration              |
10394                              N_Package_Specification           |
10395                              N_Parameter_Specification         |
10396                              N_Single_Protected_Declaration    |
10397                              N_Subunit                         =>
10398
10399                            return Scope_Depth
10400                                     (Nearest_Dynamic_Scope
10401                                        (Defining_Entity (Node_Par)));
10402
10403                         when others =>
10404                            null;
10405                      end case;
10406
10407                      Node_Par := Parent (Node_Par);
10408                   end loop;
10409
10410                   pragma Assert (False);
10411
10412                   --  Should never reach the following return
10413
10414                   return Scope_Depth (Current_Scope) + 1;
10415                end Innermost_Master_Scope_Depth;
10416
10417             --  Start of processing for Return_Master_Scope_Depth_Of_Call
10418
10419             begin
10420                return Innermost_Master_Scope_Depth (Obj);
10421             end Return_Master_Scope_Depth_Of_Call;
10422          end if;
10423
10424       --  For convenience we handle qualified expressions, even though
10425       --  they aren't technically object names.
10426
10427       elsif Nkind (Obj) = N_Qualified_Expression then
10428          return Object_Access_Level (Expression (Obj));
10429
10430       --  Otherwise return the scope level of Standard.
10431       --  (If there are cases that fall through
10432       --  to this point they will be treated as
10433       --  having global accessibility for now. ???)
10434
10435       else
10436          return Scope_Depth (Standard_Standard);
10437       end if;
10438    end Object_Access_Level;
10439
10440    --------------------------------------
10441    -- Original_Corresponding_Operation --
10442    --------------------------------------
10443
10444    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
10445    is
10446       Typ : constant Entity_Id := Find_Dispatching_Type (S);
10447
10448    begin
10449       --  If S is an inherited primitive S2 the original corresponding
10450       --  operation of S is the original corresponding operation of S2
10451
10452       if Present (Alias (S))
10453         and then Find_Dispatching_Type (Alias (S)) /= Typ
10454       then
10455          return Original_Corresponding_Operation (Alias (S));
10456
10457       --  If S overrides an inherited subprogram S2 the original corresponding
10458       --  operation of S is the original corresponding operation of S2
10459
10460       elsif Present (Overridden_Operation (S)) then
10461          return Original_Corresponding_Operation (Overridden_Operation (S));
10462
10463       --  otherwise it is S itself
10464
10465       else
10466          return S;
10467       end if;
10468    end Original_Corresponding_Operation;
10469
10470    -----------------------
10471    -- Private_Component --
10472    -----------------------
10473
10474    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
10475       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
10476
10477       function Trace_Components
10478         (T     : Entity_Id;
10479          Check : Boolean) return Entity_Id;
10480       --  Recursive function that does the work, and checks against circular
10481       --  definition for each subcomponent type.
10482
10483       ----------------------
10484       -- Trace_Components --
10485       ----------------------
10486
10487       function Trace_Components
10488          (T     : Entity_Id;
10489           Check : Boolean) return Entity_Id
10490        is
10491          Btype     : constant Entity_Id := Base_Type (T);
10492          Component : Entity_Id;
10493          P         : Entity_Id;
10494          Candidate : Entity_Id := Empty;
10495
10496       begin
10497          if Check and then Btype = Ancestor then
10498             Error_Msg_N ("circular type definition", Type_Id);
10499             return Any_Type;
10500          end if;
10501
10502          if Is_Private_Type (Btype)
10503            and then not Is_Generic_Type (Btype)
10504          then
10505             if Present (Full_View (Btype))
10506               and then Is_Record_Type (Full_View (Btype))
10507               and then not Is_Frozen (Btype)
10508             then
10509                --  To indicate that the ancestor depends on a private type, the
10510                --  current Btype is sufficient. However, to check for circular
10511                --  definition we must recurse on the full view.
10512
10513                Candidate := Trace_Components (Full_View (Btype), True);
10514
10515                if Candidate = Any_Type then
10516                   return Any_Type;
10517                else
10518                   return Btype;
10519                end if;
10520
10521             else
10522                return Btype;
10523             end if;
10524
10525          elsif Is_Array_Type (Btype) then
10526             return Trace_Components (Component_Type (Btype), True);
10527
10528          elsif Is_Record_Type (Btype) then
10529             Component := First_Entity (Btype);
10530             while Present (Component) loop
10531
10532                --  Skip anonymous types generated by constrained components
10533
10534                if not Is_Type (Component) then
10535                   P := Trace_Components (Etype (Component), True);
10536
10537                   if Present (P) then
10538                      if P = Any_Type then
10539                         return P;
10540                      else
10541                         Candidate := P;
10542                      end if;
10543                   end if;
10544                end if;
10545
10546                Next_Entity (Component);
10547             end loop;
10548
10549             return Candidate;
10550
10551          else
10552             return Empty;
10553          end if;
10554       end Trace_Components;
10555
10556    --  Start of processing for Private_Component
10557
10558    begin
10559       return Trace_Components (Type_Id, False);
10560    end Private_Component;
10561
10562    ---------------------------
10563    -- Primitive_Names_Match --
10564    ---------------------------
10565
10566    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
10567
10568       function Non_Internal_Name (E : Entity_Id) return Name_Id;
10569       --  Given an internal name, returns the corresponding non-internal name
10570
10571       ------------------------
10572       --  Non_Internal_Name --
10573       ------------------------
10574
10575       function Non_Internal_Name (E : Entity_Id) return Name_Id is
10576       begin
10577          Get_Name_String (Chars (E));
10578          Name_Len := Name_Len - 1;
10579          return Name_Find;
10580       end Non_Internal_Name;
10581
10582    --  Start of processing for Primitive_Names_Match
10583
10584    begin
10585       pragma Assert (Present (E1) and then Present (E2));
10586
10587       return Chars (E1) = Chars (E2)
10588         or else
10589            (not Is_Internal_Name (Chars (E1))
10590               and then Is_Internal_Name (Chars (E2))
10591               and then Non_Internal_Name (E2) = Chars (E1))
10592         or else
10593            (not Is_Internal_Name (Chars (E2))
10594               and then Is_Internal_Name (Chars (E1))
10595               and then Non_Internal_Name (E1) = Chars (E2))
10596         or else
10597            (Is_Predefined_Dispatching_Operation (E1)
10598               and then Is_Predefined_Dispatching_Operation (E2)
10599               and then Same_TSS (E1, E2))
10600         or else
10601            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
10602    end Primitive_Names_Match;
10603
10604    -----------------------
10605    -- Process_End_Label --
10606    -----------------------
10607
10608    procedure Process_End_Label
10609      (N   : Node_Id;
10610       Typ : Character;
10611       Ent : Entity_Id)
10612    is
10613       Loc  : Source_Ptr;
10614       Nam  : Node_Id;
10615       Scop : Entity_Id;
10616
10617       Label_Ref : Boolean;
10618       --  Set True if reference to end label itself is required
10619
10620       Endl : Node_Id;
10621       --  Gets set to the operator symbol or identifier that references the
10622       --  entity Ent. For the child unit case, this is the identifier from the
10623       --  designator. For other cases, this is simply Endl.
10624
10625       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
10626       --  N is an identifier node that appears as a parent unit reference in
10627       --  the case where Ent is a child unit. This procedure generates an
10628       --  appropriate cross-reference entry. E is the corresponding entity.
10629
10630       -------------------------
10631       -- Generate_Parent_Ref --
10632       -------------------------
10633
10634       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
10635       begin
10636          --  If names do not match, something weird, skip reference
10637
10638          if Chars (E) = Chars (N) then
10639
10640             --  Generate the reference. We do NOT consider this as a reference
10641             --  for unreferenced symbol purposes.
10642
10643             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
10644
10645             if Style_Check then
10646                Style.Check_Identifier (N, E);
10647             end if;
10648          end if;
10649       end Generate_Parent_Ref;
10650
10651    --  Start of processing for Process_End_Label
10652
10653    begin
10654       --  If no node, ignore. This happens in some error situations, and
10655       --  also for some internally generated structures where no end label
10656       --  references are required in any case.
10657
10658       if No (N) then
10659          return;
10660       end if;
10661
10662       --  Nothing to do if no End_Label, happens for internally generated
10663       --  constructs where we don't want an end label reference anyway. Also
10664       --  nothing to do if Endl is a string literal, which means there was
10665       --  some prior error (bad operator symbol)
10666
10667       Endl := End_Label (N);
10668
10669       if No (Endl) or else Nkind (Endl) = N_String_Literal then
10670          return;
10671       end if;
10672
10673       --  Reference node is not in extended main source unit
10674
10675       if not In_Extended_Main_Source_Unit (N) then
10676
10677          --  Generally we do not collect references except for the extended
10678          --  main source unit. The one exception is the 'e' entry for a
10679          --  package spec, where it is useful for a client to have the
10680          --  ending information to define scopes.
10681
10682          if Typ /= 'e' then
10683             return;
10684
10685          else
10686             Label_Ref := False;
10687
10688             --  For this case, we can ignore any parent references, but we
10689             --  need the package name itself for the 'e' entry.
10690
10691             if Nkind (Endl) = N_Designator then
10692                Endl := Identifier (Endl);
10693             end if;
10694          end if;
10695
10696       --  Reference is in extended main source unit
10697
10698       else
10699          Label_Ref := True;
10700
10701          --  For designator, generate references for the parent entries
10702
10703          if Nkind (Endl) = N_Designator then
10704
10705             --  Generate references for the prefix if the END line comes from
10706             --  source (otherwise we do not need these references) We climb the
10707             --  scope stack to find the expected entities.
10708
10709             if Comes_From_Source (Endl) then
10710                Nam  := Name (Endl);
10711                Scop := Current_Scope;
10712                while Nkind (Nam) = N_Selected_Component loop
10713                   Scop := Scope (Scop);
10714                   exit when No (Scop);
10715                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
10716                   Nam := Prefix (Nam);
10717                end loop;
10718
10719                if Present (Scop) then
10720                   Generate_Parent_Ref (Nam, Scope (Scop));
10721                end if;
10722             end if;
10723
10724             Endl := Identifier (Endl);
10725          end if;
10726       end if;
10727
10728       --  If the end label is not for the given entity, then either we have
10729       --  some previous error, or this is a generic instantiation for which
10730       --  we do not need to make a cross-reference in this case anyway. In
10731       --  either case we simply ignore the call.
10732
10733       if Chars (Ent) /= Chars (Endl) then
10734          return;
10735       end if;
10736
10737       --  If label was really there, then generate a normal reference and then
10738       --  adjust the location in the end label to point past the name (which
10739       --  should almost always be the semicolon).
10740
10741       Loc := Sloc (Endl);
10742
10743       if Comes_From_Source (Endl) then
10744
10745          --  If a label reference is required, then do the style check and
10746          --  generate an l-type cross-reference entry for the label
10747
10748          if Label_Ref then
10749             if Style_Check then
10750                Style.Check_Identifier (Endl, Ent);
10751             end if;
10752
10753             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
10754          end if;
10755
10756          --  Set the location to point past the label (normally this will
10757          --  mean the semicolon immediately following the label). This is
10758          --  done for the sake of the 'e' or 't' entry generated below.
10759
10760          Get_Decoded_Name_String (Chars (Endl));
10761          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
10762
10763       else
10764          --  In SPARK mode, no missing label is allowed for packages and
10765          --  subprogram bodies. Detect those cases by testing whether
10766          --  Process_End_Label was called for a body (Typ = 't') or a package.
10767
10768          if (SPARK_Mode or else Restriction_Check_Required (SPARK))
10769            and then (Typ = 't' or else Ekind (Ent) = E_Package)
10770          then
10771             Error_Msg_Node_1 := Endl;
10772             Check_Formal_Restriction ("`END &` required", Endl, Force => True);
10773          end if;
10774       end if;
10775
10776       --  Now generate the e/t reference
10777
10778       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
10779
10780       --  Restore Sloc, in case modified above, since we have an identifier
10781       --  and the normal Sloc should be left set in the tree.
10782
10783       Set_Sloc (Endl, Loc);
10784    end Process_End_Label;
10785
10786    ------------------------------------
10787    -- References_Generic_Formal_Type --
10788    ------------------------------------
10789
10790    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
10791
10792       function Process (N : Node_Id) return Traverse_Result;
10793       --  Process one node in search for generic formal type
10794
10795       -------------
10796       -- Process --
10797       -------------
10798
10799       function Process (N : Node_Id) return Traverse_Result is
10800       begin
10801          if Nkind (N) in N_Has_Entity then
10802             declare
10803                E : constant Entity_Id := Entity (N);
10804             begin
10805                if Present (E) then
10806                   if Is_Generic_Type (E) then
10807                      return Abandon;
10808                   elsif Present (Etype (E))
10809                     and then Is_Generic_Type (Etype (E))
10810                   then
10811                      return Abandon;
10812                   end if;
10813                end if;
10814             end;
10815          end if;
10816
10817          return Atree.OK;
10818       end Process;
10819
10820       function Traverse is new Traverse_Func (Process);
10821       --  Traverse tree to look for generic type
10822
10823    begin
10824       if Inside_A_Generic then
10825          return Traverse (N) = Abandon;
10826       else
10827          return False;
10828       end if;
10829    end References_Generic_Formal_Type;
10830
10831    --------------------
10832    -- Remove_Homonym --
10833    --------------------
10834
10835    procedure Remove_Homonym (E : Entity_Id) is
10836       Prev  : Entity_Id := Empty;
10837       H     : Entity_Id;
10838
10839    begin
10840       if E = Current_Entity (E) then
10841          if Present (Homonym (E)) then
10842             Set_Current_Entity (Homonym (E));
10843          else
10844             Set_Name_Entity_Id (Chars (E), Empty);
10845          end if;
10846       else
10847          H := Current_Entity (E);
10848          while Present (H) and then H /= E loop
10849             Prev := H;
10850             H    := Homonym (H);
10851          end loop;
10852
10853          Set_Homonym (Prev, Homonym (E));
10854       end if;
10855    end Remove_Homonym;
10856
10857    ---------------------
10858    -- Rep_To_Pos_Flag --
10859    ---------------------
10860
10861    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
10862    begin
10863       return New_Occurrence_Of
10864                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
10865    end Rep_To_Pos_Flag;
10866
10867    --------------------
10868    -- Require_Entity --
10869    --------------------
10870
10871    procedure Require_Entity (N : Node_Id) is
10872    begin
10873       if Is_Entity_Name (N) and then No (Entity (N)) then
10874          if Total_Errors_Detected /= 0 then
10875             Set_Entity (N, Any_Id);
10876          else
10877             raise Program_Error;
10878          end if;
10879       end if;
10880    end Require_Entity;
10881
10882    ------------------------------
10883    -- Requires_Transient_Scope --
10884    ------------------------------
10885
10886    --  A transient scope is required when variable-sized temporaries are
10887    --  allocated in the primary or secondary stack, or when finalization
10888    --  actions must be generated before the next instruction.
10889
10890    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
10891       Typ : constant Entity_Id := Underlying_Type (Id);
10892
10893    --  Start of processing for Requires_Transient_Scope
10894
10895    begin
10896       --  This is a private type which is not completed yet. This can only
10897       --  happen in a default expression (of a formal parameter or of a
10898       --  record component). Do not expand transient scope in this case
10899
10900       if No (Typ) then
10901          return False;
10902
10903       --  Do not expand transient scope for non-existent procedure return
10904
10905       elsif Typ = Standard_Void_Type then
10906          return False;
10907
10908       --  Elementary types do not require a transient scope
10909
10910       elsif Is_Elementary_Type (Typ) then
10911          return False;
10912
10913       --  Generally, indefinite subtypes require a transient scope, since the
10914       --  back end cannot generate temporaries, since this is not a valid type
10915       --  for declaring an object. It might be possible to relax this in the
10916       --  future, e.g. by declaring the maximum possible space for the type.
10917
10918       elsif Is_Indefinite_Subtype (Typ) then
10919          return True;
10920
10921       --  Functions returning tagged types may dispatch on result so their
10922       --  returned value is allocated on the secondary stack. Controlled
10923       --  type temporaries need finalization.
10924
10925       elsif Is_Tagged_Type (Typ)
10926         or else Has_Controlled_Component (Typ)
10927       then
10928          return not Is_Value_Type (Typ);
10929
10930       --  Record type
10931
10932       elsif Is_Record_Type (Typ) then
10933          declare
10934             Comp : Entity_Id;
10935          begin
10936             Comp := First_Entity (Typ);
10937             while Present (Comp) loop
10938                if Ekind (Comp) = E_Component
10939                   and then Requires_Transient_Scope (Etype (Comp))
10940                then
10941                   return True;
10942                else
10943                   Next_Entity (Comp);
10944                end if;
10945             end loop;
10946          end;
10947
10948          return False;
10949
10950       --  String literal types never require transient scope
10951
10952       elsif Ekind (Typ) = E_String_Literal_Subtype then
10953          return False;
10954
10955       --  Array type. Note that we already know that this is a constrained
10956       --  array, since unconstrained arrays will fail the indefinite test.
10957
10958       elsif Is_Array_Type (Typ) then
10959
10960          --  If component type requires a transient scope, the array does too
10961
10962          if Requires_Transient_Scope (Component_Type (Typ)) then
10963             return True;
10964
10965          --  Otherwise, we only need a transient scope if the size depends on
10966          --  the value of one or more discriminants.
10967
10968          else
10969             return Size_Depends_On_Discriminant (Typ);
10970          end if;
10971
10972       --  All other cases do not require a transient scope
10973
10974       else
10975          return False;
10976       end if;
10977    end Requires_Transient_Scope;
10978
10979    --------------------------
10980    -- Reset_Analyzed_Flags --
10981    --------------------------
10982
10983    procedure Reset_Analyzed_Flags (N : Node_Id) is
10984
10985       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
10986       --  Function used to reset Analyzed flags in tree. Note that we do
10987       --  not reset Analyzed flags in entities, since there is no need to
10988       --  reanalyze entities, and indeed, it is wrong to do so, since it
10989       --  can result in generating auxiliary stuff more than once.
10990
10991       --------------------
10992       -- Clear_Analyzed --
10993       --------------------
10994
10995       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
10996       begin
10997          if not Has_Extension (N) then
10998             Set_Analyzed (N, False);
10999          end if;
11000
11001          return OK;
11002       end Clear_Analyzed;
11003
11004       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
11005
11006    --  Start of processing for Reset_Analyzed_Flags
11007
11008    begin
11009       Reset_Analyzed (N);
11010    end Reset_Analyzed_Flags;
11011
11012    ---------------------------
11013    -- Safe_To_Capture_Value --
11014    ---------------------------
11015
11016    function Safe_To_Capture_Value
11017      (N    : Node_Id;
11018       Ent  : Entity_Id;
11019       Cond : Boolean := False) return Boolean
11020    is
11021    begin
11022       --  The only entities for which we track constant values are variables
11023       --  which are not renamings, constants, out parameters, and in out
11024       --  parameters, so check if we have this case.
11025
11026       --  Note: it may seem odd to track constant values for constants, but in
11027       --  fact this routine is used for other purposes than simply capturing
11028       --  the value. In particular, the setting of Known[_Non]_Null.
11029
11030       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
11031             or else
11032           Ekind (Ent) = E_Constant
11033             or else
11034           Ekind (Ent) = E_Out_Parameter
11035             or else
11036           Ekind (Ent) = E_In_Out_Parameter
11037       then
11038          null;
11039
11040       --  For conditionals, we also allow loop parameters and all formals,
11041       --  including in parameters.
11042
11043       elsif Cond
11044         and then
11045           (Ekind (Ent) = E_Loop_Parameter
11046              or else
11047            Ekind (Ent) = E_In_Parameter)
11048       then
11049          null;
11050
11051       --  For all other cases, not just unsafe, but impossible to capture
11052       --  Current_Value, since the above are the only entities which have
11053       --  Current_Value fields.
11054
11055       else
11056          return False;
11057       end if;
11058
11059       --  Skip if volatile or aliased, since funny things might be going on in
11060       --  these cases which we cannot necessarily track. Also skip any variable
11061       --  for which an address clause is given, or whose address is taken. Also
11062       --  never capture value of library level variables (an attempt to do so
11063       --  can occur in the case of package elaboration code).
11064
11065       if Treat_As_Volatile (Ent)
11066         or else Is_Aliased (Ent)
11067         or else Present (Address_Clause (Ent))
11068         or else Address_Taken (Ent)
11069         or else (Is_Library_Level_Entity (Ent)
11070                    and then Ekind (Ent) = E_Variable)
11071       then
11072          return False;
11073       end if;
11074
11075       --  OK, all above conditions are met. We also require that the scope of
11076       --  the reference be the same as the scope of the entity, not counting
11077       --  packages and blocks and loops.
11078
11079       declare
11080          E_Scope : constant Entity_Id := Scope (Ent);
11081          R_Scope : Entity_Id;
11082
11083       begin
11084          R_Scope := Current_Scope;
11085          while R_Scope /= Standard_Standard loop
11086             exit when R_Scope = E_Scope;
11087
11088             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
11089                return False;
11090             else
11091                R_Scope := Scope (R_Scope);
11092             end if;
11093          end loop;
11094       end;
11095
11096       --  We also require that the reference does not appear in a context
11097       --  where it is not sure to be executed (i.e. a conditional context
11098       --  or an exception handler). We skip this if Cond is True, since the
11099       --  capturing of values from conditional tests handles this ok.
11100
11101       if Cond then
11102          return True;
11103       end if;
11104
11105       declare
11106          Desc : Node_Id;
11107          P    : Node_Id;
11108
11109       begin
11110          Desc := N;
11111
11112          P := Parent (N);
11113          while Present (P) loop
11114             if         Nkind (P) = N_If_Statement
11115               or else  Nkind (P) = N_Case_Statement
11116               or else (Nkind (P) in N_Short_Circuit
11117                          and then Desc = Right_Opnd (P))
11118               or else (Nkind (P) = N_Conditional_Expression
11119                          and then Desc /= First (Expressions (P)))
11120               or else  Nkind (P) = N_Exception_Handler
11121               or else  Nkind (P) = N_Selective_Accept
11122               or else  Nkind (P) = N_Conditional_Entry_Call
11123               or else  Nkind (P) = N_Timed_Entry_Call
11124               or else  Nkind (P) = N_Asynchronous_Select
11125             then
11126                return False;
11127             else
11128                Desc := P;
11129                P    := Parent (P);
11130             end if;
11131          end loop;
11132       end;
11133
11134       --  OK, looks safe to set value
11135
11136       return True;
11137    end Safe_To_Capture_Value;
11138
11139    ---------------
11140    -- Same_Name --
11141    ---------------
11142
11143    function Same_Name (N1, N2 : Node_Id) return Boolean is
11144       K1 : constant Node_Kind := Nkind (N1);
11145       K2 : constant Node_Kind := Nkind (N2);
11146
11147    begin
11148       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
11149         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
11150       then
11151          return Chars (N1) = Chars (N2);
11152
11153       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
11154         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
11155       then
11156          return Same_Name (Selector_Name (N1), Selector_Name (N2))
11157            and then Same_Name (Prefix (N1), Prefix (N2));
11158
11159       else
11160          return False;
11161       end if;
11162    end Same_Name;
11163
11164    -----------------
11165    -- Same_Object --
11166    -----------------
11167
11168    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
11169       N1 : constant Node_Id := Original_Node (Node1);
11170       N2 : constant Node_Id := Original_Node (Node2);
11171       --  We do the tests on original nodes, since we are most interested
11172       --  in the original source, not any expansion that got in the way.
11173
11174       K1 : constant Node_Kind := Nkind (N1);
11175       K2 : constant Node_Kind := Nkind (N2);
11176
11177    begin
11178       --  First case, both are entities with same entity
11179
11180       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
11181          declare
11182             EN1 : constant Entity_Id := Entity (N1);
11183             EN2 : constant Entity_Id := Entity (N2);
11184          begin
11185             if Present (EN1) and then Present (EN2)
11186               and then (Ekind_In (EN1, E_Variable, E_Constant)
11187                          or else Is_Formal (EN1))
11188               and then EN1 = EN2
11189             then
11190                return True;
11191             end if;
11192          end;
11193       end if;
11194
11195       --  Second case, selected component with same selector, same record
11196
11197       if K1 = N_Selected_Component
11198         and then K2 = N_Selected_Component
11199         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
11200       then
11201          return Same_Object (Prefix (N1), Prefix (N2));
11202
11203       --  Third case, indexed component with same subscripts, same array
11204
11205       elsif K1 = N_Indexed_Component
11206         and then K2 = N_Indexed_Component
11207         and then Same_Object (Prefix (N1), Prefix (N2))
11208       then
11209          declare
11210             E1, E2 : Node_Id;
11211          begin
11212             E1 := First (Expressions (N1));
11213             E2 := First (Expressions (N2));
11214             while Present (E1) loop
11215                if not Same_Value (E1, E2) then
11216                   return False;
11217                else
11218                   Next (E1);
11219                   Next (E2);
11220                end if;
11221             end loop;
11222
11223             return True;
11224          end;
11225
11226       --  Fourth case, slice of same array with same bounds
11227
11228       elsif K1 = N_Slice
11229         and then K2 = N_Slice
11230         and then Nkind (Discrete_Range (N1)) = N_Range
11231         and then Nkind (Discrete_Range (N2)) = N_Range
11232         and then Same_Value (Low_Bound (Discrete_Range (N1)),
11233                              Low_Bound (Discrete_Range (N2)))
11234         and then Same_Value (High_Bound (Discrete_Range (N1)),
11235                              High_Bound (Discrete_Range (N2)))
11236       then
11237          return Same_Name (Prefix (N1), Prefix (N2));
11238
11239       --  All other cases, not clearly the same object
11240
11241       else
11242          return False;
11243       end if;
11244    end Same_Object;
11245
11246    ---------------
11247    -- Same_Type --
11248    ---------------
11249
11250    function Same_Type (T1, T2 : Entity_Id) return Boolean is
11251    begin
11252       if T1 = T2 then
11253          return True;
11254
11255       elsif not Is_Constrained (T1)
11256         and then not Is_Constrained (T2)
11257         and then Base_Type (T1) = Base_Type (T2)
11258       then
11259          return True;
11260
11261       --  For now don't bother with case of identical constraints, to be
11262       --  fiddled with later on perhaps (this is only used for optimization
11263       --  purposes, so it is not critical to do a best possible job)
11264
11265       else
11266          return False;
11267       end if;
11268    end Same_Type;
11269
11270    ----------------
11271    -- Same_Value --
11272    ----------------
11273
11274    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
11275    begin
11276       if Compile_Time_Known_Value (Node1)
11277         and then Compile_Time_Known_Value (Node2)
11278         and then Expr_Value (Node1) = Expr_Value (Node2)
11279       then
11280          return True;
11281       elsif Same_Object (Node1, Node2) then
11282          return True;
11283       else
11284          return False;
11285       end if;
11286    end Same_Value;
11287
11288    -----------------
11289    -- Save_Actual --
11290    -----------------
11291
11292    procedure Save_Actual (N : Node_Id;  Writable : Boolean := False) is
11293    begin
11294       if Ada_Version < Ada_2012 then
11295          return;
11296
11297       elsif Is_Entity_Name (N)
11298         or else
11299           Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
11300         or else
11301           (Nkind (N) = N_Attribute_Reference
11302             and then Attribute_Name (N) = Name_Access)
11303
11304       then
11305          --  We are only interested in IN OUT parameters of inner calls
11306
11307          if not Writable
11308            or else Nkind (Parent (N)) = N_Function_Call
11309            or else Nkind (Parent (N)) in N_Op
11310          then
11311             Actuals_In_Call.Increment_Last;
11312             Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
11313          end if;
11314       end if;
11315    end Save_Actual;
11316
11317    ------------------------
11318    -- Scope_Is_Transient --
11319    ------------------------
11320
11321    function Scope_Is_Transient return Boolean is
11322    begin
11323       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
11324    end Scope_Is_Transient;
11325
11326    ------------------
11327    -- Scope_Within --
11328    ------------------
11329
11330    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
11331       Scop : Entity_Id;
11332
11333    begin
11334       Scop := Scope1;
11335       while Scop /= Standard_Standard loop
11336          Scop := Scope (Scop);
11337
11338          if Scop = Scope2 then
11339             return True;
11340          end if;
11341       end loop;
11342
11343       return False;
11344    end Scope_Within;
11345
11346    --------------------------
11347    -- Scope_Within_Or_Same --
11348    --------------------------
11349
11350    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
11351       Scop : Entity_Id;
11352
11353    begin
11354       Scop := Scope1;
11355       while Scop /= Standard_Standard loop
11356          if Scop = Scope2 then
11357             return True;
11358          else
11359             Scop := Scope (Scop);
11360          end if;
11361       end loop;
11362
11363       return False;
11364    end Scope_Within_Or_Same;
11365
11366    --------------------
11367    -- Set_Convention --
11368    --------------------
11369
11370    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
11371    begin
11372       Basic_Set_Convention (E, Val);
11373
11374       if Is_Type (E)
11375         and then Is_Access_Subprogram_Type (Base_Type (E))
11376         and then Has_Foreign_Convention (E)
11377       then
11378          Set_Can_Use_Internal_Rep (E, False);
11379       end if;
11380    end Set_Convention;
11381
11382    ------------------------
11383    -- Set_Current_Entity --
11384    ------------------------
11385
11386    --  The given entity is to be set as the currently visible definition
11387    --  of its associated name (i.e. the Node_Id associated with its name).
11388    --  All we have to do is to get the name from the identifier, and
11389    --  then set the associated Node_Id to point to the given entity.
11390
11391    procedure Set_Current_Entity (E : Entity_Id) is
11392    begin
11393       Set_Name_Entity_Id (Chars (E), E);
11394    end Set_Current_Entity;
11395
11396    ---------------------------
11397    -- Set_Debug_Info_Needed --
11398    ---------------------------
11399
11400    procedure Set_Debug_Info_Needed (T : Entity_Id) is
11401
11402       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
11403       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
11404       --  Used to set debug info in a related node if not set already
11405
11406       --------------------------------------
11407       -- Set_Debug_Info_Needed_If_Not_Set --
11408       --------------------------------------
11409
11410       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
11411       begin
11412          if Present (E)
11413            and then not Needs_Debug_Info (E)
11414          then
11415             Set_Debug_Info_Needed (E);
11416
11417             --  For a private type, indicate that the full view also needs
11418             --  debug information.
11419
11420             if Is_Type (E)
11421               and then Is_Private_Type (E)
11422               and then Present (Full_View (E))
11423             then
11424                Set_Debug_Info_Needed (Full_View (E));
11425             end if;
11426          end if;
11427       end Set_Debug_Info_Needed_If_Not_Set;
11428
11429    --  Start of processing for Set_Debug_Info_Needed
11430
11431    begin
11432       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
11433       --  indicates that Debug_Info_Needed is never required for the entity.
11434
11435       if No (T)
11436         or else Debug_Info_Off (T)
11437       then
11438          return;
11439       end if;
11440
11441       --  Set flag in entity itself. Note that we will go through the following
11442       --  circuitry even if the flag is already set on T. That's intentional,
11443       --  it makes sure that the flag will be set in subsidiary entities.
11444
11445       Set_Needs_Debug_Info (T);
11446
11447       --  Set flag on subsidiary entities if not set already
11448
11449       if Is_Object (T) then
11450          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
11451
11452       elsif Is_Type (T) then
11453          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
11454
11455          if Is_Record_Type (T) then
11456             declare
11457                Ent : Entity_Id := First_Entity (T);
11458             begin
11459                while Present (Ent) loop
11460                   Set_Debug_Info_Needed_If_Not_Set (Ent);
11461                   Next_Entity (Ent);
11462                end loop;
11463             end;
11464
11465             --  For a class wide subtype, we also need debug information
11466             --  for the equivalent type.
11467
11468             if Ekind (T) = E_Class_Wide_Subtype then
11469                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
11470             end if;
11471
11472          elsif Is_Array_Type (T) then
11473             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
11474
11475             declare
11476                Indx : Node_Id := First_Index (T);
11477             begin
11478                while Present (Indx) loop
11479                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
11480                   Indx := Next_Index (Indx);
11481                end loop;
11482             end;
11483
11484             if Is_Packed (T) then
11485                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
11486             end if;
11487
11488          elsif Is_Access_Type (T) then
11489             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
11490
11491          elsif Is_Private_Type (T) then
11492             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
11493
11494          elsif Is_Protected_Type (T) then
11495             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
11496          end if;
11497       end if;
11498    end Set_Debug_Info_Needed;
11499
11500    ---------------------------------
11501    -- Set_Entity_With_Style_Check --
11502    ---------------------------------
11503
11504    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
11505       Val_Actual : Entity_Id;
11506       Nod        : Node_Id;
11507
11508    begin
11509       Set_Entity (N, Val);
11510
11511       if Style_Check
11512         and then not Suppress_Style_Checks (Val)
11513         and then not In_Instance
11514       then
11515          if Nkind (N) = N_Identifier then
11516             Nod := N;
11517          elsif Nkind (N) = N_Expanded_Name then
11518             Nod := Selector_Name (N);
11519          else
11520             return;
11521          end if;
11522
11523          --  A special situation arises for derived operations, where we want
11524          --  to do the check against the parent (since the Sloc of the derived
11525          --  operation points to the derived type declaration itself).
11526
11527          Val_Actual := Val;
11528          while not Comes_From_Source (Val_Actual)
11529            and then Nkind (Val_Actual) in N_Entity
11530            and then (Ekind (Val_Actual) = E_Enumeration_Literal
11531                       or else Is_Subprogram (Val_Actual)
11532                       or else Is_Generic_Subprogram (Val_Actual))
11533            and then Present (Alias (Val_Actual))
11534          loop
11535             Val_Actual := Alias (Val_Actual);
11536          end loop;
11537
11538          --  Renaming declarations for generic actuals do not come from source,
11539          --  and have a different name from that of the entity they rename, so
11540          --  there is no style check to perform here.
11541
11542          if Chars (Nod) = Chars (Val_Actual) then
11543             Style.Check_Identifier (Nod, Val_Actual);
11544          end if;
11545       end if;
11546
11547       Set_Entity (N, Val);
11548    end Set_Entity_With_Style_Check;
11549
11550    ------------------------
11551    -- Set_Name_Entity_Id --
11552    ------------------------
11553
11554    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
11555    begin
11556       Set_Name_Table_Info (Id, Int (Val));
11557    end Set_Name_Entity_Id;
11558
11559    ---------------------
11560    -- Set_Next_Actual --
11561    ---------------------
11562
11563    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
11564    begin
11565       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
11566          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
11567       end if;
11568    end Set_Next_Actual;
11569
11570    ----------------------------------
11571    -- Set_Optimize_Alignment_Flags --
11572    ----------------------------------
11573
11574    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
11575    begin
11576       if Optimize_Alignment = 'S' then
11577          Set_Optimize_Alignment_Space (E);
11578       elsif Optimize_Alignment = 'T' then
11579          Set_Optimize_Alignment_Time (E);
11580       end if;
11581    end Set_Optimize_Alignment_Flags;
11582
11583    -----------------------
11584    -- Set_Public_Status --
11585    -----------------------
11586
11587    procedure Set_Public_Status (Id : Entity_Id) is
11588       S : constant Entity_Id := Current_Scope;
11589
11590       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
11591       --  Determines if E is defined within handled statement sequence or
11592       --  an if statement, returns True if so, False otherwise.
11593
11594       ----------------------
11595       -- Within_HSS_Or_If --
11596       ----------------------
11597
11598       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
11599          N : Node_Id;
11600       begin
11601          N := Declaration_Node (E);
11602          loop
11603             N := Parent (N);
11604
11605             if No (N) then
11606                return False;
11607
11608             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
11609                                N_If_Statement)
11610             then
11611                return True;
11612             end if;
11613          end loop;
11614       end Within_HSS_Or_If;
11615
11616    --  Start of processing for Set_Public_Status
11617
11618    begin
11619       --  Everything in the scope of Standard is public
11620
11621       if S = Standard_Standard then
11622          Set_Is_Public (Id);
11623
11624       --  Entity is definitely not public if enclosing scope is not public
11625
11626       elsif not Is_Public (S) then
11627          return;
11628
11629       --  An object or function declaration that occurs in a handled sequence
11630       --  of statements or within an if statement is the declaration for a
11631       --  temporary object or local subprogram generated by the expander. It
11632       --  never needs to be made public and furthermore, making it public can
11633       --  cause back end problems.
11634
11635       elsif Nkind_In (Parent (Id), N_Object_Declaration,
11636                                    N_Function_Specification)
11637         and then Within_HSS_Or_If (Id)
11638       then
11639          return;
11640
11641       --  Entities in public packages or records are public
11642
11643       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
11644          Set_Is_Public (Id);
11645
11646       --  The bounds of an entry family declaration can generate object
11647       --  declarations that are visible to the back-end, e.g. in the
11648       --  the declaration of a composite type that contains tasks.
11649
11650       elsif Is_Concurrent_Type (S)
11651         and then not Has_Completion (S)
11652         and then Nkind (Parent (Id)) = N_Object_Declaration
11653       then
11654          Set_Is_Public (Id);
11655       end if;
11656    end Set_Public_Status;
11657
11658    -----------------------------
11659    -- Set_Referenced_Modified --
11660    -----------------------------
11661
11662    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
11663       Pref : Node_Id;
11664
11665    begin
11666       --  Deal with indexed or selected component where prefix is modified
11667
11668       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
11669          Pref := Prefix (N);
11670
11671          --  If prefix is access type, then it is the designated object that is
11672          --  being modified, which means we have no entity to set the flag on.
11673
11674          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
11675             return;
11676
11677             --  Otherwise chase the prefix
11678
11679          else
11680             Set_Referenced_Modified (Pref, Out_Param);
11681          end if;
11682
11683       --  Otherwise see if we have an entity name (only other case to process)
11684
11685       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
11686          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
11687          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
11688       end if;
11689    end Set_Referenced_Modified;
11690
11691    ----------------------------
11692    -- Set_Scope_Is_Transient --
11693    ----------------------------
11694
11695    procedure Set_Scope_Is_Transient (V : Boolean := True) is
11696    begin
11697       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
11698    end Set_Scope_Is_Transient;
11699
11700    -------------------
11701    -- Set_Size_Info --
11702    -------------------
11703
11704    procedure Set_Size_Info (T1, T2 : Entity_Id) is
11705    begin
11706       --  We copy Esize, but not RM_Size, since in general RM_Size is
11707       --  subtype specific and does not get inherited by all subtypes.
11708
11709       Set_Esize                     (T1, Esize                     (T2));
11710       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
11711
11712       if Is_Discrete_Or_Fixed_Point_Type (T1)
11713            and then
11714          Is_Discrete_Or_Fixed_Point_Type (T2)
11715       then
11716          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
11717       end if;
11718
11719       Set_Alignment                 (T1, Alignment                 (T2));
11720    end Set_Size_Info;
11721
11722    --------------------
11723    -- Static_Boolean --
11724    --------------------
11725
11726    function Static_Boolean (N : Node_Id) return Uint is
11727    begin
11728       Analyze_And_Resolve (N, Standard_Boolean);
11729
11730       if N = Error
11731         or else Error_Posted (N)
11732         or else Etype (N) = Any_Type
11733       then
11734          return No_Uint;
11735       end if;
11736
11737       if Is_Static_Expression (N) then
11738          if not Raises_Constraint_Error (N) then
11739             return Expr_Value (N);
11740          else
11741             return No_Uint;
11742          end if;
11743
11744       elsif Etype (N) = Any_Type then
11745          return No_Uint;
11746
11747       else
11748          Flag_Non_Static_Expr
11749            ("static boolean expression required here", N);
11750          return No_Uint;
11751       end if;
11752    end Static_Boolean;
11753
11754    --------------------
11755    -- Static_Integer --
11756    --------------------
11757
11758    function Static_Integer (N : Node_Id) return Uint is
11759    begin
11760       Analyze_And_Resolve (N, Any_Integer);
11761
11762       if N = Error
11763         or else Error_Posted (N)
11764         or else Etype (N) = Any_Type
11765       then
11766          return No_Uint;
11767       end if;
11768
11769       if Is_Static_Expression (N) then
11770          if not Raises_Constraint_Error (N) then
11771             return Expr_Value (N);
11772          else
11773             return No_Uint;
11774          end if;
11775
11776       elsif Etype (N) = Any_Type then
11777          return No_Uint;
11778
11779       else
11780          Flag_Non_Static_Expr
11781            ("static integer expression required here", N);
11782          return No_Uint;
11783       end if;
11784    end Static_Integer;
11785
11786    --------------------------
11787    -- Statically_Different --
11788    --------------------------
11789
11790    function Statically_Different (E1, E2 : Node_Id) return Boolean is
11791       R1 : constant Node_Id := Get_Referenced_Object (E1);
11792       R2 : constant Node_Id := Get_Referenced_Object (E2);
11793    begin
11794       return     Is_Entity_Name (R1)
11795         and then Is_Entity_Name (R2)
11796         and then Entity (R1) /= Entity (R2)
11797         and then not Is_Formal (Entity (R1))
11798         and then not Is_Formal (Entity (R2));
11799    end Statically_Different;
11800
11801    -----------------------------
11802    -- Subprogram_Access_Level --
11803    -----------------------------
11804
11805    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
11806    begin
11807       if Present (Alias (Subp)) then
11808          return Subprogram_Access_Level (Alias (Subp));
11809       else
11810          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
11811       end if;
11812    end Subprogram_Access_Level;
11813
11814    -----------------
11815    -- Trace_Scope --
11816    -----------------
11817
11818    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
11819    begin
11820       if Debug_Flag_W then
11821          for J in 0 .. Scope_Stack.Last loop
11822             Write_Str ("  ");
11823          end loop;
11824
11825          Write_Str (Msg);
11826          Write_Name (Chars (E));
11827          Write_Str (" from ");
11828          Write_Location (Sloc (N));
11829          Write_Eol;
11830       end if;
11831    end Trace_Scope;
11832
11833    -----------------------
11834    -- Transfer_Entities --
11835    -----------------------
11836
11837    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
11838       Ent : Entity_Id := First_Entity (From);
11839
11840    begin
11841       if No (Ent) then
11842          return;
11843       end if;
11844
11845       if (Last_Entity (To)) = Empty then
11846          Set_First_Entity (To, Ent);
11847       else
11848          Set_Next_Entity (Last_Entity (To), Ent);
11849       end if;
11850
11851       Set_Last_Entity (To, Last_Entity (From));
11852
11853       while Present (Ent) loop
11854          Set_Scope (Ent, To);
11855
11856          if not Is_Public (Ent) then
11857             Set_Public_Status (Ent);
11858
11859             if Is_Public (Ent)
11860               and then Ekind (Ent) = E_Record_Subtype
11861
11862             then
11863                --  The components of the propagated Itype must be public
11864                --  as well.
11865
11866                declare
11867                   Comp : Entity_Id;
11868                begin
11869                   Comp := First_Entity (Ent);
11870                   while Present (Comp) loop
11871                      Set_Is_Public (Comp);
11872                      Next_Entity (Comp);
11873                   end loop;
11874                end;
11875             end if;
11876          end if;
11877
11878          Next_Entity (Ent);
11879       end loop;
11880
11881       Set_First_Entity (From, Empty);
11882       Set_Last_Entity (From, Empty);
11883    end Transfer_Entities;
11884
11885    -----------------------
11886    -- Type_Access_Level --
11887    -----------------------
11888
11889    function Type_Access_Level (Typ : Entity_Id) return Uint is
11890       Btyp : Entity_Id;
11891
11892    begin
11893       Btyp := Base_Type (Typ);
11894
11895       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
11896       --  simply use the level where the type is declared. This is true for
11897       --  stand-alone object declarations, and for anonymous access types
11898       --  associated with components the level is the same as that of the
11899       --  enclosing composite type. However, special treatment is needed for
11900       --  the cases of access parameters, return objects of an anonymous access
11901       --  type, and, in Ada 95, access discriminants of limited types.
11902
11903       if Ekind (Btyp) in Access_Kind then
11904          if Ekind (Btyp) = E_Anonymous_Access_Type then
11905
11906             --  If the type is a nonlocal anonymous access type (such as for
11907             --  an access parameter) we treat it as being declared at the
11908             --  library level to ensure that names such as X.all'access don't
11909             --  fail static accessibility checks.
11910
11911             if not Is_Local_Anonymous_Access (Typ) then
11912                return Scope_Depth (Standard_Standard);
11913
11914             --  If this is a return object, the accessibility level is that of
11915             --  the result subtype of the enclosing function. The test here is
11916             --  little complicated, because we have to account for extended
11917             --  return statements that have been rewritten as blocks, in which
11918             --  case we have to find and the Is_Return_Object attribute of the
11919             --  itype's associated object. It would be nice to find a way to
11920             --  simplify this test, but it doesn't seem worthwhile to add a new
11921             --  flag just for purposes of this test. ???
11922
11923             elsif Ekind (Scope (Btyp)) = E_Return_Statement
11924               or else
11925                 (Is_Itype (Btyp)
11926                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
11927                              N_Object_Declaration
11928                   and then Is_Return_Object
11929                              (Defining_Identifier
11930                                 (Associated_Node_For_Itype (Btyp))))
11931             then
11932                declare
11933                   Scop : Entity_Id;
11934
11935                begin
11936                   Scop := Scope (Scope (Btyp));
11937                   while Present (Scop) loop
11938                      exit when Ekind (Scop) = E_Function;
11939                      Scop := Scope (Scop);
11940                   end loop;
11941
11942                   --  Treat the return object's type as having the level of the
11943                   --  function's result subtype (as per RM05-6.5(5.3/2)).
11944
11945                   return Type_Access_Level (Etype (Scop));
11946                end;
11947             end if;
11948          end if;
11949
11950          Btyp := Root_Type (Btyp);
11951
11952          --  The accessibility level of anonymous access types associated with
11953          --  discriminants is that of the current instance of the type, and
11954          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
11955
11956          --  AI-402: access discriminants have accessibility based on the
11957          --  object rather than the type in Ada 2005, so the above paragraph
11958          --  doesn't apply.
11959
11960          --  ??? Needs completion with rules from AI-416
11961
11962          if Ada_Version <= Ada_95
11963            and then Ekind (Typ) = E_Anonymous_Access_Type
11964            and then Present (Associated_Node_For_Itype (Typ))
11965            and then Nkind (Associated_Node_For_Itype (Typ)) =
11966                                                  N_Discriminant_Specification
11967          then
11968             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
11969          end if;
11970       end if;
11971
11972       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
11973    end Type_Access_Level;
11974
11975    --------------------------
11976    -- Unit_Declaration_Node --
11977    --------------------------
11978
11979    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
11980       N : Node_Id := Parent (Unit_Id);
11981
11982    begin
11983       --  Predefined operators do not have a full function declaration
11984
11985       if Ekind (Unit_Id) = E_Operator then
11986          return N;
11987       end if;
11988
11989       --  Isn't there some better way to express the following ???
11990
11991       while Nkind (N) /= N_Abstract_Subprogram_Declaration
11992         and then Nkind (N) /= N_Formal_Package_Declaration
11993         and then Nkind (N) /= N_Function_Instantiation
11994         and then Nkind (N) /= N_Generic_Package_Declaration
11995         and then Nkind (N) /= N_Generic_Subprogram_Declaration
11996         and then Nkind (N) /= N_Package_Declaration
11997         and then Nkind (N) /= N_Package_Body
11998         and then Nkind (N) /= N_Package_Instantiation
11999         and then Nkind (N) /= N_Package_Renaming_Declaration
12000         and then Nkind (N) /= N_Procedure_Instantiation
12001         and then Nkind (N) /= N_Protected_Body
12002         and then Nkind (N) /= N_Subprogram_Declaration
12003         and then Nkind (N) /= N_Subprogram_Body
12004         and then Nkind (N) /= N_Subprogram_Body_Stub
12005         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
12006         and then Nkind (N) /= N_Task_Body
12007         and then Nkind (N) /= N_Task_Type_Declaration
12008         and then Nkind (N) not in N_Formal_Subprogram_Declaration
12009         and then Nkind (N) not in N_Generic_Renaming_Declaration
12010       loop
12011          N := Parent (N);
12012          pragma Assert (Present (N));
12013       end loop;
12014
12015       return N;
12016    end Unit_Declaration_Node;
12017
12018    ---------------------
12019    -- Unit_Is_Visible --
12020    ---------------------
12021
12022    function Unit_Is_Visible (U : Entity_Id) return Boolean is
12023       Curr        : constant Node_Id   := Cunit (Current_Sem_Unit);
12024       Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
12025
12026       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
12027       --  For a child unit, check whether unit appears in a with_clause
12028       --  of a parent.
12029
12030       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
12031       --  Scan the context clause of one compilation unit looking for a
12032       --  with_clause for the unit in question.
12033
12034       ----------------------------
12035       -- Unit_In_Parent_Context --
12036       ----------------------------
12037
12038       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
12039       begin
12040          if Unit_In_Context (Par_Unit) then
12041             return True;
12042
12043          elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
12044             return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
12045
12046          else
12047             return False;
12048          end if;
12049       end Unit_In_Parent_Context;
12050
12051       ---------------------
12052       -- Unit_In_Context --
12053       ---------------------
12054
12055       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
12056          Clause : Node_Id;
12057
12058       begin
12059          Clause := First (Context_Items (Comp_Unit));
12060          while Present (Clause) loop
12061             if Nkind (Clause) = N_With_Clause then
12062                if Library_Unit (Clause) = U then
12063                   return True;
12064
12065                --  The with_clause may denote a renaming of the unit we are
12066                --  looking for, eg. Text_IO which renames Ada.Text_IO.
12067
12068                elsif
12069                  Renamed_Entity (Entity (Name (Clause))) =
12070                                                 Defining_Entity (Unit (U))
12071                then
12072                   return True;
12073                end if;
12074             end if;
12075
12076             Next (Clause);
12077          end loop;
12078
12079          return False;
12080       end Unit_In_Context;
12081
12082    --  Start of processing for Unit_Is_Visible
12083
12084    begin
12085       --  The currrent unit is directly visible.
12086
12087       if Curr = U then
12088          return True;
12089
12090       elsif Unit_In_Context (Curr) then
12091          return True;
12092
12093       --  If the current unit is a body, check the context of the spec.
12094
12095       elsif Nkind (Unit (Curr)) = N_Package_Body
12096         or else
12097           (Nkind (Unit (Curr)) = N_Subprogram_Body
12098             and then not Acts_As_Spec (Unit (Curr)))
12099       then
12100          if Unit_In_Context (Library_Unit (Curr)) then
12101             return True;
12102          end if;
12103       end if;
12104
12105       --  If the spec is a child unit, examine the parents.
12106
12107       if Is_Child_Unit (Curr_Entity) then
12108          if Nkind (Unit (Curr)) in N_Unit_Body then
12109             return
12110               Unit_In_Parent_Context
12111                 (Parent_Spec (Unit (Library_Unit (Curr))));
12112          else
12113             return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
12114          end if;
12115
12116       else
12117          return False;
12118       end if;
12119    end Unit_Is_Visible;
12120
12121    ------------------------------
12122    -- Universal_Interpretation --
12123    ------------------------------
12124
12125    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
12126       Index : Interp_Index;
12127       It    : Interp;
12128
12129    begin
12130       --  The argument may be a formal parameter of an operator or subprogram
12131       --  with multiple interpretations, or else an expression for an actual.
12132
12133       if Nkind (Opnd) = N_Defining_Identifier
12134         or else not Is_Overloaded (Opnd)
12135       then
12136          if Etype (Opnd) = Universal_Integer
12137            or else Etype (Opnd) = Universal_Real
12138          then
12139             return Etype (Opnd);
12140          else
12141             return Empty;
12142          end if;
12143
12144       else
12145          Get_First_Interp (Opnd, Index, It);
12146          while Present (It.Typ) loop
12147             if It.Typ = Universal_Integer
12148               or else It.Typ = Universal_Real
12149             then
12150                return It.Typ;
12151             end if;
12152
12153             Get_Next_Interp (Index, It);
12154          end loop;
12155
12156          return Empty;
12157       end if;
12158    end Universal_Interpretation;
12159
12160    ---------------
12161    -- Unqualify --
12162    ---------------
12163
12164    function Unqualify (Expr : Node_Id) return Node_Id is
12165    begin
12166       --  Recurse to handle unlikely case of multiple levels of qualification
12167
12168       if Nkind (Expr) = N_Qualified_Expression then
12169          return Unqualify (Expression (Expr));
12170
12171       --  Normal case, not a qualified expression
12172
12173       else
12174          return Expr;
12175       end if;
12176    end Unqualify;
12177
12178    -----------------------
12179    -- Visible_Ancestors --
12180    -----------------------
12181
12182    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
12183       List_1 : Elist_Id;
12184       List_2 : Elist_Id;
12185       Elmt   : Elmt_Id;
12186
12187    begin
12188       pragma Assert (Is_Record_Type (Typ)
12189         and then Is_Tagged_Type (Typ));
12190
12191       --  Collect all the parents and progenitors of Typ. If the full-view of
12192       --  private parents and progenitors is available then it is used to
12193       --  generate the list of visible ancestors; otherwise their partial
12194       --  view is added to the resulting list.
12195
12196       Collect_Parents
12197         (T               => Typ,
12198          List            => List_1,
12199          Use_Full_View   => True);
12200
12201       Collect_Interfaces
12202         (T               => Typ,
12203          Ifaces_List     => List_2,
12204          Exclude_Parents => True,
12205          Use_Full_View   => True);
12206
12207       --  Join the two lists. Avoid duplications because an interface may
12208       --  simultaneously be parent and progenitor of a type.
12209
12210       Elmt := First_Elmt (List_2);
12211       while Present (Elmt) loop
12212          Append_Unique_Elmt (Node (Elmt), List_1);
12213          Next_Elmt (Elmt);
12214       end loop;
12215
12216       return List_1;
12217    end Visible_Ancestors;
12218
12219    ----------------------
12220    -- Within_Init_Proc --
12221    ----------------------
12222
12223    function Within_Init_Proc return Boolean is
12224       S : Entity_Id;
12225
12226    begin
12227       S := Current_Scope;
12228       while not Is_Overloadable (S) loop
12229          if S = Standard_Standard then
12230             return False;
12231          else
12232             S := Scope (S);
12233          end if;
12234       end loop;
12235
12236       return Is_Init_Proc (S);
12237    end Within_Init_Proc;
12238
12239    ----------------
12240    -- Wrong_Type --
12241    ----------------
12242
12243    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
12244       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
12245       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
12246
12247       function Has_One_Matching_Field return Boolean;
12248       --  Determines if Expec_Type is a record type with a single component or
12249       --  discriminant whose type matches the found type or is one dimensional
12250       --  array whose component type matches the found type.
12251
12252       ----------------------------
12253       -- Has_One_Matching_Field --
12254       ----------------------------
12255
12256       function Has_One_Matching_Field return Boolean is
12257          E : Entity_Id;
12258
12259       begin
12260          if Is_Array_Type (Expec_Type)
12261            and then Number_Dimensions (Expec_Type) = 1
12262            and then
12263              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
12264          then
12265             return True;
12266
12267          elsif not Is_Record_Type (Expec_Type) then
12268             return False;
12269
12270          else
12271             E := First_Entity (Expec_Type);
12272             loop
12273                if No (E) then
12274                   return False;
12275
12276                elsif (Ekind (E) /= E_Discriminant
12277                        and then Ekind (E) /= E_Component)
12278                  or else (Chars (E) = Name_uTag
12279                            or else Chars (E) = Name_uParent)
12280                then
12281                   Next_Entity (E);
12282
12283                else
12284                   exit;
12285                end if;
12286             end loop;
12287
12288             if not Covers (Etype (E), Found_Type) then
12289                return False;
12290
12291             elsif Present (Next_Entity (E)) then
12292                return False;
12293
12294             else
12295                return True;
12296             end if;
12297          end if;
12298       end Has_One_Matching_Field;
12299
12300    --  Start of processing for Wrong_Type
12301
12302    begin
12303       --  Don't output message if either type is Any_Type, or if a message
12304       --  has already been posted for this node. We need to do the latter
12305       --  check explicitly (it is ordinarily done in Errout), because we
12306       --  are using ! to force the output of the error messages.
12307
12308       if Expec_Type = Any_Type
12309         or else Found_Type = Any_Type
12310         or else Error_Posted (Expr)
12311       then
12312          return;
12313
12314       --  In  an instance, there is an ongoing problem with completion of
12315       --  type derived from private types. Their structure is what Gigi
12316       --  expects, but the  Etype is the parent type rather than the
12317       --  derived private type itself. Do not flag error in this case. The
12318       --  private completion is an entity without a parent, like an Itype.
12319       --  Similarly, full and partial views may be incorrect in the instance.
12320       --  There is no simple way to insure that it is consistent ???
12321
12322       elsif In_Instance then
12323          if Etype (Etype (Expr)) = Etype (Expected_Type)
12324            and then
12325              (Has_Private_Declaration (Expected_Type)
12326                or else Has_Private_Declaration (Etype (Expr)))
12327            and then No (Parent (Expected_Type))
12328          then
12329             return;
12330          end if;
12331       end if;
12332
12333       --  An interesting special check. If the expression is parenthesized
12334       --  and its type corresponds to the type of the sole component of the
12335       --  expected record type, or to the component type of the expected one
12336       --  dimensional array type, then assume we have a bad aggregate attempt.
12337
12338       if Nkind (Expr) in N_Subexpr
12339         and then Paren_Count (Expr) /= 0
12340         and then Has_One_Matching_Field
12341       then
12342          Error_Msg_N ("positional aggregate cannot have one component", Expr);
12343
12344       --  Another special check, if we are looking for a pool-specific access
12345       --  type and we found an E_Access_Attribute_Type, then we have the case
12346       --  of an Access attribute being used in a context which needs a pool-
12347       --  specific type, which is never allowed. The one extra check we make
12348       --  is that the expected designated type covers the Found_Type.
12349
12350       elsif Is_Access_Type (Expec_Type)
12351         and then Ekind (Found_Type) = E_Access_Attribute_Type
12352         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
12353         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
12354         and then Covers
12355           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
12356       then
12357          Error_Msg_N -- CODEFIX
12358            ("result must be general access type!", Expr);
12359          Error_Msg_NE -- CODEFIX
12360            ("add ALL to }!", Expr, Expec_Type);
12361
12362       --  Another special check, if the expected type is an integer type,
12363       --  but the expression is of type System.Address, and the parent is
12364       --  an addition or subtraction operation whose left operand is the
12365       --  expression in question and whose right operand is of an integral
12366       --  type, then this is an attempt at address arithmetic, so give
12367       --  appropriate message.
12368
12369       elsif Is_Integer_Type (Expec_Type)
12370         and then Is_RTE (Found_Type, RE_Address)
12371         and then (Nkind (Parent (Expr)) = N_Op_Add
12372                     or else
12373                   Nkind (Parent (Expr)) = N_Op_Subtract)
12374         and then Expr = Left_Opnd (Parent (Expr))
12375         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
12376       then
12377          Error_Msg_N
12378            ("address arithmetic not predefined in package System",
12379             Parent (Expr));
12380          Error_Msg_N
12381            ("\possible missing with/use of System.Storage_Elements",
12382             Parent (Expr));
12383          return;
12384
12385       --  If the expected type is an anonymous access type, as for access
12386       --  parameters and discriminants, the error is on the designated types.
12387
12388       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
12389          if Comes_From_Source (Expec_Type) then
12390             Error_Msg_NE ("expected}!", Expr, Expec_Type);
12391          else
12392             Error_Msg_NE
12393               ("expected an access type with designated}",
12394                  Expr, Designated_Type (Expec_Type));
12395          end if;
12396
12397          if Is_Access_Type (Found_Type)
12398            and then not Comes_From_Source (Found_Type)
12399          then
12400             Error_Msg_NE
12401               ("\\found an access type with designated}!",
12402                 Expr, Designated_Type (Found_Type));
12403          else
12404             if From_With_Type (Found_Type) then
12405                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
12406                Error_Msg_Qual_Level := 99;
12407                Error_Msg_NE -- CODEFIX
12408                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
12409                Error_Msg_Qual_Level := 0;
12410             else
12411                Error_Msg_NE ("found}!", Expr, Found_Type);
12412             end if;
12413          end if;
12414
12415       --  Normal case of one type found, some other type expected
12416
12417       else
12418          --  If the names of the two types are the same, see if some number
12419          --  of levels of qualification will help. Don't try more than three
12420          --  levels, and if we get to standard, it's no use (and probably
12421          --  represents an error in the compiler) Also do not bother with
12422          --  internal scope names.
12423
12424          declare
12425             Expec_Scope : Entity_Id;
12426             Found_Scope : Entity_Id;
12427
12428          begin
12429             Expec_Scope := Expec_Type;
12430             Found_Scope := Found_Type;
12431
12432             for Levels in Int range 0 .. 3 loop
12433                if Chars (Expec_Scope) /= Chars (Found_Scope) then
12434                   Error_Msg_Qual_Level := Levels;
12435                   exit;
12436                end if;
12437
12438                Expec_Scope := Scope (Expec_Scope);
12439                Found_Scope := Scope (Found_Scope);
12440
12441                exit when Expec_Scope = Standard_Standard
12442                  or else Found_Scope = Standard_Standard
12443                  or else not Comes_From_Source (Expec_Scope)
12444                  or else not Comes_From_Source (Found_Scope);
12445             end loop;
12446          end;
12447
12448          if Is_Record_Type (Expec_Type)
12449            and then Present (Corresponding_Remote_Type (Expec_Type))
12450          then
12451             Error_Msg_NE ("expected}!", Expr,
12452                           Corresponding_Remote_Type (Expec_Type));
12453          else
12454             Error_Msg_NE ("expected}!", Expr, Expec_Type);
12455          end if;
12456
12457          if Is_Entity_Name (Expr)
12458            and then Is_Package_Or_Generic_Package (Entity (Expr))
12459          then
12460             Error_Msg_N ("\\found package name!", Expr);
12461
12462          elsif Is_Entity_Name (Expr)
12463            and then
12464              (Ekind (Entity (Expr)) = E_Procedure
12465                 or else
12466               Ekind (Entity (Expr)) = E_Generic_Procedure)
12467          then
12468             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
12469                Error_Msg_N
12470                  ("found procedure name, possibly missing Access attribute!",
12471                    Expr);
12472             else
12473                Error_Msg_N
12474                  ("\\found procedure name instead of function!", Expr);
12475             end if;
12476
12477          elsif Nkind (Expr) = N_Function_Call
12478            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
12479            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
12480            and then No (Parameter_Associations (Expr))
12481          then
12482             Error_Msg_N
12483               ("found function name, possibly missing Access attribute!",
12484                Expr);
12485
12486          --  Catch common error: a prefix or infix operator which is not
12487          --  directly visible because the type isn't.
12488
12489          elsif Nkind (Expr) in N_Op
12490             and then Is_Overloaded (Expr)
12491             and then not Is_Immediately_Visible (Expec_Type)
12492             and then not Is_Potentially_Use_Visible (Expec_Type)
12493             and then not In_Use (Expec_Type)
12494             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
12495          then
12496             Error_Msg_N
12497               ("operator of the type is not directly visible!", Expr);
12498
12499          elsif Ekind (Found_Type) = E_Void
12500            and then Present (Parent (Found_Type))
12501            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
12502          then
12503             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
12504
12505          else
12506             Error_Msg_NE ("\\found}!", Expr, Found_Type);
12507          end if;
12508
12509          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
12510          --  of the same modular type, and (M1 and M2) = 0 was intended.
12511
12512          if Expec_Type = Standard_Boolean
12513            and then Is_Modular_Integer_Type (Found_Type)
12514            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
12515            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
12516          then
12517             declare
12518                Op : constant Node_Id := Right_Opnd (Parent (Expr));
12519                L  : constant Node_Id := Left_Opnd (Op);
12520                R  : constant Node_Id := Right_Opnd (Op);
12521             begin
12522                --  The case for the message is when the left operand of the
12523                --  comparison is the same modular type, or when it is an
12524                --  integer literal (or other universal integer expression),
12525                --  which would have been typed as the modular type if the
12526                --  parens had been there.
12527
12528                if (Etype (L) = Found_Type
12529                      or else
12530                    Etype (L) = Universal_Integer)
12531                  and then Is_Integer_Type (Etype (R))
12532                then
12533                   Error_Msg_N
12534                     ("\\possible missing parens for modular operation", Expr);
12535                end if;
12536             end;
12537          end if;
12538
12539          --  Reset error message qualification indication
12540
12541          Error_Msg_Qual_Level := 0;
12542       end if;
12543    end Wrong_Type;
12544
12545 end Sem_Util;