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_Expression_Function --
6546    ----------------------------
6547
6548    function Is_Expression_Function (Subp : Entity_Id) return Boolean is
6549       Decl : constant Node_Id := Unit_Declaration_Node (Subp);
6550
6551    begin
6552       return Ekind (Subp) = E_Function
6553         and then Nkind (Decl) = N_Subprogram_Declaration
6554         and then
6555           (Nkind (Original_Node (Decl)) = N_Expression_Function
6556             or else
6557               (Present (Corresponding_Body (Decl))
6558                 and then
6559                   Nkind (Original_Node
6560                      (Unit_Declaration_Node (Corresponding_Body (Decl))))
6561                  = N_Expression_Function));
6562    end Is_Expression_Function;
6563
6564    --------------
6565    -- Is_False --
6566    --------------
6567
6568    function Is_False (U : Uint) return Boolean is
6569    begin
6570       return (U = 0);
6571    end Is_False;
6572
6573    ---------------------------
6574    -- Is_Fixed_Model_Number --
6575    ---------------------------
6576
6577    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
6578       S : constant Ureal := Small_Value (T);
6579       M : Urealp.Save_Mark;
6580       R : Boolean;
6581    begin
6582       M := Urealp.Mark;
6583       R := (U = UR_Trunc (U / S) * S);
6584       Urealp.Release (M);
6585       return R;
6586    end Is_Fixed_Model_Number;
6587
6588    -------------------------------
6589    -- Is_Fully_Initialized_Type --
6590    -------------------------------
6591
6592    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
6593    begin
6594       if Is_Scalar_Type (Typ) then
6595          return False;
6596
6597       elsif Is_Access_Type (Typ) then
6598          return True;
6599
6600       elsif Is_Array_Type (Typ) then
6601          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
6602             return True;
6603          end if;
6604
6605          --  An interesting case, if we have a constrained type one of whose
6606          --  bounds is known to be null, then there are no elements to be
6607          --  initialized, so all the elements are initialized!
6608
6609          if Is_Constrained (Typ) then
6610             declare
6611                Indx     : Node_Id;
6612                Indx_Typ : Entity_Id;
6613                Lbd, Hbd : Node_Id;
6614
6615             begin
6616                Indx := First_Index (Typ);
6617                while Present (Indx) loop
6618                   if Etype (Indx) = Any_Type then
6619                      return False;
6620
6621                   --  If index is a range, use directly
6622
6623                   elsif Nkind (Indx) = N_Range then
6624                      Lbd := Low_Bound  (Indx);
6625                      Hbd := High_Bound (Indx);
6626
6627                   else
6628                      Indx_Typ := Etype (Indx);
6629
6630                      if Is_Private_Type (Indx_Typ)  then
6631                         Indx_Typ := Full_View (Indx_Typ);
6632                      end if;
6633
6634                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
6635                         return False;
6636                      else
6637                         Lbd := Type_Low_Bound  (Indx_Typ);
6638                         Hbd := Type_High_Bound (Indx_Typ);
6639                      end if;
6640                   end if;
6641
6642                   if Compile_Time_Known_Value (Lbd)
6643                     and then Compile_Time_Known_Value (Hbd)
6644                   then
6645                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
6646                         return True;
6647                      end if;
6648                   end if;
6649
6650                   Next_Index (Indx);
6651                end loop;
6652             end;
6653          end if;
6654
6655          --  If no null indexes, then type is not fully initialized
6656
6657          return False;
6658
6659       --  Record types
6660
6661       elsif Is_Record_Type (Typ) then
6662          if Has_Discriminants (Typ)
6663            and then
6664              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
6665            and then Is_Fully_Initialized_Variant (Typ)
6666          then
6667             return True;
6668          end if;
6669
6670          --  Controlled records are considered to be fully initialized if
6671          --  there is a user defined Initialize routine. This may not be
6672          --  entirely correct, but as the spec notes, we are guessing here
6673          --  what is best from the point of view of issuing warnings.
6674
6675          if Is_Controlled (Typ) then
6676             declare
6677                Utyp : constant Entity_Id := Underlying_Type (Typ);
6678
6679             begin
6680                if Present (Utyp) then
6681                   declare
6682                      Init : constant Entity_Id :=
6683                               (Find_Prim_Op
6684                                  (Underlying_Type (Typ), Name_Initialize));
6685
6686                   begin
6687                      if Present (Init)
6688                        and then Comes_From_Source (Init)
6689                        and then not
6690                          Is_Predefined_File_Name
6691                            (File_Name (Get_Source_File_Index (Sloc (Init))))
6692                      then
6693                         return True;
6694
6695                      elsif Has_Null_Extension (Typ)
6696                         and then
6697                           Is_Fully_Initialized_Type
6698                             (Etype (Base_Type (Typ)))
6699                      then
6700                         return True;
6701                      end if;
6702                   end;
6703                end if;
6704             end;
6705          end if;
6706
6707          --  Otherwise see if all record components are initialized
6708
6709          declare
6710             Ent : Entity_Id;
6711
6712          begin
6713             Ent := First_Entity (Typ);
6714             while Present (Ent) loop
6715                if Chars (Ent) = Name_uController then
6716                   null;
6717
6718                elsif Ekind (Ent) = E_Component
6719                  and then (No (Parent (Ent))
6720                              or else No (Expression (Parent (Ent))))
6721                  and then not Is_Fully_Initialized_Type (Etype (Ent))
6722
6723                   --  Special VM case for tag components, which need to be
6724                   --  defined in this case, but are never initialized as VMs
6725                   --  are using other dispatching mechanisms. Ignore this
6726                   --  uninitialized case. Note that this applies both to the
6727                   --  uTag entry and the main vtable pointer (CPP_Class case).
6728
6729                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
6730                then
6731                   return False;
6732                end if;
6733
6734                Next_Entity (Ent);
6735             end loop;
6736          end;
6737
6738          --  No uninitialized components, so type is fully initialized.
6739          --  Note that this catches the case of no components as well.
6740
6741          return True;
6742
6743       elsif Is_Concurrent_Type (Typ) then
6744          return True;
6745
6746       elsif Is_Private_Type (Typ) then
6747          declare
6748             U : constant Entity_Id := Underlying_Type (Typ);
6749
6750          begin
6751             if No (U) then
6752                return False;
6753             else
6754                return Is_Fully_Initialized_Type (U);
6755             end if;
6756          end;
6757
6758       else
6759          return False;
6760       end if;
6761    end Is_Fully_Initialized_Type;
6762
6763    ----------------------------------
6764    -- Is_Fully_Initialized_Variant --
6765    ----------------------------------
6766
6767    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
6768       Loc           : constant Source_Ptr := Sloc (Typ);
6769       Constraints   : constant List_Id    := New_List;
6770       Components    : constant Elist_Id   := New_Elmt_List;
6771       Comp_Elmt     : Elmt_Id;
6772       Comp_Id       : Node_Id;
6773       Comp_List     : Node_Id;
6774       Discr         : Entity_Id;
6775       Discr_Val     : Node_Id;
6776
6777       Report_Errors : Boolean;
6778       pragma Warnings (Off, Report_Errors);
6779
6780    begin
6781       if Serious_Errors_Detected > 0 then
6782          return False;
6783       end if;
6784
6785       if Is_Record_Type (Typ)
6786         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
6787         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
6788       then
6789          Comp_List := Component_List (Type_Definition (Parent (Typ)));
6790
6791          Discr := First_Discriminant (Typ);
6792          while Present (Discr) loop
6793             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
6794                Discr_Val := Expression (Parent (Discr));
6795
6796                if Present (Discr_Val)
6797                  and then Is_OK_Static_Expression (Discr_Val)
6798                then
6799                   Append_To (Constraints,
6800                     Make_Component_Association (Loc,
6801                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
6802                       Expression => New_Copy (Discr_Val)));
6803                else
6804                   return False;
6805                end if;
6806             else
6807                return False;
6808             end if;
6809
6810             Next_Discriminant (Discr);
6811          end loop;
6812
6813          Gather_Components
6814            (Typ           => Typ,
6815             Comp_List     => Comp_List,
6816             Governed_By   => Constraints,
6817             Into          => Components,
6818             Report_Errors => Report_Errors);
6819
6820          --  Check that each component present is fully initialized
6821
6822          Comp_Elmt := First_Elmt (Components);
6823          while Present (Comp_Elmt) loop
6824             Comp_Id := Node (Comp_Elmt);
6825
6826             if Ekind (Comp_Id) = E_Component
6827               and then (No (Parent (Comp_Id))
6828                          or else No (Expression (Parent (Comp_Id))))
6829               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
6830             then
6831                return False;
6832             end if;
6833
6834             Next_Elmt (Comp_Elmt);
6835          end loop;
6836
6837          return True;
6838
6839       elsif Is_Private_Type (Typ) then
6840          declare
6841             U : constant Entity_Id := Underlying_Type (Typ);
6842
6843          begin
6844             if No (U) then
6845                return False;
6846             else
6847                return Is_Fully_Initialized_Variant (U);
6848             end if;
6849          end;
6850       else
6851          return False;
6852       end if;
6853    end Is_Fully_Initialized_Variant;
6854
6855    ------------
6856    -- Is_LHS --
6857    ------------
6858
6859    --  We seem to have a lot of overlapping functions that do similar things
6860    --  (testing for left hand sides or lvalues???). Anyway, since this one is
6861    --  purely syntactic, it should be in Sem_Aux I would think???
6862
6863    function Is_LHS (N : Node_Id) return Boolean is
6864       P : constant Node_Id := Parent (N);
6865
6866    begin
6867       if Nkind (P) = N_Assignment_Statement then
6868          return Name (P) = N;
6869
6870       elsif
6871         Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
6872       then
6873          return N = Prefix (P) and then Is_LHS (P);
6874
6875       else
6876          return False;
6877       end if;
6878    end Is_LHS;
6879
6880    ----------------------------
6881    -- Is_Inherited_Operation --
6882    ----------------------------
6883
6884    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
6885       Kind : constant Node_Kind := Nkind (Parent (E));
6886    begin
6887       pragma Assert (Is_Overloadable (E));
6888       return Kind = N_Full_Type_Declaration
6889         or else Kind = N_Private_Extension_Declaration
6890         or else Kind = N_Subtype_Declaration
6891         or else (Ekind (E) = E_Enumeration_Literal
6892                   and then Is_Derived_Type (Etype (E)));
6893    end Is_Inherited_Operation;
6894
6895    -------------------------------------
6896    -- Is_Inherited_Operation_For_Type --
6897    -------------------------------------
6898
6899    function Is_Inherited_Operation_For_Type
6900      (E : Entity_Id; Typ : Entity_Id) return Boolean
6901    is
6902    begin
6903       return Is_Inherited_Operation (E)
6904         and then Etype (Parent (E)) = Typ;
6905    end Is_Inherited_Operation_For_Type;
6906
6907    -----------------------------
6908    -- Is_Library_Level_Entity --
6909    -----------------------------
6910
6911    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
6912    begin
6913       --  The following is a small optimization, and it also properly handles
6914       --  discriminals, which in task bodies might appear in expressions before
6915       --  the corresponding procedure has been created, and which therefore do
6916       --  not have an assigned scope.
6917
6918       if Is_Formal (E) then
6919          return False;
6920       end if;
6921
6922       --  Normal test is simply that the enclosing dynamic scope is Standard
6923
6924       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
6925    end Is_Library_Level_Entity;
6926
6927    ---------------------------------
6928    -- Is_Local_Variable_Reference --
6929    ---------------------------------
6930
6931    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
6932    begin
6933       if not Is_Entity_Name (Expr) then
6934          return False;
6935
6936       else
6937          declare
6938             Ent : constant Entity_Id := Entity (Expr);
6939             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
6940          begin
6941             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
6942                return False;
6943             else
6944                return Present (Sub) and then Sub = Current_Subprogram;
6945             end if;
6946          end;
6947       end if;
6948    end Is_Local_Variable_Reference;
6949
6950    -------------------------
6951    -- Is_Object_Reference --
6952    -------------------------
6953
6954    function Is_Object_Reference (N : Node_Id) return Boolean is
6955    begin
6956       if Is_Entity_Name (N) then
6957          return Present (Entity (N)) and then Is_Object (Entity (N));
6958
6959       else
6960          case Nkind (N) is
6961             when N_Indexed_Component | N_Slice =>
6962                return
6963                  Is_Object_Reference (Prefix (N))
6964                    or else Is_Access_Type (Etype (Prefix (N)));
6965
6966             --  In Ada95, a function call is a constant object; a procedure
6967             --  call is not.
6968
6969             when N_Function_Call =>
6970                return Etype (N) /= Standard_Void_Type;
6971
6972             --  A reference to the stream attribute Input is a function call
6973
6974             when N_Attribute_Reference =>
6975                return Attribute_Name (N) = Name_Input;
6976
6977             when N_Selected_Component =>
6978                return
6979                  Is_Object_Reference (Selector_Name (N))
6980                    and then
6981                      (Is_Object_Reference (Prefix (N))
6982                         or else Is_Access_Type (Etype (Prefix (N))));
6983
6984             when N_Explicit_Dereference =>
6985                return True;
6986
6987             --  A view conversion of a tagged object is an object reference
6988
6989             when N_Type_Conversion =>
6990                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
6991                  and then Is_Tagged_Type (Etype (Expression (N)))
6992                  and then Is_Object_Reference (Expression (N));
6993
6994             --  An unchecked type conversion is considered to be an object if
6995             --  the operand is an object (this construction arises only as a
6996             --  result of expansion activities).
6997
6998             when N_Unchecked_Type_Conversion =>
6999                return True;
7000
7001             when others =>
7002                return False;
7003          end case;
7004       end if;
7005    end Is_Object_Reference;
7006
7007    -----------------------------------
7008    -- Is_OK_Variable_For_Out_Formal --
7009    -----------------------------------
7010
7011    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
7012    begin
7013       Note_Possible_Modification (AV, Sure => True);
7014
7015       --  We must reject parenthesized variable names. The check for
7016       --  Comes_From_Source is present because there are currently
7017       --  cases where the compiler violates this rule (e.g. passing
7018       --  a task object to its controlled Initialize routine).
7019
7020       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
7021          return False;
7022
7023       --  A variable is always allowed
7024
7025       elsif Is_Variable (AV) then
7026          return True;
7027
7028       --  Unchecked conversions are allowed only if they come from the
7029       --  generated code, which sometimes uses unchecked conversions for out
7030       --  parameters in cases where code generation is unaffected. We tell
7031       --  source unchecked conversions by seeing if they are rewrites of an
7032       --  original Unchecked_Conversion function call, or of an explicit
7033       --  conversion of a function call.
7034
7035       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
7036          if Nkind (Original_Node (AV)) = N_Function_Call then
7037             return False;
7038
7039          elsif Comes_From_Source (AV)
7040            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
7041          then
7042             return False;
7043
7044          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
7045             return Is_OK_Variable_For_Out_Formal (Expression (AV));
7046
7047          else
7048             return True;
7049          end if;
7050
7051       --  Normal type conversions are allowed if argument is a variable
7052
7053       elsif Nkind (AV) = N_Type_Conversion then
7054          if Is_Variable (Expression (AV))
7055            and then Paren_Count (Expression (AV)) = 0
7056          then
7057             Note_Possible_Modification (Expression (AV), Sure => True);
7058             return True;
7059
7060          --  We also allow a non-parenthesized expression that raises
7061          --  constraint error if it rewrites what used to be a variable
7062
7063          elsif Raises_Constraint_Error (Expression (AV))
7064             and then Paren_Count (Expression (AV)) = 0
7065             and then Is_Variable (Original_Node (Expression (AV)))
7066          then
7067             return True;
7068
7069          --  Type conversion of something other than a variable
7070
7071          else
7072             return False;
7073          end if;
7074
7075       --  If this node is rewritten, then test the original form, if that is
7076       --  OK, then we consider the rewritten node OK (for example, if the
7077       --  original node is a conversion, then Is_Variable will not be true
7078       --  but we still want to allow the conversion if it converts a variable).
7079
7080       elsif Original_Node (AV) /= AV then
7081          return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
7082
7083       --  All other non-variables are rejected
7084
7085       else
7086          return False;
7087       end if;
7088    end Is_OK_Variable_For_Out_Formal;
7089
7090    -----------------------------------
7091    -- Is_Partially_Initialized_Type --
7092    -----------------------------------
7093
7094    function Is_Partially_Initialized_Type
7095      (Typ              : Entity_Id;
7096       Include_Implicit : Boolean := True) return Boolean
7097    is
7098    begin
7099       if Is_Scalar_Type (Typ) then
7100          return False;
7101
7102       elsif Is_Access_Type (Typ) then
7103          return Include_Implicit;
7104
7105       elsif Is_Array_Type (Typ) then
7106
7107          --  If component type is partially initialized, so is array type
7108
7109          if Is_Partially_Initialized_Type
7110               (Component_Type (Typ), Include_Implicit)
7111          then
7112             return True;
7113
7114          --  Otherwise we are only partially initialized if we are fully
7115          --  initialized (this is the empty array case, no point in us
7116          --  duplicating that code here).
7117
7118          else
7119             return Is_Fully_Initialized_Type (Typ);
7120          end if;
7121
7122       elsif Is_Record_Type (Typ) then
7123
7124          --  A discriminated type is always partially initialized if in
7125          --  all mode
7126
7127          if Has_Discriminants (Typ) and then Include_Implicit then
7128             return True;
7129
7130          --  A tagged type is always partially initialized
7131
7132          elsif Is_Tagged_Type (Typ) then
7133             return True;
7134
7135          --  Case of non-discriminated record
7136
7137          else
7138             declare
7139                Ent : Entity_Id;
7140
7141                Component_Present : Boolean := False;
7142                --  Set True if at least one component is present. If no
7143                --  components are present, then record type is fully
7144                --  initialized (another odd case, like the null array).
7145
7146             begin
7147                --  Loop through components
7148
7149                Ent := First_Entity (Typ);
7150                while Present (Ent) loop
7151                   if Ekind (Ent) = E_Component then
7152                      Component_Present := True;
7153
7154                      --  If a component has an initialization expression then
7155                      --  the enclosing record type is partially initialized
7156
7157                      if Present (Parent (Ent))
7158                        and then Present (Expression (Parent (Ent)))
7159                      then
7160                         return True;
7161
7162                      --  If a component is of a type which is itself partially
7163                      --  initialized, then the enclosing record type is also.
7164
7165                      elsif Is_Partially_Initialized_Type
7166                              (Etype (Ent), Include_Implicit)
7167                      then
7168                         return True;
7169                      end if;
7170                   end if;
7171
7172                   Next_Entity (Ent);
7173                end loop;
7174
7175                --  No initialized components found. If we found any components
7176                --  they were all uninitialized so the result is false.
7177
7178                if Component_Present then
7179                   return False;
7180
7181                --  But if we found no components, then all the components are
7182                --  initialized so we consider the type to be initialized.
7183
7184                else
7185                   return True;
7186                end if;
7187             end;
7188          end if;
7189
7190       --  Concurrent types are always fully initialized
7191
7192       elsif Is_Concurrent_Type (Typ) then
7193          return True;
7194
7195       --  For a private type, go to underlying type. If there is no underlying
7196       --  type then just assume this partially initialized. Not clear if this
7197       --  can happen in a non-error case, but no harm in testing for this.
7198
7199       elsif Is_Private_Type (Typ) then
7200          declare
7201             U : constant Entity_Id := Underlying_Type (Typ);
7202          begin
7203             if No (U) then
7204                return True;
7205             else
7206                return Is_Partially_Initialized_Type (U, Include_Implicit);
7207             end if;
7208          end;
7209
7210       --  For any other type (are there any?) assume partially initialized
7211
7212       else
7213          return True;
7214       end if;
7215    end Is_Partially_Initialized_Type;
7216
7217    ------------------------------------
7218    -- Is_Potentially_Persistent_Type --
7219    ------------------------------------
7220
7221    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
7222       Comp : Entity_Id;
7223       Indx : Node_Id;
7224
7225    begin
7226       --  For private type, test corresponding full type
7227
7228       if Is_Private_Type (T) then
7229          return Is_Potentially_Persistent_Type (Full_View (T));
7230
7231       --  Scalar types are potentially persistent
7232
7233       elsif Is_Scalar_Type (T) then
7234          return True;
7235
7236       --  Record type is potentially persistent if not tagged and the types of
7237       --  all it components are potentially persistent, and no component has
7238       --  an initialization expression.
7239
7240       elsif Is_Record_Type (T)
7241         and then not Is_Tagged_Type (T)
7242         and then not Is_Partially_Initialized_Type (T)
7243       then
7244          Comp := First_Component (T);
7245          while Present (Comp) loop
7246             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
7247                return False;
7248             else
7249                Next_Entity (Comp);
7250             end if;
7251          end loop;
7252
7253          return True;
7254
7255       --  Array type is potentially persistent if its component type is
7256       --  potentially persistent and if all its constraints are static.
7257
7258       elsif Is_Array_Type (T) then
7259          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
7260             return False;
7261          end if;
7262
7263          Indx := First_Index (T);
7264          while Present (Indx) loop
7265             if not Is_OK_Static_Subtype (Etype (Indx)) then
7266                return False;
7267             else
7268                Next_Index (Indx);
7269             end if;
7270          end loop;
7271
7272          return True;
7273
7274       --  All other types are not potentially persistent
7275
7276       else
7277          return False;
7278       end if;
7279    end Is_Potentially_Persistent_Type;
7280
7281    ---------------------------------
7282    -- Is_Protected_Self_Reference --
7283    ---------------------------------
7284
7285    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
7286
7287       function In_Access_Definition (N : Node_Id) return Boolean;
7288       --  Returns true if N belongs to an access definition
7289
7290       --------------------------
7291       -- In_Access_Definition --
7292       --------------------------
7293
7294       function In_Access_Definition (N : Node_Id) return Boolean is
7295          P : Node_Id;
7296
7297       begin
7298          P := Parent (N);
7299          while Present (P) loop
7300             if Nkind (P) = N_Access_Definition then
7301                return True;
7302             end if;
7303
7304             P := Parent (P);
7305          end loop;
7306
7307          return False;
7308       end In_Access_Definition;
7309
7310    --  Start of processing for Is_Protected_Self_Reference
7311
7312    begin
7313       --  Verify that prefix is analyzed and has the proper form. Note that
7314       --  the attributes Elab_Spec, Elab_Body, and UET_Address, which also
7315       --  produce the address of an entity, do not analyze their prefix
7316       --  because they denote entities that are not necessarily visible.
7317       --  Neither of them can apply to a protected type.
7318
7319       return Ada_Version >= Ada_2005
7320         and then Is_Entity_Name (N)
7321         and then Present (Entity (N))
7322         and then Is_Protected_Type (Entity (N))
7323         and then In_Open_Scopes (Entity (N))
7324         and then not In_Access_Definition (N);
7325    end Is_Protected_Self_Reference;
7326
7327    -----------------------------
7328    -- Is_RCI_Pkg_Spec_Or_Body --
7329    -----------------------------
7330
7331    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
7332
7333       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
7334       --  Return True if the unit of Cunit is an RCI package declaration
7335
7336       ---------------------------
7337       -- Is_RCI_Pkg_Decl_Cunit --
7338       ---------------------------
7339
7340       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
7341          The_Unit : constant Node_Id := Unit (Cunit);
7342
7343       begin
7344          if Nkind (The_Unit) /= N_Package_Declaration then
7345             return False;
7346          end if;
7347
7348          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
7349       end Is_RCI_Pkg_Decl_Cunit;
7350
7351    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
7352
7353    begin
7354       return Is_RCI_Pkg_Decl_Cunit (Cunit)
7355         or else
7356          (Nkind (Unit (Cunit)) = N_Package_Body
7357            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
7358    end Is_RCI_Pkg_Spec_Or_Body;
7359
7360    -----------------------------------------
7361    -- Is_Remote_Access_To_Class_Wide_Type --
7362    -----------------------------------------
7363
7364    function Is_Remote_Access_To_Class_Wide_Type
7365      (E : Entity_Id) return Boolean
7366    is
7367    begin
7368       --  A remote access to class-wide type is a general access to object type
7369       --  declared in the visible part of a Remote_Types or Remote_Call_
7370       --  Interface unit.
7371
7372       return Ekind (E) = E_General_Access_Type
7373         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7374    end Is_Remote_Access_To_Class_Wide_Type;
7375
7376    -----------------------------------------
7377    -- Is_Remote_Access_To_Subprogram_Type --
7378    -----------------------------------------
7379
7380    function Is_Remote_Access_To_Subprogram_Type
7381      (E : Entity_Id) return Boolean
7382    is
7383    begin
7384       return (Ekind (E) = E_Access_Subprogram_Type
7385                 or else (Ekind (E) = E_Record_Type
7386                            and then Present (Corresponding_Remote_Type (E))))
7387         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7388    end Is_Remote_Access_To_Subprogram_Type;
7389
7390    --------------------
7391    -- Is_Remote_Call --
7392    --------------------
7393
7394    function Is_Remote_Call (N : Node_Id) return Boolean is
7395    begin
7396       if Nkind (N) /= N_Procedure_Call_Statement
7397         and then Nkind (N) /= N_Function_Call
7398       then
7399          --  An entry call cannot be remote
7400
7401          return False;
7402
7403       elsif Nkind (Name (N)) in N_Has_Entity
7404         and then Is_Remote_Call_Interface (Entity (Name (N)))
7405       then
7406          --  A subprogram declared in the spec of a RCI package is remote
7407
7408          return True;
7409
7410       elsif Nkind (Name (N)) = N_Explicit_Dereference
7411         and then Is_Remote_Access_To_Subprogram_Type
7412                    (Etype (Prefix (Name (N))))
7413       then
7414          --  The dereference of a RAS is a remote call
7415
7416          return True;
7417
7418       elsif Present (Controlling_Argument (N))
7419         and then Is_Remote_Access_To_Class_Wide_Type
7420           (Etype (Controlling_Argument (N)))
7421       then
7422          --  Any primitive operation call with a controlling argument of
7423          --  a RACW type is a remote call.
7424
7425          return True;
7426       end if;
7427
7428       --  All other calls are local calls
7429
7430       return False;
7431    end Is_Remote_Call;
7432
7433    ----------------------
7434    -- Is_Renamed_Entry --
7435    ----------------------
7436
7437    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
7438       Orig_Node : Node_Id := Empty;
7439       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
7440
7441       function Is_Entry (Nam : Node_Id) return Boolean;
7442       --  Determine whether Nam is an entry. Traverse selectors if there are
7443       --  nested selected components.
7444
7445       --------------
7446       -- Is_Entry --
7447       --------------
7448
7449       function Is_Entry (Nam : Node_Id) return Boolean is
7450       begin
7451          if Nkind (Nam) = N_Selected_Component then
7452             return Is_Entry (Selector_Name (Nam));
7453          end if;
7454
7455          return Ekind (Entity (Nam)) = E_Entry;
7456       end Is_Entry;
7457
7458    --  Start of processing for Is_Renamed_Entry
7459
7460    begin
7461       if Present (Alias (Proc_Nam)) then
7462          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
7463       end if;
7464
7465       --  Look for a rewritten subprogram renaming declaration
7466
7467       if Nkind (Subp_Decl) = N_Subprogram_Declaration
7468         and then Present (Original_Node (Subp_Decl))
7469       then
7470          Orig_Node := Original_Node (Subp_Decl);
7471       end if;
7472
7473       --  The rewritten subprogram is actually an entry
7474
7475       if Present (Orig_Node)
7476         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
7477         and then Is_Entry (Name (Orig_Node))
7478       then
7479          return True;
7480       end if;
7481
7482       return False;
7483    end Is_Renamed_Entry;
7484
7485    ----------------------
7486    -- Is_Selector_Name --
7487    ----------------------
7488
7489    function Is_Selector_Name (N : Node_Id) return Boolean is
7490    begin
7491       if not Is_List_Member (N) then
7492          declare
7493             P : constant Node_Id   := Parent (N);
7494             K : constant Node_Kind := Nkind (P);
7495          begin
7496             return
7497               (K = N_Expanded_Name          or else
7498                K = N_Generic_Association    or else
7499                K = N_Parameter_Association  or else
7500                K = N_Selected_Component)
7501               and then Selector_Name (P) = N;
7502          end;
7503
7504       else
7505          declare
7506             L : constant List_Id := List_Containing (N);
7507             P : constant Node_Id := Parent (L);
7508          begin
7509             return (Nkind (P) = N_Discriminant_Association
7510                      and then Selector_Names (P) = L)
7511               or else
7512                    (Nkind (P) = N_Component_Association
7513                      and then Choices (P) = L);
7514          end;
7515       end if;
7516    end Is_Selector_Name;
7517
7518    ----------------------------------
7519    -- Is_SPARK_Initialization_Expr --
7520    ----------------------------------
7521
7522    function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
7523       Is_Ok     : Boolean;
7524       Expr      : Node_Id;
7525       Comp_Assn : Node_Id;
7526       Orig_N    : constant Node_Id := Original_Node (N);
7527
7528    begin
7529       Is_Ok := True;
7530
7531       if not Comes_From_Source (Orig_N) then
7532          goto Done;
7533       end if;
7534
7535       pragma Assert (Nkind (Orig_N) in N_Subexpr);
7536
7537       case Nkind (Orig_N) is
7538          when N_Character_Literal |
7539               N_Integer_Literal   |
7540               N_Real_Literal      |
7541               N_String_Literal    =>
7542             null;
7543
7544          when N_Identifier    |
7545               N_Expanded_Name =>
7546             if Is_Entity_Name (Orig_N)
7547               and then Present (Entity (Orig_N))  --  needed in some cases
7548             then
7549                case Ekind (Entity (Orig_N)) is
7550                   when E_Constant            |
7551                        E_Enumeration_Literal |
7552                        E_Named_Integer       |
7553                        E_Named_Real          =>
7554                      null;
7555                   when others =>
7556                      if Is_Type (Entity (Orig_N)) then
7557                         null;
7558                      else
7559                         Is_Ok := False;
7560                      end if;
7561                end case;
7562             end if;
7563
7564          when N_Qualified_Expression |
7565               N_Type_Conversion      =>
7566             Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
7567
7568          when N_Unary_Op =>
7569             Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
7570
7571          when N_Binary_Op       |
7572               N_Short_Circuit   |
7573               N_Membership_Test =>
7574             Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
7575               and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
7576
7577          when N_Aggregate           |
7578               N_Extension_Aggregate =>
7579             if Nkind (Orig_N) = N_Extension_Aggregate then
7580                Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
7581             end if;
7582
7583             Expr := First (Expressions (Orig_N));
7584             while Present (Expr) loop
7585                if not Is_SPARK_Initialization_Expr (Expr) then
7586                   Is_Ok := False;
7587                   goto Done;
7588                end if;
7589
7590                Next (Expr);
7591             end loop;
7592
7593             Comp_Assn := First (Component_Associations (Orig_N));
7594             while Present (Comp_Assn) loop
7595                Expr := Expression (Comp_Assn);
7596                if Present (Expr)  --  needed for box association
7597                  and then not Is_SPARK_Initialization_Expr (Expr)
7598                then
7599                   Is_Ok := False;
7600                   goto Done;
7601                end if;
7602
7603                Next (Comp_Assn);
7604             end loop;
7605
7606          when N_Attribute_Reference =>
7607             if Nkind (Prefix (Orig_N)) in N_Subexpr then
7608                Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
7609             end if;
7610
7611             Expr := First (Expressions (Orig_N));
7612             while Present (Expr) loop
7613                if not Is_SPARK_Initialization_Expr (Expr) then
7614                   Is_Ok := False;
7615                   goto Done;
7616                end if;
7617
7618                Next (Expr);
7619             end loop;
7620
7621          --  Selected components might be expanded named not yet resolved, so
7622          --  default on the safe side. (Eg on sparklex.ads)
7623
7624          when N_Selected_Component =>
7625             null;
7626
7627          when others =>
7628             Is_Ok := False;
7629       end case;
7630
7631    <<Done>>
7632       return Is_Ok;
7633    end Is_SPARK_Initialization_Expr;
7634
7635    -------------------------------
7636    -- Is_SPARK_Object_Reference --
7637    -------------------------------
7638
7639    function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
7640    begin
7641       if Is_Entity_Name (N) then
7642          return Present (Entity (N))
7643            and then
7644              (Ekind_In (Entity (N), E_Constant, E_Variable)
7645               or else Ekind (Entity (N)) in Formal_Kind);
7646
7647       else
7648          case Nkind (N) is
7649             when N_Selected_Component =>
7650                return Is_SPARK_Object_Reference (Prefix (N));
7651
7652             when others =>
7653                return False;
7654          end case;
7655       end if;
7656    end Is_SPARK_Object_Reference;
7657
7658    ------------------
7659    -- Is_Statement --
7660    ------------------
7661
7662    function Is_Statement (N : Node_Id) return Boolean is
7663    begin
7664       return
7665         Nkind (N) in N_Statement_Other_Than_Procedure_Call
7666           or else Nkind (N) = N_Procedure_Call_Statement;
7667    end Is_Statement;
7668
7669    ---------------------------------
7670    -- Is_Synchronized_Tagged_Type --
7671    ---------------------------------
7672
7673    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
7674       Kind : constant Entity_Kind := Ekind (Base_Type (E));
7675
7676    begin
7677       --  A task or protected type derived from an interface is a tagged type.
7678       --  Such a tagged type is called a synchronized tagged type, as are
7679       --  synchronized interfaces and private extensions whose declaration
7680       --  includes the reserved word synchronized.
7681
7682       return (Is_Tagged_Type (E)
7683                 and then (Kind = E_Task_Type
7684                            or else Kind = E_Protected_Type))
7685             or else
7686              (Is_Interface (E)
7687                 and then Is_Synchronized_Interface (E))
7688             or else
7689              (Ekind (E) = E_Record_Type_With_Private
7690                 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
7691                 and then (Synchronized_Present (Parent (E))
7692                            or else Is_Synchronized_Interface (Etype (E))));
7693    end Is_Synchronized_Tagged_Type;
7694
7695    -----------------
7696    -- Is_Transfer --
7697    -----------------
7698
7699    function Is_Transfer (N : Node_Id) return Boolean is
7700       Kind : constant Node_Kind := Nkind (N);
7701
7702    begin
7703       if Kind = N_Simple_Return_Statement
7704            or else
7705          Kind = N_Extended_Return_Statement
7706            or else
7707          Kind = N_Goto_Statement
7708            or else
7709          Kind = N_Raise_Statement
7710            or else
7711          Kind = N_Requeue_Statement
7712       then
7713          return True;
7714
7715       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
7716         and then No (Condition (N))
7717       then
7718          return True;
7719
7720       elsif Kind = N_Procedure_Call_Statement
7721         and then Is_Entity_Name (Name (N))
7722         and then Present (Entity (Name (N)))
7723         and then No_Return (Entity (Name (N)))
7724       then
7725          return True;
7726
7727       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
7728          return True;
7729
7730       else
7731          return False;
7732       end if;
7733    end Is_Transfer;
7734
7735    -------------
7736    -- Is_True --
7737    -------------
7738
7739    function Is_True (U : Uint) return Boolean is
7740    begin
7741       return (U /= 0);
7742    end Is_True;
7743
7744    -------------------------------
7745    -- Is_Universal_Numeric_Type --
7746    -------------------------------
7747
7748    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
7749    begin
7750       return T = Universal_Integer or else T = Universal_Real;
7751    end Is_Universal_Numeric_Type;
7752
7753    -------------------
7754    -- Is_Value_Type --
7755    -------------------
7756
7757    function Is_Value_Type (T : Entity_Id) return Boolean is
7758    begin
7759       return VM_Target = CLI_Target
7760         and then Nkind (T) in N_Has_Chars
7761         and then Chars (T) /= No_Name
7762         and then Get_Name_String (Chars (T)) = "valuetype";
7763    end Is_Value_Type;
7764
7765    ---------------------
7766    -- Is_VMS_Operator --
7767    ---------------------
7768
7769    function Is_VMS_Operator (Op : Entity_Id) return Boolean is
7770    begin
7771       --  The VMS operators are declared in a child of System that is loaded
7772       --  through pragma Extend_System. In some rare cases a program is run
7773       --  with this extension but without indicating that the target is VMS.
7774
7775       return Ekind (Op) = E_Function
7776         and then Is_Intrinsic_Subprogram (Op)
7777         and then
7778           ((Present_System_Aux
7779             and then Scope (Op) = System_Aux_Id)
7780            or else
7781            (True_VMS_Target
7782              and then Scope (Scope (Op)) = RTU_Entity (System)));
7783    end Is_VMS_Operator;
7784
7785    -----------------
7786    -- Is_Variable --
7787    -----------------
7788
7789    function Is_Variable
7790      (N                 : Node_Id;
7791       Use_Original_Node : Boolean := True) return Boolean
7792    is
7793       Orig_Node : Node_Id;
7794
7795       function In_Protected_Function (E : Entity_Id) return Boolean;
7796       --  Within a protected function, the private components of the enclosing
7797       --  protected type are constants. A function nested within a (protected)
7798       --  procedure is not itself protected.
7799
7800       function Is_Variable_Prefix (P : Node_Id) return Boolean;
7801       --  Prefixes can involve implicit dereferences, in which case we must
7802       --  test for the case of a reference of a constant access type, which can
7803       --  can never be a variable.
7804
7805       ---------------------------
7806       -- In_Protected_Function --
7807       ---------------------------
7808
7809       function In_Protected_Function (E : Entity_Id) return Boolean is
7810          Prot : constant Entity_Id := Scope (E);
7811          S    : Entity_Id;
7812
7813       begin
7814          if not Is_Protected_Type (Prot) then
7815             return False;
7816          else
7817             S := Current_Scope;
7818             while Present (S) and then S /= Prot loop
7819                if Ekind (S) = E_Function and then Scope (S) = Prot then
7820                   return True;
7821                end if;
7822
7823                S := Scope (S);
7824             end loop;
7825
7826             return False;
7827          end if;
7828       end In_Protected_Function;
7829
7830       ------------------------
7831       -- Is_Variable_Prefix --
7832       ------------------------
7833
7834       function Is_Variable_Prefix (P : Node_Id) return Boolean is
7835       begin
7836          if Is_Access_Type (Etype (P)) then
7837             return not Is_Access_Constant (Root_Type (Etype (P)));
7838
7839          --  For the case of an indexed component whose prefix has a packed
7840          --  array type, the prefix has been rewritten into a type conversion.
7841          --  Determine variable-ness from the converted expression.
7842
7843          elsif Nkind (P) = N_Type_Conversion
7844            and then not Comes_From_Source (P)
7845            and then Is_Array_Type (Etype (P))
7846            and then Is_Packed (Etype (P))
7847          then
7848             return Is_Variable (Expression (P));
7849
7850          else
7851             return Is_Variable (P);
7852          end if;
7853       end Is_Variable_Prefix;
7854
7855    --  Start of processing for Is_Variable
7856
7857    begin
7858       --  Check if we perform the test on the original node since this may be a
7859       --  test of syntactic categories which must not be disturbed by whatever
7860       --  rewriting might have occurred. For example, an aggregate, which is
7861       --  certainly NOT a variable, could be turned into a variable by
7862       --  expansion.
7863
7864       if Use_Original_Node then
7865          Orig_Node := Original_Node (N);
7866       else
7867          Orig_Node := N;
7868       end if;
7869
7870       --  Definitely OK if Assignment_OK is set. Since this is something that
7871       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
7872
7873       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
7874          return True;
7875
7876       --  Normally we go to the original node, but there is one exception where
7877       --  we use the rewritten node, namely when it is an explicit dereference.
7878       --  The generated code may rewrite a prefix which is an access type with
7879       --  an explicit dereference. The dereference is a variable, even though
7880       --  the original node may not be (since it could be a constant of the
7881       --  access type).
7882
7883       --  In Ada 2005 we have a further case to consider: the prefix may be a
7884       --  function call given in prefix notation. The original node appears to
7885       --  be a selected component, but we need to examine the call.
7886
7887       elsif Nkind (N) = N_Explicit_Dereference
7888         and then Nkind (Orig_Node) /= N_Explicit_Dereference
7889         and then Present (Etype (Orig_Node))
7890         and then Is_Access_Type (Etype (Orig_Node))
7891       then
7892          --  Note that if the prefix is an explicit dereference that does not
7893          --  come from source, we must check for a rewritten function call in
7894          --  prefixed notation before other forms of rewriting, to prevent a
7895          --  compiler crash.
7896
7897          return
7898            (Nkind (Orig_Node) = N_Function_Call
7899              and then not Is_Access_Constant (Etype (Prefix (N))))
7900            or else
7901              Is_Variable_Prefix (Original_Node (Prefix (N)));
7902
7903       --  A function call is never a variable
7904
7905       elsif Nkind (N) = N_Function_Call then
7906          return False;
7907
7908       --  All remaining checks use the original node
7909
7910       elsif Is_Entity_Name (Orig_Node)
7911         and then Present (Entity (Orig_Node))
7912       then
7913          declare
7914             E : constant Entity_Id := Entity (Orig_Node);
7915             K : constant Entity_Kind := Ekind (E);
7916
7917          begin
7918             return (K = E_Variable
7919                       and then Nkind (Parent (E)) /= N_Exception_Handler)
7920               or else  (K = E_Component
7921                           and then not In_Protected_Function (E))
7922               or else  K = E_Out_Parameter
7923               or else  K = E_In_Out_Parameter
7924               or else  K = E_Generic_In_Out_Parameter
7925
7926                --  Current instance of type:
7927
7928               or else (Is_Type (E) and then In_Open_Scopes (E))
7929               or else (Is_Incomplete_Or_Private_Type (E)
7930                         and then In_Open_Scopes (Full_View (E)));
7931          end;
7932
7933       else
7934          case Nkind (Orig_Node) is
7935             when N_Indexed_Component | N_Slice =>
7936                return Is_Variable_Prefix (Prefix (Orig_Node));
7937
7938             when N_Selected_Component =>
7939                return Is_Variable_Prefix (Prefix (Orig_Node))
7940                  and then Is_Variable (Selector_Name (Orig_Node));
7941
7942             --  For an explicit dereference, the type of the prefix cannot
7943             --  be an access to constant or an access to subprogram.
7944
7945             when N_Explicit_Dereference =>
7946                declare
7947                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
7948                begin
7949                   return Is_Access_Type (Typ)
7950                     and then not Is_Access_Constant (Root_Type (Typ))
7951                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
7952                end;
7953
7954             --  The type conversion is the case where we do not deal with the
7955             --  context dependent special case of an actual parameter. Thus
7956             --  the type conversion is only considered a variable for the
7957             --  purposes of this routine if the target type is tagged. However,
7958             --  a type conversion is considered to be a variable if it does not
7959             --  come from source (this deals for example with the conversions
7960             --  of expressions to their actual subtypes).
7961
7962             when N_Type_Conversion =>
7963                return Is_Variable (Expression (Orig_Node))
7964                  and then
7965                    (not Comes_From_Source (Orig_Node)
7966                       or else
7967                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
7968                           and then
7969                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
7970
7971             --  GNAT allows an unchecked type conversion as a variable. This
7972             --  only affects the generation of internal expanded code, since
7973             --  calls to instantiations of Unchecked_Conversion are never
7974             --  considered variables (since they are function calls).
7975             --  This is also true for expression actions.
7976
7977             when N_Unchecked_Type_Conversion =>
7978                return Is_Variable (Expression (Orig_Node));
7979
7980             when others =>
7981                return False;
7982          end case;
7983       end if;
7984    end Is_Variable;
7985
7986    ---------------------------
7987    -- Is_Visibly_Controlled --
7988    ---------------------------
7989
7990    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
7991       Root : constant Entity_Id := Root_Type (T);
7992    begin
7993       return Chars (Scope (Root)) = Name_Finalization
7994         and then Chars (Scope (Scope (Root))) = Name_Ada
7995         and then Scope (Scope (Scope (Root))) = Standard_Standard;
7996    end Is_Visibly_Controlled;
7997
7998    ------------------------
7999    -- Is_Volatile_Object --
8000    ------------------------
8001
8002    function Is_Volatile_Object (N : Node_Id) return Boolean is
8003
8004       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
8005       --  Determines if given object has volatile components
8006
8007       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
8008       --  If prefix is an implicit dereference, examine designated type
8009
8010       ------------------------
8011       -- Is_Volatile_Prefix --
8012       ------------------------
8013
8014       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
8015          Typ  : constant Entity_Id := Etype (N);
8016
8017       begin
8018          if Is_Access_Type (Typ) then
8019             declare
8020                Dtyp : constant Entity_Id := Designated_Type (Typ);
8021
8022             begin
8023                return Is_Volatile (Dtyp)
8024                  or else Has_Volatile_Components (Dtyp);
8025             end;
8026
8027          else
8028             return Object_Has_Volatile_Components (N);
8029          end if;
8030       end Is_Volatile_Prefix;
8031
8032       ------------------------------------
8033       -- Object_Has_Volatile_Components --
8034       ------------------------------------
8035
8036       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
8037          Typ : constant Entity_Id := Etype (N);
8038
8039       begin
8040          if Is_Volatile (Typ)
8041            or else Has_Volatile_Components (Typ)
8042          then
8043             return True;
8044
8045          elsif Is_Entity_Name (N)
8046            and then (Has_Volatile_Components (Entity (N))
8047                       or else Is_Volatile (Entity (N)))
8048          then
8049             return True;
8050
8051          elsif Nkind (N) = N_Indexed_Component
8052            or else Nkind (N) = N_Selected_Component
8053          then
8054             return Is_Volatile_Prefix (Prefix (N));
8055
8056          else
8057             return False;
8058          end if;
8059       end Object_Has_Volatile_Components;
8060
8061    --  Start of processing for Is_Volatile_Object
8062
8063    begin
8064       if Is_Volatile (Etype (N))
8065         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
8066       then
8067          return True;
8068
8069       elsif Nkind (N) = N_Indexed_Component
8070         or else Nkind (N) = N_Selected_Component
8071       then
8072          return Is_Volatile_Prefix (Prefix (N));
8073
8074       else
8075          return False;
8076       end if;
8077    end Is_Volatile_Object;
8078
8079    -------------------------
8080    -- Kill_Current_Values --
8081    -------------------------
8082
8083    procedure Kill_Current_Values
8084      (Ent                  : Entity_Id;
8085       Last_Assignment_Only : Boolean := False)
8086    is
8087    begin
8088       --  ??? do we have to worry about clearing cached checks?
8089
8090       if Is_Assignable (Ent) then
8091          Set_Last_Assignment (Ent, Empty);
8092       end if;
8093
8094       if Is_Object (Ent) then
8095          if not Last_Assignment_Only then
8096             Kill_Checks (Ent);
8097             Set_Current_Value (Ent, Empty);
8098
8099             if not Can_Never_Be_Null (Ent) then
8100                Set_Is_Known_Non_Null (Ent, False);
8101             end if;
8102
8103             Set_Is_Known_Null (Ent, False);
8104
8105             --  Reset Is_Known_Valid unless type is always valid, or if we have
8106             --  a loop parameter (loop parameters are always valid, since their
8107             --  bounds are defined by the bounds given in the loop header).
8108
8109             if not Is_Known_Valid (Etype (Ent))
8110               and then Ekind (Ent) /= E_Loop_Parameter
8111             then
8112                Set_Is_Known_Valid (Ent, False);
8113             end if;
8114          end if;
8115       end if;
8116    end Kill_Current_Values;
8117
8118    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
8119       S : Entity_Id;
8120
8121       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
8122       --  Clear current value for entity E and all entities chained to E
8123
8124       ------------------------------------------
8125       -- Kill_Current_Values_For_Entity_Chain --
8126       ------------------------------------------
8127
8128       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
8129          Ent : Entity_Id;
8130       begin
8131          Ent := E;
8132          while Present (Ent) loop
8133             Kill_Current_Values (Ent, Last_Assignment_Only);
8134             Next_Entity (Ent);
8135          end loop;
8136       end Kill_Current_Values_For_Entity_Chain;
8137
8138    --  Start of processing for Kill_Current_Values
8139
8140    begin
8141       --  Kill all saved checks, a special case of killing saved values
8142
8143       if not Last_Assignment_Only then
8144          Kill_All_Checks;
8145       end if;
8146
8147       --  Loop through relevant scopes, which includes the current scope and
8148       --  any parent scopes if the current scope is a block or a package.
8149
8150       S := Current_Scope;
8151       Scope_Loop : loop
8152
8153          --  Clear current values of all entities in current scope
8154
8155          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
8156
8157          --  If scope is a package, also clear current values of all
8158          --  private entities in the scope.
8159
8160          if Is_Package_Or_Generic_Package (S)
8161            or else Is_Concurrent_Type (S)
8162          then
8163             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
8164          end if;
8165
8166          --  If this is a not a subprogram, deal with parents
8167
8168          if not Is_Subprogram (S) then
8169             S := Scope (S);
8170             exit Scope_Loop when S = Standard_Standard;
8171          else
8172             exit Scope_Loop;
8173          end if;
8174       end loop Scope_Loop;
8175    end Kill_Current_Values;
8176
8177    --------------------------
8178    -- Kill_Size_Check_Code --
8179    --------------------------
8180
8181    procedure Kill_Size_Check_Code (E : Entity_Id) is
8182    begin
8183       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8184         and then Present (Size_Check_Code (E))
8185       then
8186          Remove (Size_Check_Code (E));
8187          Set_Size_Check_Code (E, Empty);
8188       end if;
8189    end Kill_Size_Check_Code;
8190
8191    --------------------------
8192    -- Known_To_Be_Assigned --
8193    --------------------------
8194
8195    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
8196       P : constant Node_Id := Parent (N);
8197
8198    begin
8199       case Nkind (P) is
8200
8201          --  Test left side of assignment
8202
8203          when N_Assignment_Statement =>
8204             return N = Name (P);
8205
8206             --  Function call arguments are never lvalues
8207
8208          when N_Function_Call =>
8209             return False;
8210
8211          --  Positional parameter for procedure or accept call
8212
8213          when N_Procedure_Call_Statement |
8214               N_Accept_Statement
8215           =>
8216             declare
8217                Proc : Entity_Id;
8218                Form : Entity_Id;
8219                Act  : Node_Id;
8220
8221             begin
8222                Proc := Get_Subprogram_Entity (P);
8223
8224                if No (Proc) then
8225                   return False;
8226                end if;
8227
8228                --  If we are not a list member, something is strange, so
8229                --  be conservative and return False.
8230
8231                if not Is_List_Member (N) then
8232                   return False;
8233                end if;
8234
8235                --  We are going to find the right formal by stepping forward
8236                --  through the formals, as we step backwards in the actuals.
8237
8238                Form := First_Formal (Proc);
8239                Act  := N;
8240                loop
8241                   --  If no formal, something is weird, so be conservative
8242                   --  and return False.
8243
8244                   if No (Form) then
8245                      return False;
8246                   end if;
8247
8248                   Prev (Act);
8249                   exit when No (Act);
8250                   Next_Formal (Form);
8251                end loop;
8252
8253                return Ekind (Form) /= E_In_Parameter;
8254             end;
8255
8256          --  Named parameter for procedure or accept call
8257
8258          when N_Parameter_Association =>
8259             declare
8260                Proc : Entity_Id;
8261                Form : Entity_Id;
8262
8263             begin
8264                Proc := Get_Subprogram_Entity (Parent (P));
8265
8266                if No (Proc) then
8267                   return False;
8268                end if;
8269
8270                --  Loop through formals to find the one that matches
8271
8272                Form := First_Formal (Proc);
8273                loop
8274                   --  If no matching formal, that's peculiar, some kind of
8275                   --  previous error, so return False to be conservative.
8276
8277                   if No (Form) then
8278                      return False;
8279                   end if;
8280
8281                   --  Else test for match
8282
8283                   if Chars (Form) = Chars (Selector_Name (P)) then
8284                      return Ekind (Form) /= E_In_Parameter;
8285                   end if;
8286
8287                   Next_Formal (Form);
8288                end loop;
8289             end;
8290
8291          --  Test for appearing in a conversion that itself appears
8292          --  in an lvalue context, since this should be an lvalue.
8293
8294          when N_Type_Conversion =>
8295             return Known_To_Be_Assigned (P);
8296
8297          --  All other references are definitely not known to be modifications
8298
8299          when others =>
8300             return False;
8301
8302       end case;
8303    end Known_To_Be_Assigned;
8304
8305    ---------------------------
8306    -- Last_Source_Statement --
8307    ---------------------------
8308
8309    function Last_Source_Statement (HSS : Node_Id) return Node_Id is
8310       N : Node_Id;
8311
8312    begin
8313       N := Last (Statements (HSS));
8314       while Present (N) loop
8315          exit when Comes_From_Source (N);
8316          Prev (N);
8317       end loop;
8318
8319       return N;
8320    end Last_Source_Statement;
8321
8322    ----------------------------------
8323    -- Matching_Static_Array_Bounds --
8324    ----------------------------------
8325
8326    function Matching_Static_Array_Bounds
8327      (L_Typ : Node_Id;
8328       R_Typ : Node_Id) return Boolean
8329    is
8330       L_Ndims : constant Nat := Number_Dimensions (L_Typ);
8331       R_Ndims : constant Nat := Number_Dimensions (R_Typ);
8332
8333       L_Index : Node_Id;
8334       R_Index : Node_Id;
8335       L_Low   : Node_Id;
8336       L_High  : Node_Id;
8337       L_Len   : Uint;
8338       R_Low   : Node_Id;
8339       R_High  : Node_Id;
8340       R_Len   : Uint;
8341
8342    begin
8343       if L_Ndims /= R_Ndims then
8344          return False;
8345       end if;
8346
8347       --  Unconstrained types do not have static bounds
8348
8349       if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
8350          return False;
8351       end if;
8352
8353       --  First treat specially the first dimension, as the lower bound and
8354       --  length of string literals are not stored like those of arrays.
8355
8356       if Ekind (L_Typ) = E_String_Literal_Subtype then
8357          L_Low := String_Literal_Low_Bound (L_Typ);
8358          L_Len := String_Literal_Length (L_Typ);
8359       else
8360          L_Index := First_Index (L_Typ);
8361          Get_Index_Bounds (L_Index, L_Low, L_High);
8362
8363          if         Is_OK_Static_Expression (L_Low)
8364            and then Is_OK_Static_Expression (L_High)
8365          then
8366             if Expr_Value (L_High) < Expr_Value (L_Low) then
8367                L_Len := Uint_0;
8368             else
8369                L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
8370             end if;
8371          else
8372             return False;
8373          end if;
8374       end if;
8375
8376       if Ekind (R_Typ) = E_String_Literal_Subtype then
8377          R_Low := String_Literal_Low_Bound (R_Typ);
8378          R_Len := String_Literal_Length (R_Typ);
8379       else
8380          R_Index := First_Index (R_Typ);
8381          Get_Index_Bounds (R_Index, R_Low, R_High);
8382
8383          if         Is_OK_Static_Expression (R_Low)
8384            and then Is_OK_Static_Expression (R_High)
8385          then
8386             if Expr_Value (R_High) < Expr_Value (R_Low) then
8387                R_Len := Uint_0;
8388             else
8389                R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
8390             end if;
8391          else
8392             return False;
8393          end if;
8394       end if;
8395
8396       if         Is_OK_Static_Expression (L_Low)
8397         and then Is_OK_Static_Expression (R_Low)
8398         and then Expr_Value (L_Low) = Expr_Value (R_Low)
8399         and then L_Len = R_Len
8400       then
8401          null;
8402       else
8403          return False;
8404       end if;
8405
8406       --  Then treat all other dimensions
8407
8408       for Indx in 2 .. L_Ndims loop
8409          Next (L_Index);
8410          Next (R_Index);
8411
8412          Get_Index_Bounds (L_Index, L_Low, L_High);
8413          Get_Index_Bounds (R_Index, R_Low, R_High);
8414
8415          if         Is_OK_Static_Expression (L_Low)
8416            and then Is_OK_Static_Expression (L_High)
8417            and then Is_OK_Static_Expression (R_Low)
8418            and then Is_OK_Static_Expression (R_High)
8419            and then Expr_Value (L_Low)  = Expr_Value (R_Low)
8420            and then Expr_Value (L_High) = Expr_Value (R_High)
8421          then
8422             null;
8423          else
8424             return False;
8425          end if;
8426       end loop;
8427
8428       --  If we fall through the loop, all indexes matched
8429
8430       return True;
8431    end Matching_Static_Array_Bounds;
8432
8433    -------------------
8434    -- May_Be_Lvalue --
8435    -------------------
8436
8437    function May_Be_Lvalue (N : Node_Id) return Boolean is
8438       P : constant Node_Id := Parent (N);
8439
8440    begin
8441       case Nkind (P) is
8442
8443          --  Test left side of assignment
8444
8445          when N_Assignment_Statement =>
8446             return N = Name (P);
8447
8448          --  Test prefix of component or attribute. Note that the prefix of an
8449          --  explicit or implicit dereference cannot be an l-value.
8450
8451          when N_Attribute_Reference =>
8452             return N = Prefix (P)
8453               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
8454
8455          --  For an expanded name, the name is an lvalue if the expanded name
8456          --  is an lvalue, but the prefix is never an lvalue, since it is just
8457          --  the scope where the name is found.
8458
8459          when N_Expanded_Name        =>
8460             if N = Prefix (P) then
8461                return May_Be_Lvalue (P);
8462             else
8463                return False;
8464             end if;
8465
8466          --  For a selected component A.B, A is certainly an lvalue if A.B is.
8467          --  B is a little interesting, if we have A.B := 3, there is some
8468          --  discussion as to whether B is an lvalue or not, we choose to say
8469          --  it is. Note however that A is not an lvalue if it is of an access
8470          --  type since this is an implicit dereference.
8471
8472          when N_Selected_Component   =>
8473             if N = Prefix (P)
8474               and then Present (Etype (N))
8475               and then Is_Access_Type (Etype (N))
8476             then
8477                return False;
8478             else
8479                return May_Be_Lvalue (P);
8480             end if;
8481
8482          --  For an indexed component or slice, the index or slice bounds is
8483          --  never an lvalue. The prefix is an lvalue if the indexed component
8484          --  or slice is an lvalue, except if it is an access type, where we
8485          --  have an implicit dereference.
8486
8487          when N_Indexed_Component    =>
8488             if N /= Prefix (P)
8489               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
8490             then
8491                return False;
8492             else
8493                return May_Be_Lvalue (P);
8494             end if;
8495
8496          --  Prefix of a reference is an lvalue if the reference is an lvalue
8497
8498          when N_Reference            =>
8499             return May_Be_Lvalue (P);
8500
8501          --  Prefix of explicit dereference is never an lvalue
8502
8503          when N_Explicit_Dereference =>
8504             return False;
8505
8506          --  Positional parameter for subprogram, entry, or accept call.
8507          --  In older versions of Ada function call arguments are never
8508          --  lvalues. In Ada 2012 functions can have in-out parameters.
8509
8510          when N_Function_Call            |
8511               N_Procedure_Call_Statement |
8512               N_Entry_Call_Statement     |
8513               N_Accept_Statement
8514          =>
8515             if Nkind (P) = N_Function_Call
8516               and then Ada_Version < Ada_2012
8517             then
8518                return False;
8519             end if;
8520
8521             --  The following mechanism is clumsy and fragile. A single
8522             --  flag set in Resolve_Actuals would be preferable ???
8523
8524             declare
8525                Proc : Entity_Id;
8526                Form : Entity_Id;
8527                Act  : Node_Id;
8528
8529             begin
8530                Proc := Get_Subprogram_Entity (P);
8531
8532                if No (Proc) then
8533                   return True;
8534                end if;
8535
8536                --  If we are not a list member, something is strange, so
8537                --  be conservative and return True.
8538
8539                if not Is_List_Member (N) then
8540                   return True;
8541                end if;
8542
8543                --  We are going to find the right formal by stepping forward
8544                --  through the formals, as we step backwards in the actuals.
8545
8546                Form := First_Formal (Proc);
8547                Act  := N;
8548                loop
8549                   --  If no formal, something is weird, so be conservative
8550                   --  and return True.
8551
8552                   if No (Form) then
8553                      return True;
8554                   end if;
8555
8556                   Prev (Act);
8557                   exit when No (Act);
8558                   Next_Formal (Form);
8559                end loop;
8560
8561                return Ekind (Form) /= E_In_Parameter;
8562             end;
8563
8564          --  Named parameter for procedure or accept call
8565
8566          when N_Parameter_Association =>
8567             declare
8568                Proc : Entity_Id;
8569                Form : Entity_Id;
8570
8571             begin
8572                Proc := Get_Subprogram_Entity (Parent (P));
8573
8574                if No (Proc) then
8575                   return True;
8576                end if;
8577
8578                --  Loop through formals to find the one that matches
8579
8580                Form := First_Formal (Proc);
8581                loop
8582                   --  If no matching formal, that's peculiar, some kind of
8583                   --  previous error, so return True to be conservative.
8584
8585                   if No (Form) then
8586                      return True;
8587                   end if;
8588
8589                   --  Else test for match
8590
8591                   if Chars (Form) = Chars (Selector_Name (P)) then
8592                      return Ekind (Form) /= E_In_Parameter;
8593                   end if;
8594
8595                   Next_Formal (Form);
8596                end loop;
8597             end;
8598
8599          --  Test for appearing in a conversion that itself appears in an
8600          --  lvalue context, since this should be an lvalue.
8601
8602          when N_Type_Conversion =>
8603             return May_Be_Lvalue (P);
8604
8605          --  Test for appearance in object renaming declaration
8606
8607          when N_Object_Renaming_Declaration =>
8608             return True;
8609
8610          --  All other references are definitely not lvalues
8611
8612          when others =>
8613             return False;
8614
8615       end case;
8616    end May_Be_Lvalue;
8617
8618    -----------------------
8619    -- Mark_Coextensions --
8620    -----------------------
8621
8622    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
8623       Is_Dynamic : Boolean;
8624       --  Indicates whether the context causes nested coextensions to be
8625       --  dynamic or static
8626
8627       function Mark_Allocator (N : Node_Id) return Traverse_Result;
8628       --  Recognize an allocator node and label it as a dynamic coextension
8629
8630       --------------------
8631       -- Mark_Allocator --
8632       --------------------
8633
8634       function Mark_Allocator (N : Node_Id) return Traverse_Result is
8635       begin
8636          if Nkind (N) = N_Allocator then
8637             if Is_Dynamic then
8638                Set_Is_Dynamic_Coextension (N);
8639
8640             --  If the allocator expression is potentially dynamic, it may
8641             --  be expanded out of order and require dynamic allocation
8642             --  anyway, so we treat the coextension itself as dynamic.
8643             --  Potential optimization ???
8644
8645             elsif Nkind (Expression (N)) = N_Qualified_Expression
8646               and then Nkind (Expression (Expression (N))) = N_Op_Concat
8647             then
8648                Set_Is_Dynamic_Coextension (N);
8649
8650             else
8651                Set_Is_Static_Coextension (N);
8652             end if;
8653          end if;
8654
8655          return OK;
8656       end Mark_Allocator;
8657
8658       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
8659
8660    --  Start of processing Mark_Coextensions
8661
8662    begin
8663       case Nkind (Context_Nod) is
8664          when N_Assignment_Statement    |
8665               N_Simple_Return_Statement =>
8666             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
8667
8668          when N_Object_Declaration =>
8669             Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
8670
8671          --  This routine should not be called for constructs which may not
8672          --  contain coextensions.
8673
8674          when others =>
8675             raise Program_Error;
8676       end case;
8677
8678       Mark_Allocators (Root_Nod);
8679    end Mark_Coextensions;
8680
8681    ----------------------
8682    -- Needs_One_Actual --
8683    ----------------------
8684
8685    function Needs_One_Actual (E : Entity_Id) return Boolean is
8686       Formal : Entity_Id;
8687
8688    begin
8689       if Ada_Version >= Ada_2005
8690         and then Present (First_Formal (E))
8691       then
8692          Formal := Next_Formal (First_Formal (E));
8693          while Present (Formal) loop
8694             if No (Default_Value (Formal)) then
8695                return False;
8696             end if;
8697
8698             Next_Formal (Formal);
8699          end loop;
8700
8701          return True;
8702
8703       else
8704          return False;
8705       end if;
8706    end Needs_One_Actual;
8707
8708    ------------------------
8709    -- New_Copy_List_Tree --
8710    ------------------------
8711
8712    function New_Copy_List_Tree (List : List_Id) return List_Id is
8713       NL : List_Id;
8714       E  : Node_Id;
8715
8716    begin
8717       if List = No_List then
8718          return No_List;
8719
8720       else
8721          NL := New_List;
8722          E := First (List);
8723
8724          while Present (E) loop
8725             Append (New_Copy_Tree (E), NL);
8726             E := Next (E);
8727          end loop;
8728
8729          return NL;
8730       end if;
8731    end New_Copy_List_Tree;
8732
8733    -------------------
8734    -- New_Copy_Tree --
8735    -------------------
8736
8737    use Atree.Unchecked_Access;
8738    use Atree_Private_Part;
8739
8740    --  Our approach here requires a two pass traversal of the tree. The
8741    --  first pass visits all nodes that eventually will be copied looking
8742    --  for defining Itypes. If any defining Itypes are found, then they are
8743    --  copied, and an entry is added to the replacement map. In the second
8744    --  phase, the tree is copied, using the replacement map to replace any
8745    --  Itype references within the copied tree.
8746
8747    --  The following hash tables are used if the Map supplied has more
8748    --  than hash threshold entries to speed up access to the map. If
8749    --  there are fewer entries, then the map is searched sequentially
8750    --  (because setting up a hash table for only a few entries takes
8751    --  more time than it saves.
8752
8753    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
8754    --  Hash function used for hash operations
8755
8756    -------------------
8757    -- New_Copy_Hash --
8758    -------------------
8759
8760    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
8761    begin
8762       return Nat (E) mod (NCT_Header_Num'Last + 1);
8763    end New_Copy_Hash;
8764
8765    ---------------
8766    -- NCT_Assoc --
8767    ---------------
8768
8769    --  The hash table NCT_Assoc associates old entities in the table
8770    --  with their corresponding new entities (i.e. the pairs of entries
8771    --  presented in the original Map argument are Key-Element pairs).
8772
8773    package NCT_Assoc is new Simple_HTable (
8774      Header_Num => NCT_Header_Num,
8775      Element    => Entity_Id,
8776      No_Element => Empty,
8777      Key        => Entity_Id,
8778      Hash       => New_Copy_Hash,
8779      Equal      => Types."=");
8780
8781    ---------------------
8782    -- NCT_Itype_Assoc --
8783    ---------------------
8784
8785    --  The hash table NCT_Itype_Assoc contains entries only for those
8786    --  old nodes which have a non-empty Associated_Node_For_Itype set.
8787    --  The key is the associated node, and the element is the new node
8788    --  itself (NOT the associated node for the new node).
8789
8790    package NCT_Itype_Assoc is new Simple_HTable (
8791      Header_Num => NCT_Header_Num,
8792      Element    => Entity_Id,
8793      No_Element => Empty,
8794      Key        => Entity_Id,
8795      Hash       => New_Copy_Hash,
8796      Equal      => Types."=");
8797
8798    --  Start of processing for New_Copy_Tree function
8799
8800    function New_Copy_Tree
8801      (Source    : Node_Id;
8802       Map       : Elist_Id := No_Elist;
8803       New_Sloc  : Source_Ptr := No_Location;
8804       New_Scope : Entity_Id := Empty) return Node_Id
8805    is
8806       Actual_Map : Elist_Id := Map;
8807       --  This is the actual map for the copy. It is initialized with the
8808       --  given elements, and then enlarged as required for Itypes that are
8809       --  copied during the first phase of the copy operation. The visit
8810       --  procedures add elements to this map as Itypes are encountered.
8811       --  The reason we cannot use Map directly, is that it may well be
8812       --  (and normally is) initialized to No_Elist, and if we have mapped
8813       --  entities, we have to reset it to point to a real Elist.
8814
8815       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
8816       --  Called during second phase to map entities into their corresponding
8817       --  copies using Actual_Map. If the argument is not an entity, or is not
8818       --  in Actual_Map, then it is returned unchanged.
8819
8820       procedure Build_NCT_Hash_Tables;
8821       --  Builds hash tables (number of elements >= threshold value)
8822
8823       function Copy_Elist_With_Replacement
8824         (Old_Elist : Elist_Id) return Elist_Id;
8825       --  Called during second phase to copy element list doing replacements
8826
8827       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
8828       --  Called during the second phase to process a copied Itype. The actual
8829       --  copy happened during the first phase (so that we could make the entry
8830       --  in the mapping), but we still have to deal with the descendents of
8831       --  the copied Itype and copy them where necessary.
8832
8833       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
8834       --  Called during second phase to copy list doing replacements
8835
8836       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
8837       --  Called during second phase to copy node doing replacements
8838
8839       procedure Visit_Elist (E : Elist_Id);
8840       --  Called during first phase to visit all elements of an Elist
8841
8842       procedure Visit_Field (F : Union_Id; N : Node_Id);
8843       --  Visit a single field, recursing to call Visit_Node or Visit_List
8844       --  if the field is a syntactic descendent of the current node (i.e.
8845       --  its parent is Node N).
8846
8847       procedure Visit_Itype (Old_Itype : Entity_Id);
8848       --  Called during first phase to visit subsidiary fields of a defining
8849       --  Itype, and also create a copy and make an entry in the replacement
8850       --  map for the new copy.
8851
8852       procedure Visit_List (L : List_Id);
8853       --  Called during first phase to visit all elements of a List
8854
8855       procedure Visit_Node (N : Node_Or_Entity_Id);
8856       --  Called during first phase to visit a node and all its subtrees
8857
8858       -----------
8859       -- Assoc --
8860       -----------
8861
8862       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
8863          E   : Elmt_Id;
8864          Ent : Entity_Id;
8865
8866       begin
8867          if not Has_Extension (N) or else No (Actual_Map) then
8868             return N;
8869
8870          elsif NCT_Hash_Tables_Used then
8871             Ent := NCT_Assoc.Get (Entity_Id (N));
8872
8873             if Present (Ent) then
8874                return Ent;
8875             else
8876                return N;
8877             end if;
8878
8879          --  No hash table used, do serial search
8880
8881          else
8882             E := First_Elmt (Actual_Map);
8883             while Present (E) loop
8884                if Node (E) = N then
8885                   return Node (Next_Elmt (E));
8886                else
8887                   E := Next_Elmt (Next_Elmt (E));
8888                end if;
8889             end loop;
8890          end if;
8891
8892          return N;
8893       end Assoc;
8894
8895       ---------------------------
8896       -- Build_NCT_Hash_Tables --
8897       ---------------------------
8898
8899       procedure Build_NCT_Hash_Tables is
8900          Elmt : Elmt_Id;
8901          Ent  : Entity_Id;
8902       begin
8903          if NCT_Hash_Table_Setup then
8904             NCT_Assoc.Reset;
8905             NCT_Itype_Assoc.Reset;
8906          end if;
8907
8908          Elmt := First_Elmt (Actual_Map);
8909          while Present (Elmt) loop
8910             Ent := Node (Elmt);
8911
8912             --  Get new entity, and associate old and new
8913
8914             Next_Elmt (Elmt);
8915             NCT_Assoc.Set (Ent, Node (Elmt));
8916
8917             if Is_Type (Ent) then
8918                declare
8919                   Anode : constant Entity_Id :=
8920                             Associated_Node_For_Itype (Ent);
8921
8922                begin
8923                   if Present (Anode) then
8924
8925                      --  Enter a link between the associated node of the
8926                      --  old Itype and the new Itype, for updating later
8927                      --  when node is copied.
8928
8929                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
8930                   end if;
8931                end;
8932             end if;
8933
8934             Next_Elmt (Elmt);
8935          end loop;
8936
8937          NCT_Hash_Tables_Used := True;
8938          NCT_Hash_Table_Setup := True;
8939       end Build_NCT_Hash_Tables;
8940
8941       ---------------------------------
8942       -- Copy_Elist_With_Replacement --
8943       ---------------------------------
8944
8945       function Copy_Elist_With_Replacement
8946         (Old_Elist : Elist_Id) return Elist_Id
8947       is
8948          M         : Elmt_Id;
8949          New_Elist : Elist_Id;
8950
8951       begin
8952          if No (Old_Elist) then
8953             return No_Elist;
8954
8955          else
8956             New_Elist := New_Elmt_List;
8957
8958             M := First_Elmt (Old_Elist);
8959             while Present (M) loop
8960                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
8961                Next_Elmt (M);
8962             end loop;
8963          end if;
8964
8965          return New_Elist;
8966       end Copy_Elist_With_Replacement;
8967
8968       ---------------------------------
8969       -- Copy_Itype_With_Replacement --
8970       ---------------------------------
8971
8972       --  This routine exactly parallels its phase one analog Visit_Itype,
8973
8974       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
8975       begin
8976          --  Translate Next_Entity, Scope and Etype fields, in case they
8977          --  reference entities that have been mapped into copies.
8978
8979          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
8980          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
8981
8982          if Present (New_Scope) then
8983             Set_Scope    (New_Itype, New_Scope);
8984          else
8985             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
8986          end if;
8987
8988          --  Copy referenced fields
8989
8990          if Is_Discrete_Type (New_Itype) then
8991             Set_Scalar_Range (New_Itype,
8992               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
8993
8994          elsif Has_Discriminants (Base_Type (New_Itype)) then
8995             Set_Discriminant_Constraint (New_Itype,
8996               Copy_Elist_With_Replacement
8997                 (Discriminant_Constraint (New_Itype)));
8998
8999          elsif Is_Array_Type (New_Itype) then
9000             if Present (First_Index (New_Itype)) then
9001                Set_First_Index (New_Itype,
9002                  First (Copy_List_With_Replacement
9003                          (List_Containing (First_Index (New_Itype)))));
9004             end if;
9005
9006             if Is_Packed (New_Itype) then
9007                Set_Packed_Array_Type (New_Itype,
9008                  Copy_Node_With_Replacement
9009                    (Packed_Array_Type (New_Itype)));
9010             end if;
9011          end if;
9012       end Copy_Itype_With_Replacement;
9013
9014       --------------------------------
9015       -- Copy_List_With_Replacement --
9016       --------------------------------
9017
9018       function Copy_List_With_Replacement
9019         (Old_List : List_Id) return List_Id
9020       is
9021          New_List : List_Id;
9022          E        : Node_Id;
9023
9024       begin
9025          if Old_List = No_List then
9026             return No_List;
9027
9028          else
9029             New_List := Empty_List;
9030
9031             E := First (Old_List);
9032             while Present (E) loop
9033                Append (Copy_Node_With_Replacement (E), New_List);
9034                Next (E);
9035             end loop;
9036
9037             return New_List;
9038          end if;
9039       end Copy_List_With_Replacement;
9040
9041       --------------------------------
9042       -- Copy_Node_With_Replacement --
9043       --------------------------------
9044
9045       function Copy_Node_With_Replacement
9046         (Old_Node : Node_Id) return Node_Id
9047       is
9048          New_Node : Node_Id;
9049
9050          procedure Adjust_Named_Associations
9051            (Old_Node : Node_Id;
9052             New_Node : Node_Id);
9053          --  If a call node has named associations, these are chained through
9054          --  the First_Named_Actual, Next_Named_Actual links. These must be
9055          --  propagated separately to the new parameter list, because these
9056          --  are not syntactic fields.
9057
9058          function Copy_Field_With_Replacement
9059            (Field : Union_Id) return Union_Id;
9060          --  Given Field, which is a field of Old_Node, return a copy of it
9061          --  if it is a syntactic field (i.e. its parent is Node), setting
9062          --  the parent of the copy to poit to New_Node. Otherwise returns
9063          --  the field (possibly mapped if it is an entity).
9064
9065          -------------------------------
9066          -- Adjust_Named_Associations --
9067          -------------------------------
9068
9069          procedure Adjust_Named_Associations
9070            (Old_Node : Node_Id;
9071             New_Node : Node_Id)
9072          is
9073             Old_E : Node_Id;
9074             New_E : Node_Id;
9075
9076             Old_Next : Node_Id;
9077             New_Next : Node_Id;
9078
9079          begin
9080             Old_E := First (Parameter_Associations (Old_Node));
9081             New_E := First (Parameter_Associations (New_Node));
9082             while Present (Old_E) loop
9083                if Nkind (Old_E) = N_Parameter_Association
9084                  and then Present (Next_Named_Actual (Old_E))
9085                then
9086                   if First_Named_Actual (Old_Node)
9087                     =  Explicit_Actual_Parameter (Old_E)
9088                   then
9089                      Set_First_Named_Actual
9090                        (New_Node, Explicit_Actual_Parameter (New_E));
9091                   end if;
9092
9093                   --  Now scan parameter list from the beginning,to locate
9094                   --  next named actual, which can be out of order.
9095
9096                   Old_Next := First (Parameter_Associations (Old_Node));
9097                   New_Next := First (Parameter_Associations (New_Node));
9098
9099                   while Nkind (Old_Next) /= N_Parameter_Association
9100                     or else  Explicit_Actual_Parameter (Old_Next)
9101                       /= Next_Named_Actual (Old_E)
9102                   loop
9103                      Next (Old_Next);
9104                      Next (New_Next);
9105                   end loop;
9106
9107                   Set_Next_Named_Actual
9108                     (New_E, Explicit_Actual_Parameter (New_Next));
9109                end if;
9110
9111                Next (Old_E);
9112                Next (New_E);
9113             end loop;
9114          end Adjust_Named_Associations;
9115
9116          ---------------------------------
9117          -- Copy_Field_With_Replacement --
9118          ---------------------------------
9119
9120          function Copy_Field_With_Replacement
9121            (Field : Union_Id) return Union_Id
9122          is
9123          begin
9124             if Field = Union_Id (Empty) then
9125                return Field;
9126
9127             elsif Field in Node_Range then
9128                declare
9129                   Old_N : constant Node_Id := Node_Id (Field);
9130                   New_N : Node_Id;
9131
9132                begin
9133                   --  If syntactic field, as indicated by the parent pointer
9134                   --  being set, then copy the referenced node recursively.
9135
9136                   if Parent (Old_N) = Old_Node then
9137                      New_N := Copy_Node_With_Replacement (Old_N);
9138
9139                      if New_N /= Old_N then
9140                         Set_Parent (New_N, New_Node);
9141                      end if;
9142
9143                   --  For semantic fields, update possible entity reference
9144                   --  from the replacement map.
9145
9146                   else
9147                      New_N := Assoc (Old_N);
9148                   end if;
9149
9150                   return Union_Id (New_N);
9151                end;
9152
9153             elsif Field in List_Range then
9154                declare
9155                   Old_L : constant List_Id := List_Id (Field);
9156                   New_L : List_Id;
9157
9158                begin
9159                   --  If syntactic field, as indicated by the parent pointer,
9160                   --  then recursively copy the entire referenced list.
9161
9162                   if Parent (Old_L) = Old_Node then
9163                      New_L := Copy_List_With_Replacement (Old_L);
9164                      Set_Parent (New_L, New_Node);
9165
9166                   --  For semantic list, just returned unchanged
9167
9168                   else
9169                      New_L := Old_L;
9170                   end if;
9171
9172                   return Union_Id (New_L);
9173                end;
9174
9175             --  Anything other than a list or a node is returned unchanged
9176
9177             else
9178                return Field;
9179             end if;
9180          end Copy_Field_With_Replacement;
9181
9182       --  Start of processing for Copy_Node_With_Replacement
9183
9184       begin
9185          if Old_Node <= Empty_Or_Error then
9186             return Old_Node;
9187
9188          elsif Has_Extension (Old_Node) then
9189             return Assoc (Old_Node);
9190
9191          else
9192             New_Node := New_Copy (Old_Node);
9193
9194             --  If the node we are copying is the associated node of a
9195             --  previously copied Itype, then adjust the associated node
9196             --  of the copy of that Itype accordingly.
9197
9198             if Present (Actual_Map) then
9199                declare
9200                   E   : Elmt_Id;
9201                   Ent : Entity_Id;
9202
9203                begin
9204                   --  Case of hash table used
9205
9206                   if NCT_Hash_Tables_Used then
9207                      Ent := NCT_Itype_Assoc.Get (Old_Node);
9208
9209                      if Present (Ent) then
9210                         Set_Associated_Node_For_Itype (Ent, New_Node);
9211                      end if;
9212
9213                   --  Case of no hash table used
9214
9215                   else
9216                      E := First_Elmt (Actual_Map);
9217                      while Present (E) loop
9218                         if Is_Itype (Node (E))
9219                           and then
9220                             Old_Node = Associated_Node_For_Itype (Node (E))
9221                         then
9222                            Set_Associated_Node_For_Itype
9223                              (Node (Next_Elmt (E)), New_Node);
9224                         end if;
9225
9226                         E := Next_Elmt (Next_Elmt (E));
9227                      end loop;
9228                   end if;
9229                end;
9230             end if;
9231
9232             --  Recursively copy descendents
9233
9234             Set_Field1
9235               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
9236             Set_Field2
9237               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
9238             Set_Field3
9239               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
9240             Set_Field4
9241               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
9242             Set_Field5
9243               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
9244
9245             --  Adjust Sloc of new node if necessary
9246
9247             if New_Sloc /= No_Location then
9248                Set_Sloc (New_Node, New_Sloc);
9249
9250                --  If we adjust the Sloc, then we are essentially making
9251                --  a completely new node, so the Comes_From_Source flag
9252                --  should be reset to the proper default value.
9253
9254                Nodes.Table (New_Node).Comes_From_Source :=
9255                  Default_Node.Comes_From_Source;
9256             end if;
9257
9258             --  If the node is call and has named associations,
9259             --  set the corresponding links in the copy.
9260
9261             if (Nkind (Old_Node) = N_Function_Call
9262                  or else Nkind (Old_Node) = N_Entry_Call_Statement
9263                  or else
9264                    Nkind (Old_Node) = N_Procedure_Call_Statement)
9265               and then Present (First_Named_Actual (Old_Node))
9266             then
9267                Adjust_Named_Associations (Old_Node, New_Node);
9268             end if;
9269
9270             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
9271             --  The replacement mechanism applies to entities, and is not used
9272             --  here. Eventually we may need a more general graph-copying
9273             --  routine. For now, do a sequential search to find desired node.
9274
9275             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
9276               and then Present (First_Real_Statement (Old_Node))
9277             then
9278                declare
9279                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
9280                   N1, N2 : Node_Id;
9281
9282                begin
9283                   N1 := First (Statements (Old_Node));
9284                   N2 := First (Statements (New_Node));
9285
9286                   while N1 /= Old_F loop
9287                      Next (N1);
9288                      Next (N2);
9289                   end loop;
9290
9291                   Set_First_Real_Statement (New_Node, N2);
9292                end;
9293             end if;
9294          end if;
9295
9296          --  All done, return copied node
9297
9298          return New_Node;
9299       end Copy_Node_With_Replacement;
9300
9301       -----------------
9302       -- Visit_Elist --
9303       -----------------
9304
9305       procedure Visit_Elist (E : Elist_Id) is
9306          Elmt : Elmt_Id;
9307       begin
9308          if Present (E) then
9309             Elmt := First_Elmt (E);
9310
9311             while Elmt /= No_Elmt loop
9312                Visit_Node (Node (Elmt));
9313                Next_Elmt (Elmt);
9314             end loop;
9315          end if;
9316       end Visit_Elist;
9317
9318       -----------------
9319       -- Visit_Field --
9320       -----------------
9321
9322       procedure Visit_Field (F : Union_Id; N : Node_Id) is
9323       begin
9324          if F = Union_Id (Empty) then
9325             return;
9326
9327          elsif F in Node_Range then
9328
9329             --  Copy node if it is syntactic, i.e. its parent pointer is
9330             --  set to point to the field that referenced it (certain
9331             --  Itypes will also meet this criterion, which is fine, since
9332             --  these are clearly Itypes that do need to be copied, since
9333             --  we are copying their parent.)
9334
9335             if Parent (Node_Id (F)) = N then
9336                Visit_Node (Node_Id (F));
9337                return;
9338
9339             --  Another case, if we are pointing to an Itype, then we want
9340             --  to copy it if its associated node is somewhere in the tree
9341             --  being copied.
9342
9343             --  Note: the exclusion of self-referential copies is just an
9344             --  optimization, since the search of the already copied list
9345             --  would catch it, but it is a common case (Etype pointing
9346             --  to itself for an Itype that is a base type).
9347
9348             elsif Has_Extension (Node_Id (F))
9349               and then Is_Itype (Entity_Id (F))
9350               and then Node_Id (F) /= N
9351             then
9352                declare
9353                   P : Node_Id;
9354
9355                begin
9356                   P := Associated_Node_For_Itype (Node_Id (F));
9357                   while Present (P) loop
9358                      if P = Source then
9359                         Visit_Node (Node_Id (F));
9360                         return;
9361                      else
9362                         P := Parent (P);
9363                      end if;
9364                   end loop;
9365
9366                   --  An Itype whose parent is not being copied definitely
9367                   --  should NOT be copied, since it does not belong in any
9368                   --  sense to the copied subtree.
9369
9370                   return;
9371                end;
9372             end if;
9373
9374          elsif F in List_Range
9375            and then Parent (List_Id (F)) = N
9376          then
9377             Visit_List (List_Id (F));
9378             return;
9379          end if;
9380       end Visit_Field;
9381
9382       -----------------
9383       -- Visit_Itype --
9384       -----------------
9385
9386       procedure Visit_Itype (Old_Itype : Entity_Id) is
9387          New_Itype : Entity_Id;
9388          E         : Elmt_Id;
9389          Ent       : Entity_Id;
9390
9391       begin
9392          --  Itypes that describe the designated type of access to subprograms
9393          --  have the structure of subprogram declarations, with signatures,
9394          --  etc. Either we duplicate the signatures completely, or choose to
9395          --  share such itypes, which is fine because their elaboration will
9396          --  have no side effects.
9397
9398          if Ekind (Old_Itype) = E_Subprogram_Type then
9399             return;
9400          end if;
9401
9402          New_Itype := New_Copy (Old_Itype);
9403
9404          --  The new Itype has all the attributes of the old one, and
9405          --  we just copy the contents of the entity. However, the back-end
9406          --  needs different names for debugging purposes, so we create a
9407          --  new internal name for it in all cases.
9408
9409          Set_Chars (New_Itype, New_Internal_Name ('T'));
9410
9411          --  If our associated node is an entity that has already been copied,
9412          --  then set the associated node of the copy to point to the right
9413          --  copy. If we have copied an Itype that is itself the associated
9414          --  node of some previously copied Itype, then we set the right
9415          --  pointer in the other direction.
9416
9417          if Present (Actual_Map) then
9418
9419             --  Case of hash tables used
9420
9421             if NCT_Hash_Tables_Used then
9422
9423                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
9424
9425                if Present (Ent) then
9426                   Set_Associated_Node_For_Itype (New_Itype, Ent);
9427                end if;
9428
9429                Ent := NCT_Itype_Assoc.Get (Old_Itype);
9430                if Present (Ent) then
9431                   Set_Associated_Node_For_Itype (Ent, New_Itype);
9432
9433                --  If the hash table has no association for this Itype and
9434                --  its associated node, enter one now.
9435
9436                else
9437                   NCT_Itype_Assoc.Set
9438                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
9439                end if;
9440
9441             --  Case of hash tables not used
9442
9443             else
9444                E := First_Elmt (Actual_Map);
9445                while Present (E) loop
9446                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
9447                      Set_Associated_Node_For_Itype
9448                        (New_Itype, Node (Next_Elmt (E)));
9449                   end if;
9450
9451                   if Is_Type (Node (E))
9452                     and then
9453                       Old_Itype = Associated_Node_For_Itype (Node (E))
9454                   then
9455                      Set_Associated_Node_For_Itype
9456                        (Node (Next_Elmt (E)), New_Itype);
9457                   end if;
9458
9459                   E := Next_Elmt (Next_Elmt (E));
9460                end loop;
9461             end if;
9462          end if;
9463
9464          if Present (Freeze_Node (New_Itype)) then
9465             Set_Is_Frozen (New_Itype, False);
9466             Set_Freeze_Node (New_Itype, Empty);
9467          end if;
9468
9469          --  Add new association to map
9470
9471          if No (Actual_Map) then
9472             Actual_Map := New_Elmt_List;
9473          end if;
9474
9475          Append_Elmt (Old_Itype, Actual_Map);
9476          Append_Elmt (New_Itype, Actual_Map);
9477
9478          if NCT_Hash_Tables_Used then
9479             NCT_Assoc.Set (Old_Itype, New_Itype);
9480
9481          else
9482             NCT_Table_Entries := NCT_Table_Entries + 1;
9483
9484             if NCT_Table_Entries > NCT_Hash_Threshold then
9485                Build_NCT_Hash_Tables;
9486             end if;
9487          end if;
9488
9489          --  If a record subtype is simply copied, the entity list will be
9490          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
9491
9492          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
9493             Set_Cloned_Subtype (New_Itype, Old_Itype);
9494          end if;
9495
9496          --  Visit descendents that eventually get copied
9497
9498          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
9499
9500          if Is_Discrete_Type (Old_Itype) then
9501             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
9502
9503          elsif Has_Discriminants (Base_Type (Old_Itype)) then
9504             --  ??? This should involve call to Visit_Field
9505             Visit_Elist (Discriminant_Constraint (Old_Itype));
9506
9507          elsif Is_Array_Type (Old_Itype) then
9508             if Present (First_Index (Old_Itype)) then
9509                Visit_Field (Union_Id (List_Containing
9510                                 (First_Index (Old_Itype))),
9511                             Old_Itype);
9512             end if;
9513
9514             if Is_Packed (Old_Itype) then
9515                Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
9516                             Old_Itype);
9517             end if;
9518          end if;
9519       end Visit_Itype;
9520
9521       ----------------
9522       -- Visit_List --
9523       ----------------
9524
9525       procedure Visit_List (L : List_Id) is
9526          N : Node_Id;
9527       begin
9528          if L /= No_List then
9529             N := First (L);
9530
9531             while Present (N) loop
9532                Visit_Node (N);
9533                Next (N);
9534             end loop;
9535          end if;
9536       end Visit_List;
9537
9538       ----------------
9539       -- Visit_Node --
9540       ----------------
9541
9542       procedure Visit_Node (N : Node_Or_Entity_Id) is
9543
9544       --  Start of processing for Visit_Node
9545
9546       begin
9547          --  Handle case of an Itype, which must be copied
9548
9549          if Has_Extension (N)
9550            and then Is_Itype (N)
9551          then
9552             --  Nothing to do if already in the list. This can happen with an
9553             --  Itype entity that appears more than once in the tree.
9554             --  Note that we do not want to visit descendents in this case.
9555
9556             --  Test for already in list when hash table is used
9557
9558             if NCT_Hash_Tables_Used then
9559                if Present (NCT_Assoc.Get (Entity_Id (N))) then
9560                   return;
9561                end if;
9562
9563             --  Test for already in list when hash table not used
9564
9565             else
9566                declare
9567                   E : Elmt_Id;
9568                begin
9569                   if Present (Actual_Map) then
9570                      E := First_Elmt (Actual_Map);
9571                      while Present (E) loop
9572                         if Node (E) = N then
9573                            return;
9574                         else
9575                            E := Next_Elmt (Next_Elmt (E));
9576                         end if;
9577                      end loop;
9578                   end if;
9579                end;
9580             end if;
9581
9582             Visit_Itype (N);
9583          end if;
9584
9585          --  Visit descendents
9586
9587          Visit_Field (Field1 (N), N);
9588          Visit_Field (Field2 (N), N);
9589          Visit_Field (Field3 (N), N);
9590          Visit_Field (Field4 (N), N);
9591          Visit_Field (Field5 (N), N);
9592       end Visit_Node;
9593
9594    --  Start of processing for New_Copy_Tree
9595
9596    begin
9597       Actual_Map := Map;
9598
9599       --  See if we should use hash table
9600
9601       if No (Actual_Map) then
9602          NCT_Hash_Tables_Used := False;
9603
9604       else
9605          declare
9606             Elmt : Elmt_Id;
9607
9608          begin
9609             NCT_Table_Entries := 0;
9610
9611             Elmt := First_Elmt (Actual_Map);
9612             while Present (Elmt) loop
9613                NCT_Table_Entries := NCT_Table_Entries + 1;
9614                Next_Elmt (Elmt);
9615                Next_Elmt (Elmt);
9616             end loop;
9617
9618             if NCT_Table_Entries > NCT_Hash_Threshold then
9619                Build_NCT_Hash_Tables;
9620             else
9621                NCT_Hash_Tables_Used := False;
9622             end if;
9623          end;
9624       end if;
9625
9626       --  Hash table set up if required, now start phase one by visiting
9627       --  top node (we will recursively visit the descendents).
9628
9629       Visit_Node (Source);
9630
9631       --  Now the second phase of the copy can start. First we process
9632       --  all the mapped entities, copying their descendents.
9633
9634       if Present (Actual_Map) then
9635          declare
9636             Elmt      : Elmt_Id;
9637             New_Itype : Entity_Id;
9638          begin
9639             Elmt := First_Elmt (Actual_Map);
9640             while Present (Elmt) loop
9641                Next_Elmt (Elmt);
9642                New_Itype := Node (Elmt);
9643                Copy_Itype_With_Replacement (New_Itype);
9644                Next_Elmt (Elmt);
9645             end loop;
9646          end;
9647       end if;
9648
9649       --  Now we can copy the actual tree
9650
9651       return Copy_Node_With_Replacement (Source);
9652    end New_Copy_Tree;
9653
9654    -------------------------
9655    -- New_External_Entity --
9656    -------------------------
9657
9658    function New_External_Entity
9659      (Kind         : Entity_Kind;
9660       Scope_Id     : Entity_Id;
9661       Sloc_Value   : Source_Ptr;
9662       Related_Id   : Entity_Id;
9663       Suffix       : Character;
9664       Suffix_Index : Nat := 0;
9665       Prefix       : Character := ' ') return Entity_Id
9666    is
9667       N : constant Entity_Id :=
9668             Make_Defining_Identifier (Sloc_Value,
9669               New_External_Name
9670                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
9671
9672    begin
9673       Set_Ekind          (N, Kind);
9674       Set_Is_Internal    (N, True);
9675       Append_Entity      (N, Scope_Id);
9676       Set_Public_Status  (N);
9677
9678       if Kind in Type_Kind then
9679          Init_Size_Align (N);
9680       end if;
9681
9682       return N;
9683    end New_External_Entity;
9684
9685    -------------------------
9686    -- New_Internal_Entity --
9687    -------------------------
9688
9689    function New_Internal_Entity
9690      (Kind       : Entity_Kind;
9691       Scope_Id   : Entity_Id;
9692       Sloc_Value : Source_Ptr;
9693       Id_Char    : Character) return Entity_Id
9694    is
9695       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
9696
9697    begin
9698       Set_Ekind          (N, Kind);
9699       Set_Is_Internal    (N, True);
9700       Append_Entity      (N, Scope_Id);
9701
9702       if Kind in Type_Kind then
9703          Init_Size_Align (N);
9704       end if;
9705
9706       return N;
9707    end New_Internal_Entity;
9708
9709    -----------------
9710    -- Next_Actual --
9711    -----------------
9712
9713    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
9714       N  : Node_Id;
9715
9716    begin
9717       --  If we are pointing at a positional parameter, it is a member of a
9718       --  node list (the list of parameters), and the next parameter is the
9719       --  next node on the list, unless we hit a parameter association, then
9720       --  we shift to using the chain whose head is the First_Named_Actual in
9721       --  the parent, and then is threaded using the Next_Named_Actual of the
9722       --  Parameter_Association. All this fiddling is because the original node
9723       --  list is in the textual call order, and what we need is the
9724       --  declaration order.
9725
9726       if Is_List_Member (Actual_Id) then
9727          N := Next (Actual_Id);
9728
9729          if Nkind (N) = N_Parameter_Association then
9730             return First_Named_Actual (Parent (Actual_Id));
9731          else
9732             return N;
9733          end if;
9734
9735       else
9736          return Next_Named_Actual (Parent (Actual_Id));
9737       end if;
9738    end Next_Actual;
9739
9740    procedure Next_Actual (Actual_Id : in out Node_Id) is
9741    begin
9742       Actual_Id := Next_Actual (Actual_Id);
9743    end Next_Actual;
9744
9745    -----------------------
9746    -- Normalize_Actuals --
9747    -----------------------
9748
9749    --  Chain actuals according to formals of subprogram. If there are no named
9750    --  associations, the chain is simply the list of Parameter Associations,
9751    --  since the order is the same as the declaration order. If there are named
9752    --  associations, then the First_Named_Actual field in the N_Function_Call
9753    --  or N_Procedure_Call_Statement node points to the Parameter_Association
9754    --  node for the parameter that comes first in declaration order. The
9755    --  remaining named parameters are then chained in declaration order using
9756    --  Next_Named_Actual.
9757
9758    --  This routine also verifies that the number of actuals is compatible with
9759    --  the number and default values of formals, but performs no type checking
9760    --  (type checking is done by the caller).
9761
9762    --  If the matching succeeds, Success is set to True and the caller proceeds
9763    --  with type-checking. If the match is unsuccessful, then Success is set to
9764    --  False, and the caller attempts a different interpretation, if there is
9765    --  one.
9766
9767    --  If the flag Report is on, the call is not overloaded, and a failure to
9768    --  match can be reported here, rather than in the caller.
9769
9770    procedure Normalize_Actuals
9771      (N       : Node_Id;
9772       S       : Entity_Id;
9773       Report  : Boolean;
9774       Success : out Boolean)
9775    is
9776       Actuals     : constant List_Id := Parameter_Associations (N);
9777       Actual      : Node_Id := Empty;
9778       Formal      : Entity_Id;
9779       Last        : Node_Id := Empty;
9780       First_Named : Node_Id := Empty;
9781       Found       : Boolean;
9782
9783       Formals_To_Match : Integer := 0;
9784       Actuals_To_Match : Integer := 0;
9785
9786       procedure Chain (A : Node_Id);
9787       --  Add named actual at the proper place in the list, using the
9788       --  Next_Named_Actual link.
9789
9790       function Reporting return Boolean;
9791       --  Determines if an error is to be reported. To report an error, we
9792       --  need Report to be True, and also we do not report errors caused
9793       --  by calls to init procs that occur within other init procs. Such
9794       --  errors must always be cascaded errors, since if all the types are
9795       --  declared correctly, the compiler will certainly build decent calls!
9796
9797       -----------
9798       -- Chain --
9799       -----------
9800
9801       procedure Chain (A : Node_Id) is
9802       begin
9803          if No (Last) then
9804
9805             --  Call node points to first actual in list
9806
9807             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
9808
9809          else
9810             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
9811          end if;
9812
9813          Last := A;
9814          Set_Next_Named_Actual (Last, Empty);
9815       end Chain;
9816
9817       ---------------
9818       -- Reporting --
9819       ---------------
9820
9821       function Reporting return Boolean is
9822       begin
9823          if not Report then
9824             return False;
9825
9826          elsif not Within_Init_Proc then
9827             return True;
9828
9829          elsif Is_Init_Proc (Entity (Name (N))) then
9830             return False;
9831
9832          else
9833             return True;
9834          end if;
9835       end Reporting;
9836
9837    --  Start of processing for Normalize_Actuals
9838
9839    begin
9840       if Is_Access_Type (S) then
9841
9842          --  The name in the call is a function call that returns an access
9843          --  to subprogram. The designated type has the list of formals.
9844
9845          Formal := First_Formal (Designated_Type (S));
9846       else
9847          Formal := First_Formal (S);
9848       end if;
9849
9850       while Present (Formal) loop
9851          Formals_To_Match := Formals_To_Match + 1;
9852          Next_Formal (Formal);
9853       end loop;
9854
9855       --  Find if there is a named association, and verify that no positional
9856       --  associations appear after named ones.
9857
9858       if Present (Actuals) then
9859          Actual := First (Actuals);
9860       end if;
9861
9862       while Present (Actual)
9863         and then Nkind (Actual) /= N_Parameter_Association
9864       loop
9865          Actuals_To_Match := Actuals_To_Match + 1;
9866          Next (Actual);
9867       end loop;
9868
9869       if No (Actual) and Actuals_To_Match = Formals_To_Match then
9870
9871          --  Most common case: positional notation, no defaults
9872
9873          Success := True;
9874          return;
9875
9876       elsif Actuals_To_Match > Formals_To_Match then
9877
9878          --  Too many actuals: will not work
9879
9880          if Reporting then
9881             if Is_Entity_Name (Name (N)) then
9882                Error_Msg_N ("too many arguments in call to&", Name (N));
9883             else
9884                Error_Msg_N ("too many arguments in call", N);
9885             end if;
9886          end if;
9887
9888          Success := False;
9889          return;
9890       end if;
9891
9892       First_Named := Actual;
9893
9894       while Present (Actual) loop
9895          if Nkind (Actual) /= N_Parameter_Association then
9896             Error_Msg_N
9897               ("positional parameters not allowed after named ones", Actual);
9898             Success := False;
9899             return;
9900
9901          else
9902             Actuals_To_Match := Actuals_To_Match + 1;
9903          end if;
9904
9905          Next (Actual);
9906       end loop;
9907
9908       if Present (Actuals) then
9909          Actual := First (Actuals);
9910       end if;
9911
9912       Formal := First_Formal (S);
9913       while Present (Formal) loop
9914
9915          --  Match the formals in order. If the corresponding actual is
9916          --  positional, nothing to do. Else scan the list of named actuals
9917          --  to find the one with the right name.
9918
9919          if Present (Actual)
9920            and then Nkind (Actual) /= N_Parameter_Association
9921          then
9922             Next (Actual);
9923             Actuals_To_Match := Actuals_To_Match - 1;
9924             Formals_To_Match := Formals_To_Match - 1;
9925
9926          else
9927             --  For named parameters, search the list of actuals to find
9928             --  one that matches the next formal name.
9929
9930             Actual := First_Named;
9931             Found  := False;
9932             while Present (Actual) loop
9933                if Chars (Selector_Name (Actual)) = Chars (Formal) then
9934                   Found := True;
9935                   Chain (Actual);
9936                   Actuals_To_Match := Actuals_To_Match - 1;
9937                   Formals_To_Match := Formals_To_Match - 1;
9938                   exit;
9939                end if;
9940
9941                Next (Actual);
9942             end loop;
9943
9944             if not Found then
9945                if Ekind (Formal) /= E_In_Parameter
9946                  or else No (Default_Value (Formal))
9947                then
9948                   if Reporting then
9949                      if (Comes_From_Source (S)
9950                           or else Sloc (S) = Standard_Location)
9951                        and then Is_Overloadable (S)
9952                      then
9953                         if No (Actuals)
9954                           and then
9955                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
9956                              or else
9957                            (Nkind (Parent (N)) = N_Function_Call
9958                              or else
9959                             Nkind (Parent (N)) = N_Parameter_Association))
9960                           and then Ekind (S) /= E_Function
9961                         then
9962                            Set_Etype (N, Etype (S));
9963                         else
9964                            Error_Msg_Name_1 := Chars (S);
9965                            Error_Msg_Sloc := Sloc (S);
9966                            Error_Msg_NE
9967                              ("missing argument for parameter & " &
9968                                 "in call to % declared #", N, Formal);
9969                         end if;
9970
9971                      elsif Is_Overloadable (S) then
9972                         Error_Msg_Name_1 := Chars (S);
9973
9974                         --  Point to type derivation that generated the
9975                         --  operation.
9976
9977                         Error_Msg_Sloc := Sloc (Parent (S));
9978
9979                         Error_Msg_NE
9980                           ("missing argument for parameter & " &
9981                              "in call to % (inherited) #", N, Formal);
9982
9983                      else
9984                         Error_Msg_NE
9985                           ("missing argument for parameter &", N, Formal);
9986                      end if;
9987                   end if;
9988
9989                   Success := False;
9990                   return;
9991
9992                else
9993                   Formals_To_Match := Formals_To_Match - 1;
9994                end if;
9995             end if;
9996          end if;
9997
9998          Next_Formal (Formal);
9999       end loop;
10000
10001       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
10002          Success := True;
10003          return;
10004
10005       else
10006          if Reporting then
10007
10008             --  Find some superfluous named actual that did not get
10009             --  attached to the list of associations.
10010
10011             Actual := First (Actuals);
10012             while Present (Actual) loop
10013                if Nkind (Actual) = N_Parameter_Association
10014                  and then Actual /= Last
10015                  and then No (Next_Named_Actual (Actual))
10016                then
10017                   Error_Msg_N ("unmatched actual & in call",
10018                     Selector_Name (Actual));
10019                   exit;
10020                end if;
10021
10022                Next (Actual);
10023             end loop;
10024          end if;
10025
10026          Success := False;
10027          return;
10028       end if;
10029    end Normalize_Actuals;
10030
10031    --------------------------------
10032    -- Note_Possible_Modification --
10033    --------------------------------
10034
10035    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
10036       Modification_Comes_From_Source : constant Boolean :=
10037                                          Comes_From_Source (Parent (N));
10038
10039       Ent : Entity_Id;
10040       Exp : Node_Id;
10041
10042    begin
10043       --  Loop to find referenced entity, if there is one
10044
10045       Exp := N;
10046       loop
10047          <<Continue>>
10048          Ent := Empty;
10049
10050          if Is_Entity_Name (Exp) then
10051             Ent := Entity (Exp);
10052
10053             --  If the entity is missing, it is an undeclared identifier,
10054             --  and there is nothing to annotate.
10055
10056             if No (Ent) then
10057                return;
10058             end if;
10059
10060          elsif Nkind (Exp) = N_Explicit_Dereference then
10061             declare
10062                P : constant Node_Id := Prefix (Exp);
10063
10064             begin
10065                if Nkind (P) = N_Selected_Component
10066                  and then Present (
10067                    Entry_Formal (Entity (Selector_Name (P))))
10068                then
10069                   --  Case of a reference to an entry formal
10070
10071                   Ent := Entry_Formal (Entity (Selector_Name (P)));
10072
10073                elsif Nkind (P) = N_Identifier
10074                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
10075                  and then Present (Expression (Parent (Entity (P))))
10076                  and then Nkind (Expression (Parent (Entity (P))))
10077                    = N_Reference
10078                then
10079                   --  Case of a reference to a value on which side effects have
10080                   --  been removed.
10081
10082                   Exp := Prefix (Expression (Parent (Entity (P))));
10083                   goto Continue;
10084
10085                else
10086                   return;
10087
10088                end if;
10089             end;
10090
10091          elsif     Nkind (Exp) = N_Type_Conversion
10092            or else Nkind (Exp) = N_Unchecked_Type_Conversion
10093          then
10094             Exp := Expression (Exp);
10095             goto Continue;
10096
10097          elsif     Nkind (Exp) = N_Slice
10098            or else Nkind (Exp) = N_Indexed_Component
10099            or else Nkind (Exp) = N_Selected_Component
10100          then
10101             Exp := Prefix (Exp);
10102             goto Continue;
10103
10104          else
10105             return;
10106          end if;
10107
10108          --  Now look for entity being referenced
10109
10110          if Present (Ent) then
10111             if Is_Object (Ent) then
10112                if Comes_From_Source (Exp)
10113                  or else Modification_Comes_From_Source
10114                then
10115                   --  Give warning if pragma unmodified given and we are
10116                   --  sure this is a modification.
10117
10118                   if Has_Pragma_Unmodified (Ent) and then Sure then
10119                      Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
10120                   end if;
10121
10122                   Set_Never_Set_In_Source (Ent, False);
10123                end if;
10124
10125                Set_Is_True_Constant (Ent, False);
10126                Set_Current_Value    (Ent, Empty);
10127                Set_Is_Known_Null    (Ent, False);
10128
10129                if not Can_Never_Be_Null (Ent) then
10130                   Set_Is_Known_Non_Null (Ent, False);
10131                end if;
10132
10133                --  Follow renaming chain
10134
10135                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
10136                  and then Present (Renamed_Object (Ent))
10137                then
10138                   Exp := Renamed_Object (Ent);
10139                   goto Continue;
10140                end if;
10141
10142                --  Generate a reference only if the assignment comes from
10143                --  source. This excludes, for example, calls to a dispatching
10144                --  assignment operation when the left-hand side is tagged.
10145
10146                if Modification_Comes_From_Source then
10147                   Generate_Reference (Ent, Exp, 'm');
10148
10149                   --  If the target of the assignment is the bound variable
10150                   --  in an iterator, indicate that the corresponding array
10151                   --  or container is also modified.
10152
10153                   if Ada_Version >= Ada_2012
10154                     and then
10155                       Nkind (Parent (Ent)) = N_Iterator_Specification
10156                   then
10157                      declare
10158                         Domain : constant Node_Id := Name (Parent (Ent));
10159
10160                      begin
10161                         --  TBD : in the full version of the construct, the
10162                         --  domain of iteration can be given by an expression.
10163
10164                         if Is_Entity_Name (Domain) then
10165                            Generate_Reference      (Entity (Domain), Exp, 'm');
10166                            Set_Is_True_Constant    (Entity (Domain), False);
10167                            Set_Never_Set_In_Source (Entity (Domain), False);
10168                         end if;
10169                      end;
10170                   end if;
10171                end if;
10172
10173                Check_Nested_Access (Ent);
10174             end if;
10175
10176             Kill_Checks (Ent);
10177
10178             --  If we are sure this is a modification from source, and we know
10179             --  this modifies a constant, then give an appropriate warning.
10180
10181             if Overlays_Constant (Ent)
10182               and then Modification_Comes_From_Source
10183               and then Sure
10184             then
10185                declare
10186                   A : constant Node_Id := Address_Clause (Ent);
10187                begin
10188                   if Present (A) then
10189                      declare
10190                         Exp : constant Node_Id := Expression (A);
10191                      begin
10192                         if Nkind (Exp) = N_Attribute_Reference
10193                           and then Attribute_Name (Exp) = Name_Address
10194                           and then Is_Entity_Name (Prefix (Exp))
10195                         then
10196                            Error_Msg_Sloc := Sloc (A);
10197                            Error_Msg_NE
10198                              ("constant& may be modified via address clause#?",
10199                               N, Entity (Prefix (Exp)));
10200                         end if;
10201                      end;
10202                   end if;
10203                end;
10204             end if;
10205
10206             return;
10207          end if;
10208       end loop;
10209    end Note_Possible_Modification;
10210
10211    -------------------------
10212    -- Object_Access_Level --
10213    -------------------------
10214
10215    function Object_Access_Level (Obj : Node_Id) return Uint is
10216       E : Entity_Id;
10217
10218    --  Returns the static accessibility level of the view denoted by Obj. Note
10219    --  that the value returned is the result of a call to Scope_Depth. Only
10220    --  scope depths associated with dynamic scopes can actually be returned.
10221    --  Since only relative levels matter for accessibility checking, the fact
10222    --  that the distance between successive levels of accessibility is not
10223    --  always one is immaterial (invariant: if level(E2) is deeper than
10224    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
10225
10226       function Reference_To (Obj : Node_Id) return Node_Id;
10227       --  An explicit dereference is created when removing side-effects from
10228       --  expressions for constraint checking purposes. In this case a local
10229       --  access type is created for it. The correct access level is that of
10230       --  the original source node. We detect this case by noting that the
10231       --  prefix of the dereference is created by an object declaration whose
10232       --  initial expression is a reference.
10233
10234       ------------------
10235       -- Reference_To --
10236       ------------------
10237
10238       function Reference_To (Obj : Node_Id) return Node_Id is
10239          Pref : constant Node_Id := Prefix (Obj);
10240       begin
10241          if Is_Entity_Name (Pref)
10242            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
10243            and then Present (Expression (Parent (Entity (Pref))))
10244            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
10245          then
10246             return (Prefix (Expression (Parent (Entity (Pref)))));
10247          else
10248             return Empty;
10249          end if;
10250       end Reference_To;
10251
10252    --  Start of processing for Object_Access_Level
10253
10254    begin
10255       if Is_Entity_Name (Obj) then
10256          E := Entity (Obj);
10257
10258          if Is_Prival (E) then
10259             E := Prival_Link (E);
10260          end if;
10261
10262          --  If E is a type then it denotes a current instance. For this case
10263          --  we add one to the normal accessibility level of the type to ensure
10264          --  that current instances are treated as always being deeper than
10265          --  than the level of any visible named access type (see 3.10.2(21)).
10266
10267          if Is_Type (E) then
10268             return Type_Access_Level (E) +  1;
10269
10270          elsif Present (Renamed_Object (E)) then
10271             return Object_Access_Level (Renamed_Object (E));
10272
10273          --  Similarly, if E is a component of the current instance of a
10274          --  protected type, any instance of it is assumed to be at a deeper
10275          --  level than the type. For a protected object (whose type is an
10276          --  anonymous protected type) its components are at the same level
10277          --  as the type itself.
10278
10279          elsif not Is_Overloadable (E)
10280            and then Ekind (Scope (E)) = E_Protected_Type
10281            and then Comes_From_Source (Scope (E))
10282          then
10283             return Type_Access_Level (Scope (E)) + 1;
10284
10285          else
10286             return Scope_Depth (Enclosing_Dynamic_Scope (E));
10287          end if;
10288
10289       elsif Nkind (Obj) = N_Selected_Component then
10290          if Is_Access_Type (Etype (Prefix (Obj))) then
10291             return Type_Access_Level (Etype (Prefix (Obj)));
10292          else
10293             return Object_Access_Level (Prefix (Obj));
10294          end if;
10295
10296       elsif Nkind (Obj) = N_Indexed_Component then
10297          if Is_Access_Type (Etype (Prefix (Obj))) then
10298             return Type_Access_Level (Etype (Prefix (Obj)));
10299          else
10300             return Object_Access_Level (Prefix (Obj));
10301          end if;
10302
10303       elsif Nkind (Obj) = N_Explicit_Dereference then
10304
10305          --  If the prefix is a selected access discriminant then we make a
10306          --  recursive call on the prefix, which will in turn check the level
10307          --  of the prefix object of the selected discriminant.
10308
10309          if Nkind (Prefix (Obj)) = N_Selected_Component
10310            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
10311            and then
10312              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
10313          then
10314             return Object_Access_Level (Prefix (Obj));
10315
10316          elsif not (Comes_From_Source (Obj)) then
10317             declare
10318                Ref : constant Node_Id := Reference_To (Obj);
10319             begin
10320                if Present (Ref) then
10321                   return Object_Access_Level (Ref);
10322                else
10323                   return Type_Access_Level (Etype (Prefix (Obj)));
10324                end if;
10325             end;
10326
10327          else
10328             return Type_Access_Level (Etype (Prefix (Obj)));
10329          end if;
10330
10331       elsif Nkind (Obj) = N_Type_Conversion
10332         or else Nkind (Obj) = N_Unchecked_Type_Conversion
10333       then
10334          return Object_Access_Level (Expression (Obj));
10335
10336       elsif Nkind (Obj) = N_Function_Call then
10337
10338          --  Function results are objects, so we get either the access level of
10339          --  the function or, in the case of an indirect call, the level of the
10340          --  access-to-subprogram type. (This code is used for Ada 95, but it
10341          --  looks wrong, because it seems that we should be checking the level
10342          --  of the call itself, even for Ada 95. However, using the Ada 2005
10343          --  version of the code causes regressions in several tests that are
10344          --  compiled with -gnat95. ???)
10345
10346          if Ada_Version < Ada_2005 then
10347             if Is_Entity_Name (Name (Obj)) then
10348                return Subprogram_Access_Level (Entity (Name (Obj)));
10349             else
10350                return Type_Access_Level (Etype (Prefix (Name (Obj))));
10351             end if;
10352
10353          --  For Ada 2005, the level of the result object of a function call is
10354          --  defined to be the level of the call's innermost enclosing master.
10355          --  We determine that by querying the depth of the innermost enclosing
10356          --  dynamic scope.
10357
10358          else
10359             Return_Master_Scope_Depth_Of_Call : declare
10360
10361                function Innermost_Master_Scope_Depth
10362                  (N : Node_Id) return Uint;
10363                --  Returns the scope depth of the given node's innermost
10364                --  enclosing dynamic scope (effectively the accessibility
10365                --  level of the innermost enclosing master).
10366
10367                ----------------------------------
10368                -- Innermost_Master_Scope_Depth --
10369                ----------------------------------
10370
10371                function Innermost_Master_Scope_Depth
10372                  (N : Node_Id) return Uint
10373                is
10374                   Node_Par : Node_Id := Parent (N);
10375
10376                begin
10377                   --  Locate the nearest enclosing node (by traversing Parents)
10378                   --  that Defining_Entity can be applied to, and return the
10379                   --  depth of that entity's nearest enclosing dynamic scope.
10380
10381                   while Present (Node_Par) loop
10382                      case Nkind (Node_Par) is
10383                         when N_Component_Declaration           |
10384                              N_Entry_Declaration               |
10385                              N_Formal_Object_Declaration       |
10386                              N_Formal_Type_Declaration         |
10387                              N_Full_Type_Declaration           |
10388                              N_Incomplete_Type_Declaration     |
10389                              N_Loop_Parameter_Specification    |
10390                              N_Object_Declaration              |
10391                              N_Protected_Type_Declaration      |
10392                              N_Private_Extension_Declaration   |
10393                              N_Private_Type_Declaration        |
10394                              N_Subtype_Declaration             |
10395                              N_Function_Specification          |
10396                              N_Procedure_Specification         |
10397                              N_Task_Type_Declaration           |
10398                              N_Body_Stub                       |
10399                              N_Generic_Instantiation           |
10400                              N_Proper_Body                     |
10401                              N_Implicit_Label_Declaration      |
10402                              N_Package_Declaration             |
10403                              N_Single_Task_Declaration         |
10404                              N_Subprogram_Declaration          |
10405                              N_Generic_Declaration             |
10406                              N_Renaming_Declaration            |
10407                              N_Block_Statement                 |
10408                              N_Formal_Subprogram_Declaration   |
10409                              N_Abstract_Subprogram_Declaration |
10410                              N_Entry_Body                      |
10411                              N_Exception_Declaration           |
10412                              N_Formal_Package_Declaration      |
10413                              N_Number_Declaration              |
10414                              N_Package_Specification           |
10415                              N_Parameter_Specification         |
10416                              N_Single_Protected_Declaration    |
10417                              N_Subunit                         =>
10418
10419                            return Scope_Depth
10420                                     (Nearest_Dynamic_Scope
10421                                        (Defining_Entity (Node_Par)));
10422
10423                         when others =>
10424                            null;
10425                      end case;
10426
10427                      Node_Par := Parent (Node_Par);
10428                   end loop;
10429
10430                   pragma Assert (False);
10431
10432                   --  Should never reach the following return
10433
10434                   return Scope_Depth (Current_Scope) + 1;
10435                end Innermost_Master_Scope_Depth;
10436
10437             --  Start of processing for Return_Master_Scope_Depth_Of_Call
10438
10439             begin
10440                return Innermost_Master_Scope_Depth (Obj);
10441             end Return_Master_Scope_Depth_Of_Call;
10442          end if;
10443
10444       --  For convenience we handle qualified expressions, even though
10445       --  they aren't technically object names.
10446
10447       elsif Nkind (Obj) = N_Qualified_Expression then
10448          return Object_Access_Level (Expression (Obj));
10449
10450       --  Otherwise return the scope level of Standard.
10451       --  (If there are cases that fall through
10452       --  to this point they will be treated as
10453       --  having global accessibility for now. ???)
10454
10455       else
10456          return Scope_Depth (Standard_Standard);
10457       end if;
10458    end Object_Access_Level;
10459
10460    --------------------------------------
10461    -- Original_Corresponding_Operation --
10462    --------------------------------------
10463
10464    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
10465    is
10466       Typ : constant Entity_Id := Find_Dispatching_Type (S);
10467
10468    begin
10469       --  If S is an inherited primitive S2 the original corresponding
10470       --  operation of S is the original corresponding operation of S2
10471
10472       if Present (Alias (S))
10473         and then Find_Dispatching_Type (Alias (S)) /= Typ
10474       then
10475          return Original_Corresponding_Operation (Alias (S));
10476
10477       --  If S overrides an inherited subprogram S2 the original corresponding
10478       --  operation of S is the original corresponding operation of S2
10479
10480       elsif Present (Overridden_Operation (S)) then
10481          return Original_Corresponding_Operation (Overridden_Operation (S));
10482
10483       --  otherwise it is S itself
10484
10485       else
10486          return S;
10487       end if;
10488    end Original_Corresponding_Operation;
10489
10490    -----------------------
10491    -- Private_Component --
10492    -----------------------
10493
10494    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
10495       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
10496
10497       function Trace_Components
10498         (T     : Entity_Id;
10499          Check : Boolean) return Entity_Id;
10500       --  Recursive function that does the work, and checks against circular
10501       --  definition for each subcomponent type.
10502
10503       ----------------------
10504       -- Trace_Components --
10505       ----------------------
10506
10507       function Trace_Components
10508          (T     : Entity_Id;
10509           Check : Boolean) return Entity_Id
10510        is
10511          Btype     : constant Entity_Id := Base_Type (T);
10512          Component : Entity_Id;
10513          P         : Entity_Id;
10514          Candidate : Entity_Id := Empty;
10515
10516       begin
10517          if Check and then Btype = Ancestor then
10518             Error_Msg_N ("circular type definition", Type_Id);
10519             return Any_Type;
10520          end if;
10521
10522          if Is_Private_Type (Btype)
10523            and then not Is_Generic_Type (Btype)
10524          then
10525             if Present (Full_View (Btype))
10526               and then Is_Record_Type (Full_View (Btype))
10527               and then not Is_Frozen (Btype)
10528             then
10529                --  To indicate that the ancestor depends on a private type, the
10530                --  current Btype is sufficient. However, to check for circular
10531                --  definition we must recurse on the full view.
10532
10533                Candidate := Trace_Components (Full_View (Btype), True);
10534
10535                if Candidate = Any_Type then
10536                   return Any_Type;
10537                else
10538                   return Btype;
10539                end if;
10540
10541             else
10542                return Btype;
10543             end if;
10544
10545          elsif Is_Array_Type (Btype) then
10546             return Trace_Components (Component_Type (Btype), True);
10547
10548          elsif Is_Record_Type (Btype) then
10549             Component := First_Entity (Btype);
10550             while Present (Component) loop
10551
10552                --  Skip anonymous types generated by constrained components
10553
10554                if not Is_Type (Component) then
10555                   P := Trace_Components (Etype (Component), True);
10556
10557                   if Present (P) then
10558                      if P = Any_Type then
10559                         return P;
10560                      else
10561                         Candidate := P;
10562                      end if;
10563                   end if;
10564                end if;
10565
10566                Next_Entity (Component);
10567             end loop;
10568
10569             return Candidate;
10570
10571          else
10572             return Empty;
10573          end if;
10574       end Trace_Components;
10575
10576    --  Start of processing for Private_Component
10577
10578    begin
10579       return Trace_Components (Type_Id, False);
10580    end Private_Component;
10581
10582    ---------------------------
10583    -- Primitive_Names_Match --
10584    ---------------------------
10585
10586    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
10587
10588       function Non_Internal_Name (E : Entity_Id) return Name_Id;
10589       --  Given an internal name, returns the corresponding non-internal name
10590
10591       ------------------------
10592       --  Non_Internal_Name --
10593       ------------------------
10594
10595       function Non_Internal_Name (E : Entity_Id) return Name_Id is
10596       begin
10597          Get_Name_String (Chars (E));
10598          Name_Len := Name_Len - 1;
10599          return Name_Find;
10600       end Non_Internal_Name;
10601
10602    --  Start of processing for Primitive_Names_Match
10603
10604    begin
10605       pragma Assert (Present (E1) and then Present (E2));
10606
10607       return Chars (E1) = Chars (E2)
10608         or else
10609            (not Is_Internal_Name (Chars (E1))
10610               and then Is_Internal_Name (Chars (E2))
10611               and then Non_Internal_Name (E2) = Chars (E1))
10612         or else
10613            (not Is_Internal_Name (Chars (E2))
10614               and then Is_Internal_Name (Chars (E1))
10615               and then Non_Internal_Name (E1) = Chars (E2))
10616         or else
10617            (Is_Predefined_Dispatching_Operation (E1)
10618               and then Is_Predefined_Dispatching_Operation (E2)
10619               and then Same_TSS (E1, E2))
10620         or else
10621            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
10622    end Primitive_Names_Match;
10623
10624    -----------------------
10625    -- Process_End_Label --
10626    -----------------------
10627
10628    procedure Process_End_Label
10629      (N   : Node_Id;
10630       Typ : Character;
10631       Ent : Entity_Id)
10632    is
10633       Loc  : Source_Ptr;
10634       Nam  : Node_Id;
10635       Scop : Entity_Id;
10636
10637       Label_Ref : Boolean;
10638       --  Set True if reference to end label itself is required
10639
10640       Endl : Node_Id;
10641       --  Gets set to the operator symbol or identifier that references the
10642       --  entity Ent. For the child unit case, this is the identifier from the
10643       --  designator. For other cases, this is simply Endl.
10644
10645       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
10646       --  N is an identifier node that appears as a parent unit reference in
10647       --  the case where Ent is a child unit. This procedure generates an
10648       --  appropriate cross-reference entry. E is the corresponding entity.
10649
10650       -------------------------
10651       -- Generate_Parent_Ref --
10652       -------------------------
10653
10654       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
10655       begin
10656          --  If names do not match, something weird, skip reference
10657
10658          if Chars (E) = Chars (N) then
10659
10660             --  Generate the reference. We do NOT consider this as a reference
10661             --  for unreferenced symbol purposes.
10662
10663             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
10664
10665             if Style_Check then
10666                Style.Check_Identifier (N, E);
10667             end if;
10668          end if;
10669       end Generate_Parent_Ref;
10670
10671    --  Start of processing for Process_End_Label
10672
10673    begin
10674       --  If no node, ignore. This happens in some error situations, and
10675       --  also for some internally generated structures where no end label
10676       --  references are required in any case.
10677
10678       if No (N) then
10679          return;
10680       end if;
10681
10682       --  Nothing to do if no End_Label, happens for internally generated
10683       --  constructs where we don't want an end label reference anyway. Also
10684       --  nothing to do if Endl is a string literal, which means there was
10685       --  some prior error (bad operator symbol)
10686
10687       Endl := End_Label (N);
10688
10689       if No (Endl) or else Nkind (Endl) = N_String_Literal then
10690          return;
10691       end if;
10692
10693       --  Reference node is not in extended main source unit
10694
10695       if not In_Extended_Main_Source_Unit (N) then
10696
10697          --  Generally we do not collect references except for the extended
10698          --  main source unit. The one exception is the 'e' entry for a
10699          --  package spec, where it is useful for a client to have the
10700          --  ending information to define scopes.
10701
10702          if Typ /= 'e' then
10703             return;
10704
10705          else
10706             Label_Ref := False;
10707
10708             --  For this case, we can ignore any parent references, but we
10709             --  need the package name itself for the 'e' entry.
10710
10711             if Nkind (Endl) = N_Designator then
10712                Endl := Identifier (Endl);
10713             end if;
10714          end if;
10715
10716       --  Reference is in extended main source unit
10717
10718       else
10719          Label_Ref := True;
10720
10721          --  For designator, generate references for the parent entries
10722
10723          if Nkind (Endl) = N_Designator then
10724
10725             --  Generate references for the prefix if the END line comes from
10726             --  source (otherwise we do not need these references) We climb the
10727             --  scope stack to find the expected entities.
10728
10729             if Comes_From_Source (Endl) then
10730                Nam  := Name (Endl);
10731                Scop := Current_Scope;
10732                while Nkind (Nam) = N_Selected_Component loop
10733                   Scop := Scope (Scop);
10734                   exit when No (Scop);
10735                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
10736                   Nam := Prefix (Nam);
10737                end loop;
10738
10739                if Present (Scop) then
10740                   Generate_Parent_Ref (Nam, Scope (Scop));
10741                end if;
10742             end if;
10743
10744             Endl := Identifier (Endl);
10745          end if;
10746       end if;
10747
10748       --  If the end label is not for the given entity, then either we have
10749       --  some previous error, or this is a generic instantiation for which
10750       --  we do not need to make a cross-reference in this case anyway. In
10751       --  either case we simply ignore the call.
10752
10753       if Chars (Ent) /= Chars (Endl) then
10754          return;
10755       end if;
10756
10757       --  If label was really there, then generate a normal reference and then
10758       --  adjust the location in the end label to point past the name (which
10759       --  should almost always be the semicolon).
10760
10761       Loc := Sloc (Endl);
10762
10763       if Comes_From_Source (Endl) then
10764
10765          --  If a label reference is required, then do the style check and
10766          --  generate an l-type cross-reference entry for the label
10767
10768          if Label_Ref then
10769             if Style_Check then
10770                Style.Check_Identifier (Endl, Ent);
10771             end if;
10772
10773             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
10774          end if;
10775
10776          --  Set the location to point past the label (normally this will
10777          --  mean the semicolon immediately following the label). This is
10778          --  done for the sake of the 'e' or 't' entry generated below.
10779
10780          Get_Decoded_Name_String (Chars (Endl));
10781          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
10782
10783       else
10784          --  In SPARK mode, no missing label is allowed for packages and
10785          --  subprogram bodies. Detect those cases by testing whether
10786          --  Process_End_Label was called for a body (Typ = 't') or a package.
10787
10788          if (SPARK_Mode or else Restriction_Check_Required (SPARK))
10789            and then (Typ = 't' or else Ekind (Ent) = E_Package)
10790          then
10791             Error_Msg_Node_1 := Endl;
10792             Check_Formal_Restriction ("`END &` required", Endl, Force => True);
10793          end if;
10794       end if;
10795
10796       --  Now generate the e/t reference
10797
10798       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
10799
10800       --  Restore Sloc, in case modified above, since we have an identifier
10801       --  and the normal Sloc should be left set in the tree.
10802
10803       Set_Sloc (Endl, Loc);
10804    end Process_End_Label;
10805
10806    ------------------------------------
10807    -- References_Generic_Formal_Type --
10808    ------------------------------------
10809
10810    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
10811
10812       function Process (N : Node_Id) return Traverse_Result;
10813       --  Process one node in search for generic formal type
10814
10815       -------------
10816       -- Process --
10817       -------------
10818
10819       function Process (N : Node_Id) return Traverse_Result is
10820       begin
10821          if Nkind (N) in N_Has_Entity then
10822             declare
10823                E : constant Entity_Id := Entity (N);
10824             begin
10825                if Present (E) then
10826                   if Is_Generic_Type (E) then
10827                      return Abandon;
10828                   elsif Present (Etype (E))
10829                     and then Is_Generic_Type (Etype (E))
10830                   then
10831                      return Abandon;
10832                   end if;
10833                end if;
10834             end;
10835          end if;
10836
10837          return Atree.OK;
10838       end Process;
10839
10840       function Traverse is new Traverse_Func (Process);
10841       --  Traverse tree to look for generic type
10842
10843    begin
10844       if Inside_A_Generic then
10845          return Traverse (N) = Abandon;
10846       else
10847          return False;
10848       end if;
10849    end References_Generic_Formal_Type;
10850
10851    --------------------
10852    -- Remove_Homonym --
10853    --------------------
10854
10855    procedure Remove_Homonym (E : Entity_Id) is
10856       Prev  : Entity_Id := Empty;
10857       H     : Entity_Id;
10858
10859    begin
10860       if E = Current_Entity (E) then
10861          if Present (Homonym (E)) then
10862             Set_Current_Entity (Homonym (E));
10863          else
10864             Set_Name_Entity_Id (Chars (E), Empty);
10865          end if;
10866       else
10867          H := Current_Entity (E);
10868          while Present (H) and then H /= E loop
10869             Prev := H;
10870             H    := Homonym (H);
10871          end loop;
10872
10873          Set_Homonym (Prev, Homonym (E));
10874       end if;
10875    end Remove_Homonym;
10876
10877    ---------------------
10878    -- Rep_To_Pos_Flag --
10879    ---------------------
10880
10881    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
10882    begin
10883       return New_Occurrence_Of
10884                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
10885    end Rep_To_Pos_Flag;
10886
10887    --------------------
10888    -- Require_Entity --
10889    --------------------
10890
10891    procedure Require_Entity (N : Node_Id) is
10892    begin
10893       if Is_Entity_Name (N) and then No (Entity (N)) then
10894          if Total_Errors_Detected /= 0 then
10895             Set_Entity (N, Any_Id);
10896          else
10897             raise Program_Error;
10898          end if;
10899       end if;
10900    end Require_Entity;
10901
10902    ------------------------------
10903    -- Requires_Transient_Scope --
10904    ------------------------------
10905
10906    --  A transient scope is required when variable-sized temporaries are
10907    --  allocated in the primary or secondary stack, or when finalization
10908    --  actions must be generated before the next instruction.
10909
10910    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
10911       Typ : constant Entity_Id := Underlying_Type (Id);
10912
10913    --  Start of processing for Requires_Transient_Scope
10914
10915    begin
10916       --  This is a private type which is not completed yet. This can only
10917       --  happen in a default expression (of a formal parameter or of a
10918       --  record component). Do not expand transient scope in this case
10919
10920       if No (Typ) then
10921          return False;
10922
10923       --  Do not expand transient scope for non-existent procedure return
10924
10925       elsif Typ = Standard_Void_Type then
10926          return False;
10927
10928       --  Elementary types do not require a transient scope
10929
10930       elsif Is_Elementary_Type (Typ) then
10931          return False;
10932
10933       --  Generally, indefinite subtypes require a transient scope, since the
10934       --  back end cannot generate temporaries, since this is not a valid type
10935       --  for declaring an object. It might be possible to relax this in the
10936       --  future, e.g. by declaring the maximum possible space for the type.
10937
10938       elsif Is_Indefinite_Subtype (Typ) then
10939          return True;
10940
10941       --  Functions returning tagged types may dispatch on result so their
10942       --  returned value is allocated on the secondary stack. Controlled
10943       --  type temporaries need finalization.
10944
10945       elsif Is_Tagged_Type (Typ)
10946         or else Has_Controlled_Component (Typ)
10947       then
10948          return not Is_Value_Type (Typ);
10949
10950       --  Record type
10951
10952       elsif Is_Record_Type (Typ) then
10953          declare
10954             Comp : Entity_Id;
10955          begin
10956             Comp := First_Entity (Typ);
10957             while Present (Comp) loop
10958                if Ekind (Comp) = E_Component
10959                   and then Requires_Transient_Scope (Etype (Comp))
10960                then
10961                   return True;
10962                else
10963                   Next_Entity (Comp);
10964                end if;
10965             end loop;
10966          end;
10967
10968          return False;
10969
10970       --  String literal types never require transient scope
10971
10972       elsif Ekind (Typ) = E_String_Literal_Subtype then
10973          return False;
10974
10975       --  Array type. Note that we already know that this is a constrained
10976       --  array, since unconstrained arrays will fail the indefinite test.
10977
10978       elsif Is_Array_Type (Typ) then
10979
10980          --  If component type requires a transient scope, the array does too
10981
10982          if Requires_Transient_Scope (Component_Type (Typ)) then
10983             return True;
10984
10985          --  Otherwise, we only need a transient scope if the size depends on
10986          --  the value of one or more discriminants.
10987
10988          else
10989             return Size_Depends_On_Discriminant (Typ);
10990          end if;
10991
10992       --  All other cases do not require a transient scope
10993
10994       else
10995          return False;
10996       end if;
10997    end Requires_Transient_Scope;
10998
10999    --------------------------
11000    -- Reset_Analyzed_Flags --
11001    --------------------------
11002
11003    procedure Reset_Analyzed_Flags (N : Node_Id) is
11004
11005       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
11006       --  Function used to reset Analyzed flags in tree. Note that we do
11007       --  not reset Analyzed flags in entities, since there is no need to
11008       --  reanalyze entities, and indeed, it is wrong to do so, since it
11009       --  can result in generating auxiliary stuff more than once.
11010
11011       --------------------
11012       -- Clear_Analyzed --
11013       --------------------
11014
11015       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
11016       begin
11017          if not Has_Extension (N) then
11018             Set_Analyzed (N, False);
11019          end if;
11020
11021          return OK;
11022       end Clear_Analyzed;
11023
11024       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
11025
11026    --  Start of processing for Reset_Analyzed_Flags
11027
11028    begin
11029       Reset_Analyzed (N);
11030    end Reset_Analyzed_Flags;
11031
11032    ---------------------------
11033    -- Safe_To_Capture_Value --
11034    ---------------------------
11035
11036    function Safe_To_Capture_Value
11037      (N    : Node_Id;
11038       Ent  : Entity_Id;
11039       Cond : Boolean := False) return Boolean
11040    is
11041    begin
11042       --  The only entities for which we track constant values are variables
11043       --  which are not renamings, constants, out parameters, and in out
11044       --  parameters, so check if we have this case.
11045
11046       --  Note: it may seem odd to track constant values for constants, but in
11047       --  fact this routine is used for other purposes than simply capturing
11048       --  the value. In particular, the setting of Known[_Non]_Null.
11049
11050       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
11051             or else
11052           Ekind (Ent) = E_Constant
11053             or else
11054           Ekind (Ent) = E_Out_Parameter
11055             or else
11056           Ekind (Ent) = E_In_Out_Parameter
11057       then
11058          null;
11059
11060       --  For conditionals, we also allow loop parameters and all formals,
11061       --  including in parameters.
11062
11063       elsif Cond
11064         and then
11065           (Ekind (Ent) = E_Loop_Parameter
11066              or else
11067            Ekind (Ent) = E_In_Parameter)
11068       then
11069          null;
11070
11071       --  For all other cases, not just unsafe, but impossible to capture
11072       --  Current_Value, since the above are the only entities which have
11073       --  Current_Value fields.
11074
11075       else
11076          return False;
11077       end if;
11078
11079       --  Skip if volatile or aliased, since funny things might be going on in
11080       --  these cases which we cannot necessarily track. Also skip any variable
11081       --  for which an address clause is given, or whose address is taken. Also
11082       --  never capture value of library level variables (an attempt to do so
11083       --  can occur in the case of package elaboration code).
11084
11085       if Treat_As_Volatile (Ent)
11086         or else Is_Aliased (Ent)
11087         or else Present (Address_Clause (Ent))
11088         or else Address_Taken (Ent)
11089         or else (Is_Library_Level_Entity (Ent)
11090                    and then Ekind (Ent) = E_Variable)
11091       then
11092          return False;
11093       end if;
11094
11095       --  OK, all above conditions are met. We also require that the scope of
11096       --  the reference be the same as the scope of the entity, not counting
11097       --  packages and blocks and loops.
11098
11099       declare
11100          E_Scope : constant Entity_Id := Scope (Ent);
11101          R_Scope : Entity_Id;
11102
11103       begin
11104          R_Scope := Current_Scope;
11105          while R_Scope /= Standard_Standard loop
11106             exit when R_Scope = E_Scope;
11107
11108             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
11109                return False;
11110             else
11111                R_Scope := Scope (R_Scope);
11112             end if;
11113          end loop;
11114       end;
11115
11116       --  We also require that the reference does not appear in a context
11117       --  where it is not sure to be executed (i.e. a conditional context
11118       --  or an exception handler). We skip this if Cond is True, since the
11119       --  capturing of values from conditional tests handles this ok.
11120
11121       if Cond then
11122          return True;
11123       end if;
11124
11125       declare
11126          Desc : Node_Id;
11127          P    : Node_Id;
11128
11129       begin
11130          Desc := N;
11131
11132          P := Parent (N);
11133          while Present (P) loop
11134             if         Nkind (P) = N_If_Statement
11135               or else  Nkind (P) = N_Case_Statement
11136               or else (Nkind (P) in N_Short_Circuit
11137                          and then Desc = Right_Opnd (P))
11138               or else (Nkind (P) = N_Conditional_Expression
11139                          and then Desc /= First (Expressions (P)))
11140               or else  Nkind (P) = N_Exception_Handler
11141               or else  Nkind (P) = N_Selective_Accept
11142               or else  Nkind (P) = N_Conditional_Entry_Call
11143               or else  Nkind (P) = N_Timed_Entry_Call
11144               or else  Nkind (P) = N_Asynchronous_Select
11145             then
11146                return False;
11147             else
11148                Desc := P;
11149                P    := Parent (P);
11150             end if;
11151          end loop;
11152       end;
11153
11154       --  OK, looks safe to set value
11155
11156       return True;
11157    end Safe_To_Capture_Value;
11158
11159    ---------------
11160    -- Same_Name --
11161    ---------------
11162
11163    function Same_Name (N1, N2 : Node_Id) return Boolean is
11164       K1 : constant Node_Kind := Nkind (N1);
11165       K2 : constant Node_Kind := Nkind (N2);
11166
11167    begin
11168       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
11169         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
11170       then
11171          return Chars (N1) = Chars (N2);
11172
11173       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
11174         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
11175       then
11176          return Same_Name (Selector_Name (N1), Selector_Name (N2))
11177            and then Same_Name (Prefix (N1), Prefix (N2));
11178
11179       else
11180          return False;
11181       end if;
11182    end Same_Name;
11183
11184    -----------------
11185    -- Same_Object --
11186    -----------------
11187
11188    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
11189       N1 : constant Node_Id := Original_Node (Node1);
11190       N2 : constant Node_Id := Original_Node (Node2);
11191       --  We do the tests on original nodes, since we are most interested
11192       --  in the original source, not any expansion that got in the way.
11193
11194       K1 : constant Node_Kind := Nkind (N1);
11195       K2 : constant Node_Kind := Nkind (N2);
11196
11197    begin
11198       --  First case, both are entities with same entity
11199
11200       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
11201          declare
11202             EN1 : constant Entity_Id := Entity (N1);
11203             EN2 : constant Entity_Id := Entity (N2);
11204          begin
11205             if Present (EN1) and then Present (EN2)
11206               and then (Ekind_In (EN1, E_Variable, E_Constant)
11207                          or else Is_Formal (EN1))
11208               and then EN1 = EN2
11209             then
11210                return True;
11211             end if;
11212          end;
11213       end if;
11214
11215       --  Second case, selected component with same selector, same record
11216
11217       if K1 = N_Selected_Component
11218         and then K2 = N_Selected_Component
11219         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
11220       then
11221          return Same_Object (Prefix (N1), Prefix (N2));
11222
11223       --  Third case, indexed component with same subscripts, same array
11224
11225       elsif K1 = N_Indexed_Component
11226         and then K2 = N_Indexed_Component
11227         and then Same_Object (Prefix (N1), Prefix (N2))
11228       then
11229          declare
11230             E1, E2 : Node_Id;
11231          begin
11232             E1 := First (Expressions (N1));
11233             E2 := First (Expressions (N2));
11234             while Present (E1) loop
11235                if not Same_Value (E1, E2) then
11236                   return False;
11237                else
11238                   Next (E1);
11239                   Next (E2);
11240                end if;
11241             end loop;
11242
11243             return True;
11244          end;
11245
11246       --  Fourth case, slice of same array with same bounds
11247
11248       elsif K1 = N_Slice
11249         and then K2 = N_Slice
11250         and then Nkind (Discrete_Range (N1)) = N_Range
11251         and then Nkind (Discrete_Range (N2)) = N_Range
11252         and then Same_Value (Low_Bound (Discrete_Range (N1)),
11253                              Low_Bound (Discrete_Range (N2)))
11254         and then Same_Value (High_Bound (Discrete_Range (N1)),
11255                              High_Bound (Discrete_Range (N2)))
11256       then
11257          return Same_Name (Prefix (N1), Prefix (N2));
11258
11259       --  All other cases, not clearly the same object
11260
11261       else
11262          return False;
11263       end if;
11264    end Same_Object;
11265
11266    ---------------
11267    -- Same_Type --
11268    ---------------
11269
11270    function Same_Type (T1, T2 : Entity_Id) return Boolean is
11271    begin
11272       if T1 = T2 then
11273          return True;
11274
11275       elsif not Is_Constrained (T1)
11276         and then not Is_Constrained (T2)
11277         and then Base_Type (T1) = Base_Type (T2)
11278       then
11279          return True;
11280
11281       --  For now don't bother with case of identical constraints, to be
11282       --  fiddled with later on perhaps (this is only used for optimization
11283       --  purposes, so it is not critical to do a best possible job)
11284
11285       else
11286          return False;
11287       end if;
11288    end Same_Type;
11289
11290    ----------------
11291    -- Same_Value --
11292    ----------------
11293
11294    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
11295    begin
11296       if Compile_Time_Known_Value (Node1)
11297         and then Compile_Time_Known_Value (Node2)
11298         and then Expr_Value (Node1) = Expr_Value (Node2)
11299       then
11300          return True;
11301       elsif Same_Object (Node1, Node2) then
11302          return True;
11303       else
11304          return False;
11305       end if;
11306    end Same_Value;
11307
11308    -----------------
11309    -- Save_Actual --
11310    -----------------
11311
11312    procedure Save_Actual (N : Node_Id;  Writable : Boolean := False) is
11313    begin
11314       if Ada_Version < Ada_2012 then
11315          return;
11316
11317       elsif Is_Entity_Name (N)
11318         or else
11319           Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
11320         or else
11321           (Nkind (N) = N_Attribute_Reference
11322             and then Attribute_Name (N) = Name_Access)
11323
11324       then
11325          --  We are only interested in IN OUT parameters of inner calls
11326
11327          if not Writable
11328            or else Nkind (Parent (N)) = N_Function_Call
11329            or else Nkind (Parent (N)) in N_Op
11330          then
11331             Actuals_In_Call.Increment_Last;
11332             Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
11333          end if;
11334       end if;
11335    end Save_Actual;
11336
11337    ------------------------
11338    -- Scope_Is_Transient --
11339    ------------------------
11340
11341    function Scope_Is_Transient return Boolean is
11342    begin
11343       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
11344    end Scope_Is_Transient;
11345
11346    ------------------
11347    -- Scope_Within --
11348    ------------------
11349
11350    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
11351       Scop : Entity_Id;
11352
11353    begin
11354       Scop := Scope1;
11355       while Scop /= Standard_Standard loop
11356          Scop := Scope (Scop);
11357
11358          if Scop = Scope2 then
11359             return True;
11360          end if;
11361       end loop;
11362
11363       return False;
11364    end Scope_Within;
11365
11366    --------------------------
11367    -- Scope_Within_Or_Same --
11368    --------------------------
11369
11370    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
11371       Scop : Entity_Id;
11372
11373    begin
11374       Scop := Scope1;
11375       while Scop /= Standard_Standard loop
11376          if Scop = Scope2 then
11377             return True;
11378          else
11379             Scop := Scope (Scop);
11380          end if;
11381       end loop;
11382
11383       return False;
11384    end Scope_Within_Or_Same;
11385
11386    --------------------
11387    -- Set_Convention --
11388    --------------------
11389
11390    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
11391    begin
11392       Basic_Set_Convention (E, Val);
11393
11394       if Is_Type (E)
11395         and then Is_Access_Subprogram_Type (Base_Type (E))
11396         and then Has_Foreign_Convention (E)
11397       then
11398          Set_Can_Use_Internal_Rep (E, False);
11399       end if;
11400    end Set_Convention;
11401
11402    ------------------------
11403    -- Set_Current_Entity --
11404    ------------------------
11405
11406    --  The given entity is to be set as the currently visible definition
11407    --  of its associated name (i.e. the Node_Id associated with its name).
11408    --  All we have to do is to get the name from the identifier, and
11409    --  then set the associated Node_Id to point to the given entity.
11410
11411    procedure Set_Current_Entity (E : Entity_Id) is
11412    begin
11413       Set_Name_Entity_Id (Chars (E), E);
11414    end Set_Current_Entity;
11415
11416    ---------------------------
11417    -- Set_Debug_Info_Needed --
11418    ---------------------------
11419
11420    procedure Set_Debug_Info_Needed (T : Entity_Id) is
11421
11422       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
11423       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
11424       --  Used to set debug info in a related node if not set already
11425
11426       --------------------------------------
11427       -- Set_Debug_Info_Needed_If_Not_Set --
11428       --------------------------------------
11429
11430       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
11431       begin
11432          if Present (E)
11433            and then not Needs_Debug_Info (E)
11434          then
11435             Set_Debug_Info_Needed (E);
11436
11437             --  For a private type, indicate that the full view also needs
11438             --  debug information.
11439
11440             if Is_Type (E)
11441               and then Is_Private_Type (E)
11442               and then Present (Full_View (E))
11443             then
11444                Set_Debug_Info_Needed (Full_View (E));
11445             end if;
11446          end if;
11447       end Set_Debug_Info_Needed_If_Not_Set;
11448
11449    --  Start of processing for Set_Debug_Info_Needed
11450
11451    begin
11452       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
11453       --  indicates that Debug_Info_Needed is never required for the entity.
11454
11455       if No (T)
11456         or else Debug_Info_Off (T)
11457       then
11458          return;
11459       end if;
11460
11461       --  Set flag in entity itself. Note that we will go through the following
11462       --  circuitry even if the flag is already set on T. That's intentional,
11463       --  it makes sure that the flag will be set in subsidiary entities.
11464
11465       Set_Needs_Debug_Info (T);
11466
11467       --  Set flag on subsidiary entities if not set already
11468
11469       if Is_Object (T) then
11470          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
11471
11472       elsif Is_Type (T) then
11473          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
11474
11475          if Is_Record_Type (T) then
11476             declare
11477                Ent : Entity_Id := First_Entity (T);
11478             begin
11479                while Present (Ent) loop
11480                   Set_Debug_Info_Needed_If_Not_Set (Ent);
11481                   Next_Entity (Ent);
11482                end loop;
11483             end;
11484
11485             --  For a class wide subtype, we also need debug information
11486             --  for the equivalent type.
11487
11488             if Ekind (T) = E_Class_Wide_Subtype then
11489                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
11490             end if;
11491
11492          elsif Is_Array_Type (T) then
11493             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
11494
11495             declare
11496                Indx : Node_Id := First_Index (T);
11497             begin
11498                while Present (Indx) loop
11499                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
11500                   Indx := Next_Index (Indx);
11501                end loop;
11502             end;
11503
11504             if Is_Packed (T) then
11505                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
11506             end if;
11507
11508          elsif Is_Access_Type (T) then
11509             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
11510
11511          elsif Is_Private_Type (T) then
11512             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
11513
11514          elsif Is_Protected_Type (T) then
11515             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
11516          end if;
11517       end if;
11518    end Set_Debug_Info_Needed;
11519
11520    ---------------------------------
11521    -- Set_Entity_With_Style_Check --
11522    ---------------------------------
11523
11524    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
11525       Val_Actual : Entity_Id;
11526       Nod        : Node_Id;
11527
11528    begin
11529       Set_Entity (N, Val);
11530
11531       if Style_Check
11532         and then not Suppress_Style_Checks (Val)
11533         and then not In_Instance
11534       then
11535          if Nkind (N) = N_Identifier then
11536             Nod := N;
11537          elsif Nkind (N) = N_Expanded_Name then
11538             Nod := Selector_Name (N);
11539          else
11540             return;
11541          end if;
11542
11543          --  A special situation arises for derived operations, where we want
11544          --  to do the check against the parent (since the Sloc of the derived
11545          --  operation points to the derived type declaration itself).
11546
11547          Val_Actual := Val;
11548          while not Comes_From_Source (Val_Actual)
11549            and then Nkind (Val_Actual) in N_Entity
11550            and then (Ekind (Val_Actual) = E_Enumeration_Literal
11551                       or else Is_Subprogram (Val_Actual)
11552                       or else Is_Generic_Subprogram (Val_Actual))
11553            and then Present (Alias (Val_Actual))
11554          loop
11555             Val_Actual := Alias (Val_Actual);
11556          end loop;
11557
11558          --  Renaming declarations for generic actuals do not come from source,
11559          --  and have a different name from that of the entity they rename, so
11560          --  there is no style check to perform here.
11561
11562          if Chars (Nod) = Chars (Val_Actual) then
11563             Style.Check_Identifier (Nod, Val_Actual);
11564          end if;
11565       end if;
11566
11567       Set_Entity (N, Val);
11568    end Set_Entity_With_Style_Check;
11569
11570    ------------------------
11571    -- Set_Name_Entity_Id --
11572    ------------------------
11573
11574    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
11575    begin
11576       Set_Name_Table_Info (Id, Int (Val));
11577    end Set_Name_Entity_Id;
11578
11579    ---------------------
11580    -- Set_Next_Actual --
11581    ---------------------
11582
11583    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
11584    begin
11585       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
11586          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
11587       end if;
11588    end Set_Next_Actual;
11589
11590    ----------------------------------
11591    -- Set_Optimize_Alignment_Flags --
11592    ----------------------------------
11593
11594    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
11595    begin
11596       if Optimize_Alignment = 'S' then
11597          Set_Optimize_Alignment_Space (E);
11598       elsif Optimize_Alignment = 'T' then
11599          Set_Optimize_Alignment_Time (E);
11600       end if;
11601    end Set_Optimize_Alignment_Flags;
11602
11603    -----------------------
11604    -- Set_Public_Status --
11605    -----------------------
11606
11607    procedure Set_Public_Status (Id : Entity_Id) is
11608       S : constant Entity_Id := Current_Scope;
11609
11610       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
11611       --  Determines if E is defined within handled statement sequence or
11612       --  an if statement, returns True if so, False otherwise.
11613
11614       ----------------------
11615       -- Within_HSS_Or_If --
11616       ----------------------
11617
11618       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
11619          N : Node_Id;
11620       begin
11621          N := Declaration_Node (E);
11622          loop
11623             N := Parent (N);
11624
11625             if No (N) then
11626                return False;
11627
11628             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
11629                                N_If_Statement)
11630             then
11631                return True;
11632             end if;
11633          end loop;
11634       end Within_HSS_Or_If;
11635
11636    --  Start of processing for Set_Public_Status
11637
11638    begin
11639       --  Everything in the scope of Standard is public
11640
11641       if S = Standard_Standard then
11642          Set_Is_Public (Id);
11643
11644       --  Entity is definitely not public if enclosing scope is not public
11645
11646       elsif not Is_Public (S) then
11647          return;
11648
11649       --  An object or function declaration that occurs in a handled sequence
11650       --  of statements or within an if statement is the declaration for a
11651       --  temporary object or local subprogram generated by the expander. It
11652       --  never needs to be made public and furthermore, making it public can
11653       --  cause back end problems.
11654
11655       elsif Nkind_In (Parent (Id), N_Object_Declaration,
11656                                    N_Function_Specification)
11657         and then Within_HSS_Or_If (Id)
11658       then
11659          return;
11660
11661       --  Entities in public packages or records are public
11662
11663       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
11664          Set_Is_Public (Id);
11665
11666       --  The bounds of an entry family declaration can generate object
11667       --  declarations that are visible to the back-end, e.g. in the
11668       --  the declaration of a composite type that contains tasks.
11669
11670       elsif Is_Concurrent_Type (S)
11671         and then not Has_Completion (S)
11672         and then Nkind (Parent (Id)) = N_Object_Declaration
11673       then
11674          Set_Is_Public (Id);
11675       end if;
11676    end Set_Public_Status;
11677
11678    -----------------------------
11679    -- Set_Referenced_Modified --
11680    -----------------------------
11681
11682    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
11683       Pref : Node_Id;
11684
11685    begin
11686       --  Deal with indexed or selected component where prefix is modified
11687
11688       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
11689          Pref := Prefix (N);
11690
11691          --  If prefix is access type, then it is the designated object that is
11692          --  being modified, which means we have no entity to set the flag on.
11693
11694          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
11695             return;
11696
11697             --  Otherwise chase the prefix
11698
11699          else
11700             Set_Referenced_Modified (Pref, Out_Param);
11701          end if;
11702
11703       --  Otherwise see if we have an entity name (only other case to process)
11704
11705       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
11706          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
11707          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
11708       end if;
11709    end Set_Referenced_Modified;
11710
11711    ----------------------------
11712    -- Set_Scope_Is_Transient --
11713    ----------------------------
11714
11715    procedure Set_Scope_Is_Transient (V : Boolean := True) is
11716    begin
11717       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
11718    end Set_Scope_Is_Transient;
11719
11720    -------------------
11721    -- Set_Size_Info --
11722    -------------------
11723
11724    procedure Set_Size_Info (T1, T2 : Entity_Id) is
11725    begin
11726       --  We copy Esize, but not RM_Size, since in general RM_Size is
11727       --  subtype specific and does not get inherited by all subtypes.
11728
11729       Set_Esize                     (T1, Esize                     (T2));
11730       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
11731
11732       if Is_Discrete_Or_Fixed_Point_Type (T1)
11733            and then
11734          Is_Discrete_Or_Fixed_Point_Type (T2)
11735       then
11736          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
11737       end if;
11738
11739       Set_Alignment                 (T1, Alignment                 (T2));
11740    end Set_Size_Info;
11741
11742    --------------------
11743    -- Static_Boolean --
11744    --------------------
11745
11746    function Static_Boolean (N : Node_Id) return Uint is
11747    begin
11748       Analyze_And_Resolve (N, Standard_Boolean);
11749
11750       if N = Error
11751         or else Error_Posted (N)
11752         or else Etype (N) = Any_Type
11753       then
11754          return No_Uint;
11755       end if;
11756
11757       if Is_Static_Expression (N) then
11758          if not Raises_Constraint_Error (N) then
11759             return Expr_Value (N);
11760          else
11761             return No_Uint;
11762          end if;
11763
11764       elsif Etype (N) = Any_Type then
11765          return No_Uint;
11766
11767       else
11768          Flag_Non_Static_Expr
11769            ("static boolean expression required here", N);
11770          return No_Uint;
11771       end if;
11772    end Static_Boolean;
11773
11774    --------------------
11775    -- Static_Integer --
11776    --------------------
11777
11778    function Static_Integer (N : Node_Id) return Uint is
11779    begin
11780       Analyze_And_Resolve (N, Any_Integer);
11781
11782       if N = Error
11783         or else Error_Posted (N)
11784         or else Etype (N) = Any_Type
11785       then
11786          return No_Uint;
11787       end if;
11788
11789       if Is_Static_Expression (N) then
11790          if not Raises_Constraint_Error (N) then
11791             return Expr_Value (N);
11792          else
11793             return No_Uint;
11794          end if;
11795
11796       elsif Etype (N) = Any_Type then
11797          return No_Uint;
11798
11799       else
11800          Flag_Non_Static_Expr
11801            ("static integer expression required here", N);
11802          return No_Uint;
11803       end if;
11804    end Static_Integer;
11805
11806    --------------------------
11807    -- Statically_Different --
11808    --------------------------
11809
11810    function Statically_Different (E1, E2 : Node_Id) return Boolean is
11811       R1 : constant Node_Id := Get_Referenced_Object (E1);
11812       R2 : constant Node_Id := Get_Referenced_Object (E2);
11813    begin
11814       return     Is_Entity_Name (R1)
11815         and then Is_Entity_Name (R2)
11816         and then Entity (R1) /= Entity (R2)
11817         and then not Is_Formal (Entity (R1))
11818         and then not Is_Formal (Entity (R2));
11819    end Statically_Different;
11820
11821    -----------------------------
11822    -- Subprogram_Access_Level --
11823    -----------------------------
11824
11825    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
11826    begin
11827       if Present (Alias (Subp)) then
11828          return Subprogram_Access_Level (Alias (Subp));
11829       else
11830          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
11831       end if;
11832    end Subprogram_Access_Level;
11833
11834    -----------------
11835    -- Trace_Scope --
11836    -----------------
11837
11838    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
11839    begin
11840       if Debug_Flag_W then
11841          for J in 0 .. Scope_Stack.Last loop
11842             Write_Str ("  ");
11843          end loop;
11844
11845          Write_Str (Msg);
11846          Write_Name (Chars (E));
11847          Write_Str (" from ");
11848          Write_Location (Sloc (N));
11849          Write_Eol;
11850       end if;
11851    end Trace_Scope;
11852
11853    -----------------------
11854    -- Transfer_Entities --
11855    -----------------------
11856
11857    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
11858       Ent : Entity_Id := First_Entity (From);
11859
11860    begin
11861       if No (Ent) then
11862          return;
11863       end if;
11864
11865       if (Last_Entity (To)) = Empty then
11866          Set_First_Entity (To, Ent);
11867       else
11868          Set_Next_Entity (Last_Entity (To), Ent);
11869       end if;
11870
11871       Set_Last_Entity (To, Last_Entity (From));
11872
11873       while Present (Ent) loop
11874          Set_Scope (Ent, To);
11875
11876          if not Is_Public (Ent) then
11877             Set_Public_Status (Ent);
11878
11879             if Is_Public (Ent)
11880               and then Ekind (Ent) = E_Record_Subtype
11881
11882             then
11883                --  The components of the propagated Itype must be public
11884                --  as well.
11885
11886                declare
11887                   Comp : Entity_Id;
11888                begin
11889                   Comp := First_Entity (Ent);
11890                   while Present (Comp) loop
11891                      Set_Is_Public (Comp);
11892                      Next_Entity (Comp);
11893                   end loop;
11894                end;
11895             end if;
11896          end if;
11897
11898          Next_Entity (Ent);
11899       end loop;
11900
11901       Set_First_Entity (From, Empty);
11902       Set_Last_Entity (From, Empty);
11903    end Transfer_Entities;
11904
11905    -----------------------
11906    -- Type_Access_Level --
11907    -----------------------
11908
11909    function Type_Access_Level (Typ : Entity_Id) return Uint is
11910       Btyp : Entity_Id;
11911
11912    begin
11913       Btyp := Base_Type (Typ);
11914
11915       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
11916       --  simply use the level where the type is declared. This is true for
11917       --  stand-alone object declarations, and for anonymous access types
11918       --  associated with components the level is the same as that of the
11919       --  enclosing composite type. However, special treatment is needed for
11920       --  the cases of access parameters, return objects of an anonymous access
11921       --  type, and, in Ada 95, access discriminants of limited types.
11922
11923       if Ekind (Btyp) in Access_Kind then
11924          if Ekind (Btyp) = E_Anonymous_Access_Type then
11925
11926             --  If the type is a nonlocal anonymous access type (such as for
11927             --  an access parameter) we treat it as being declared at the
11928             --  library level to ensure that names such as X.all'access don't
11929             --  fail static accessibility checks.
11930
11931             if not Is_Local_Anonymous_Access (Typ) then
11932                return Scope_Depth (Standard_Standard);
11933
11934             --  If this is a return object, the accessibility level is that of
11935             --  the result subtype of the enclosing function. The test here is
11936             --  little complicated, because we have to account for extended
11937             --  return statements that have been rewritten as blocks, in which
11938             --  case we have to find and the Is_Return_Object attribute of the
11939             --  itype's associated object. It would be nice to find a way to
11940             --  simplify this test, but it doesn't seem worthwhile to add a new
11941             --  flag just for purposes of this test. ???
11942
11943             elsif Ekind (Scope (Btyp)) = E_Return_Statement
11944               or else
11945                 (Is_Itype (Btyp)
11946                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
11947                              N_Object_Declaration
11948                   and then Is_Return_Object
11949                              (Defining_Identifier
11950                                 (Associated_Node_For_Itype (Btyp))))
11951             then
11952                declare
11953                   Scop : Entity_Id;
11954
11955                begin
11956                   Scop := Scope (Scope (Btyp));
11957                   while Present (Scop) loop
11958                      exit when Ekind (Scop) = E_Function;
11959                      Scop := Scope (Scop);
11960                   end loop;
11961
11962                   --  Treat the return object's type as having the level of the
11963                   --  function's result subtype (as per RM05-6.5(5.3/2)).
11964
11965                   return Type_Access_Level (Etype (Scop));
11966                end;
11967             end if;
11968          end if;
11969
11970          Btyp := Root_Type (Btyp);
11971
11972          --  The accessibility level of anonymous access types associated with
11973          --  discriminants is that of the current instance of the type, and
11974          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
11975
11976          --  AI-402: access discriminants have accessibility based on the
11977          --  object rather than the type in Ada 2005, so the above paragraph
11978          --  doesn't apply.
11979
11980          --  ??? Needs completion with rules from AI-416
11981
11982          if Ada_Version <= Ada_95
11983            and then Ekind (Typ) = E_Anonymous_Access_Type
11984            and then Present (Associated_Node_For_Itype (Typ))
11985            and then Nkind (Associated_Node_For_Itype (Typ)) =
11986                                                  N_Discriminant_Specification
11987          then
11988             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
11989          end if;
11990       end if;
11991
11992       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
11993    end Type_Access_Level;
11994
11995    --------------------------
11996    -- Unit_Declaration_Node --
11997    --------------------------
11998
11999    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
12000       N : Node_Id := Parent (Unit_Id);
12001
12002    begin
12003       --  Predefined operators do not have a full function declaration
12004
12005       if Ekind (Unit_Id) = E_Operator then
12006          return N;
12007       end if;
12008
12009       --  Isn't there some better way to express the following ???
12010
12011       while Nkind (N) /= N_Abstract_Subprogram_Declaration
12012         and then Nkind (N) /= N_Formal_Package_Declaration
12013         and then Nkind (N) /= N_Function_Instantiation
12014         and then Nkind (N) /= N_Generic_Package_Declaration
12015         and then Nkind (N) /= N_Generic_Subprogram_Declaration
12016         and then Nkind (N) /= N_Package_Declaration
12017         and then Nkind (N) /= N_Package_Body
12018         and then Nkind (N) /= N_Package_Instantiation
12019         and then Nkind (N) /= N_Package_Renaming_Declaration
12020         and then Nkind (N) /= N_Procedure_Instantiation
12021         and then Nkind (N) /= N_Protected_Body
12022         and then Nkind (N) /= N_Subprogram_Declaration
12023         and then Nkind (N) /= N_Subprogram_Body
12024         and then Nkind (N) /= N_Subprogram_Body_Stub
12025         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
12026         and then Nkind (N) /= N_Task_Body
12027         and then Nkind (N) /= N_Task_Type_Declaration
12028         and then Nkind (N) not in N_Formal_Subprogram_Declaration
12029         and then Nkind (N) not in N_Generic_Renaming_Declaration
12030       loop
12031          N := Parent (N);
12032          pragma Assert (Present (N));
12033       end loop;
12034
12035       return N;
12036    end Unit_Declaration_Node;
12037
12038    ---------------------
12039    -- Unit_Is_Visible --
12040    ---------------------
12041
12042    function Unit_Is_Visible (U : Entity_Id) return Boolean is
12043       Curr        : constant Node_Id   := Cunit (Current_Sem_Unit);
12044       Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
12045
12046       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
12047       --  For a child unit, check whether unit appears in a with_clause
12048       --  of a parent.
12049
12050       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
12051       --  Scan the context clause of one compilation unit looking for a
12052       --  with_clause for the unit in question.
12053
12054       ----------------------------
12055       -- Unit_In_Parent_Context --
12056       ----------------------------
12057
12058       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
12059       begin
12060          if Unit_In_Context (Par_Unit) then
12061             return True;
12062
12063          elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
12064             return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
12065
12066          else
12067             return False;
12068          end if;
12069       end Unit_In_Parent_Context;
12070
12071       ---------------------
12072       -- Unit_In_Context --
12073       ---------------------
12074
12075       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
12076          Clause : Node_Id;
12077
12078       begin
12079          Clause := First (Context_Items (Comp_Unit));
12080          while Present (Clause) loop
12081             if Nkind (Clause) = N_With_Clause then
12082                if Library_Unit (Clause) = U then
12083                   return True;
12084
12085                --  The with_clause may denote a renaming of the unit we are
12086                --  looking for, eg. Text_IO which renames Ada.Text_IO.
12087
12088                elsif
12089                  Renamed_Entity (Entity (Name (Clause))) =
12090                                                 Defining_Entity (Unit (U))
12091                then
12092                   return True;
12093                end if;
12094             end if;
12095
12096             Next (Clause);
12097          end loop;
12098
12099          return False;
12100       end Unit_In_Context;
12101
12102    --  Start of processing for Unit_Is_Visible
12103
12104    begin
12105       --  The currrent unit is directly visible.
12106
12107       if Curr = U then
12108          return True;
12109
12110       elsif Unit_In_Context (Curr) then
12111          return True;
12112
12113       --  If the current unit is a body, check the context of the spec.
12114
12115       elsif Nkind (Unit (Curr)) = N_Package_Body
12116         or else
12117           (Nkind (Unit (Curr)) = N_Subprogram_Body
12118             and then not Acts_As_Spec (Unit (Curr)))
12119       then
12120          if Unit_In_Context (Library_Unit (Curr)) then
12121             return True;
12122          end if;
12123       end if;
12124
12125       --  If the spec is a child unit, examine the parents.
12126
12127       if Is_Child_Unit (Curr_Entity) then
12128          if Nkind (Unit (Curr)) in N_Unit_Body then
12129             return
12130               Unit_In_Parent_Context
12131                 (Parent_Spec (Unit (Library_Unit (Curr))));
12132          else
12133             return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
12134          end if;
12135
12136       else
12137          return False;
12138       end if;
12139    end Unit_Is_Visible;
12140
12141    ------------------------------
12142    -- Universal_Interpretation --
12143    ------------------------------
12144
12145    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
12146       Index : Interp_Index;
12147       It    : Interp;
12148
12149    begin
12150       --  The argument may be a formal parameter of an operator or subprogram
12151       --  with multiple interpretations, or else an expression for an actual.
12152
12153       if Nkind (Opnd) = N_Defining_Identifier
12154         or else not Is_Overloaded (Opnd)
12155       then
12156          if Etype (Opnd) = Universal_Integer
12157            or else Etype (Opnd) = Universal_Real
12158          then
12159             return Etype (Opnd);
12160          else
12161             return Empty;
12162          end if;
12163
12164       else
12165          Get_First_Interp (Opnd, Index, It);
12166          while Present (It.Typ) loop
12167             if It.Typ = Universal_Integer
12168               or else It.Typ = Universal_Real
12169             then
12170                return It.Typ;
12171             end if;
12172
12173             Get_Next_Interp (Index, It);
12174          end loop;
12175
12176          return Empty;
12177       end if;
12178    end Universal_Interpretation;
12179
12180    ---------------
12181    -- Unqualify --
12182    ---------------
12183
12184    function Unqualify (Expr : Node_Id) return Node_Id is
12185    begin
12186       --  Recurse to handle unlikely case of multiple levels of qualification
12187
12188       if Nkind (Expr) = N_Qualified_Expression then
12189          return Unqualify (Expression (Expr));
12190
12191       --  Normal case, not a qualified expression
12192
12193       else
12194          return Expr;
12195       end if;
12196    end Unqualify;
12197
12198    -----------------------
12199    -- Visible_Ancestors --
12200    -----------------------
12201
12202    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
12203       List_1 : Elist_Id;
12204       List_2 : Elist_Id;
12205       Elmt   : Elmt_Id;
12206
12207    begin
12208       pragma Assert (Is_Record_Type (Typ)
12209         and then Is_Tagged_Type (Typ));
12210
12211       --  Collect all the parents and progenitors of Typ. If the full-view of
12212       --  private parents and progenitors is available then it is used to
12213       --  generate the list of visible ancestors; otherwise their partial
12214       --  view is added to the resulting list.
12215
12216       Collect_Parents
12217         (T               => Typ,
12218          List            => List_1,
12219          Use_Full_View   => True);
12220
12221       Collect_Interfaces
12222         (T               => Typ,
12223          Ifaces_List     => List_2,
12224          Exclude_Parents => True,
12225          Use_Full_View   => True);
12226
12227       --  Join the two lists. Avoid duplications because an interface may
12228       --  simultaneously be parent and progenitor of a type.
12229
12230       Elmt := First_Elmt (List_2);
12231       while Present (Elmt) loop
12232          Append_Unique_Elmt (Node (Elmt), List_1);
12233          Next_Elmt (Elmt);
12234       end loop;
12235
12236       return List_1;
12237    end Visible_Ancestors;
12238
12239    ----------------------
12240    -- Within_Init_Proc --
12241    ----------------------
12242
12243    function Within_Init_Proc return Boolean is
12244       S : Entity_Id;
12245
12246    begin
12247       S := Current_Scope;
12248       while not Is_Overloadable (S) loop
12249          if S = Standard_Standard then
12250             return False;
12251          else
12252             S := Scope (S);
12253          end if;
12254       end loop;
12255
12256       return Is_Init_Proc (S);
12257    end Within_Init_Proc;
12258
12259    ----------------
12260    -- Wrong_Type --
12261    ----------------
12262
12263    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
12264       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
12265       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
12266
12267       function Has_One_Matching_Field return Boolean;
12268       --  Determines if Expec_Type is a record type with a single component or
12269       --  discriminant whose type matches the found type or is one dimensional
12270       --  array whose component type matches the found type.
12271
12272       ----------------------------
12273       -- Has_One_Matching_Field --
12274       ----------------------------
12275
12276       function Has_One_Matching_Field return Boolean is
12277          E : Entity_Id;
12278
12279       begin
12280          if Is_Array_Type (Expec_Type)
12281            and then Number_Dimensions (Expec_Type) = 1
12282            and then
12283              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
12284          then
12285             return True;
12286
12287          elsif not Is_Record_Type (Expec_Type) then
12288             return False;
12289
12290          else
12291             E := First_Entity (Expec_Type);
12292             loop
12293                if No (E) then
12294                   return False;
12295
12296                elsif (Ekind (E) /= E_Discriminant
12297                        and then Ekind (E) /= E_Component)
12298                  or else (Chars (E) = Name_uTag
12299                            or else Chars (E) = Name_uParent)
12300                then
12301                   Next_Entity (E);
12302
12303                else
12304                   exit;
12305                end if;
12306             end loop;
12307
12308             if not Covers (Etype (E), Found_Type) then
12309                return False;
12310
12311             elsif Present (Next_Entity (E)) then
12312                return False;
12313
12314             else
12315                return True;
12316             end if;
12317          end if;
12318       end Has_One_Matching_Field;
12319
12320    --  Start of processing for Wrong_Type
12321
12322    begin
12323       --  Don't output message if either type is Any_Type, or if a message
12324       --  has already been posted for this node. We need to do the latter
12325       --  check explicitly (it is ordinarily done in Errout), because we
12326       --  are using ! to force the output of the error messages.
12327
12328       if Expec_Type = Any_Type
12329         or else Found_Type = Any_Type
12330         or else Error_Posted (Expr)
12331       then
12332          return;
12333
12334       --  In  an instance, there is an ongoing problem with completion of
12335       --  type derived from private types. Their structure is what Gigi
12336       --  expects, but the  Etype is the parent type rather than the
12337       --  derived private type itself. Do not flag error in this case. The
12338       --  private completion is an entity without a parent, like an Itype.
12339       --  Similarly, full and partial views may be incorrect in the instance.
12340       --  There is no simple way to insure that it is consistent ???
12341
12342       elsif In_Instance then
12343          if Etype (Etype (Expr)) = Etype (Expected_Type)
12344            and then
12345              (Has_Private_Declaration (Expected_Type)
12346                or else Has_Private_Declaration (Etype (Expr)))
12347            and then No (Parent (Expected_Type))
12348          then
12349             return;
12350          end if;
12351       end if;
12352
12353       --  An interesting special check. If the expression is parenthesized
12354       --  and its type corresponds to the type of the sole component of the
12355       --  expected record type, or to the component type of the expected one
12356       --  dimensional array type, then assume we have a bad aggregate attempt.
12357
12358       if Nkind (Expr) in N_Subexpr
12359         and then Paren_Count (Expr) /= 0
12360         and then Has_One_Matching_Field
12361       then
12362          Error_Msg_N ("positional aggregate cannot have one component", Expr);
12363
12364       --  Another special check, if we are looking for a pool-specific access
12365       --  type and we found an E_Access_Attribute_Type, then we have the case
12366       --  of an Access attribute being used in a context which needs a pool-
12367       --  specific type, which is never allowed. The one extra check we make
12368       --  is that the expected designated type covers the Found_Type.
12369
12370       elsif Is_Access_Type (Expec_Type)
12371         and then Ekind (Found_Type) = E_Access_Attribute_Type
12372         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
12373         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
12374         and then Covers
12375           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
12376       then
12377          Error_Msg_N -- CODEFIX
12378            ("result must be general access type!", Expr);
12379          Error_Msg_NE -- CODEFIX
12380            ("add ALL to }!", Expr, Expec_Type);
12381
12382       --  Another special check, if the expected type is an integer type,
12383       --  but the expression is of type System.Address, and the parent is
12384       --  an addition or subtraction operation whose left operand is the
12385       --  expression in question and whose right operand is of an integral
12386       --  type, then this is an attempt at address arithmetic, so give
12387       --  appropriate message.
12388
12389       elsif Is_Integer_Type (Expec_Type)
12390         and then Is_RTE (Found_Type, RE_Address)
12391         and then (Nkind (Parent (Expr)) = N_Op_Add
12392                     or else
12393                   Nkind (Parent (Expr)) = N_Op_Subtract)
12394         and then Expr = Left_Opnd (Parent (Expr))
12395         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
12396       then
12397          Error_Msg_N
12398            ("address arithmetic not predefined in package System",
12399             Parent (Expr));
12400          Error_Msg_N
12401            ("\possible missing with/use of System.Storage_Elements",
12402             Parent (Expr));
12403          return;
12404
12405       --  If the expected type is an anonymous access type, as for access
12406       --  parameters and discriminants, the error is on the designated types.
12407
12408       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
12409          if Comes_From_Source (Expec_Type) then
12410             Error_Msg_NE ("expected}!", Expr, Expec_Type);
12411          else
12412             Error_Msg_NE
12413               ("expected an access type with designated}",
12414                  Expr, Designated_Type (Expec_Type));
12415          end if;
12416
12417          if Is_Access_Type (Found_Type)
12418            and then not Comes_From_Source (Found_Type)
12419          then
12420             Error_Msg_NE
12421               ("\\found an access type with designated}!",
12422                 Expr, Designated_Type (Found_Type));
12423          else
12424             if From_With_Type (Found_Type) then
12425                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
12426                Error_Msg_Qual_Level := 99;
12427                Error_Msg_NE -- CODEFIX
12428                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
12429                Error_Msg_Qual_Level := 0;
12430             else
12431                Error_Msg_NE ("found}!", Expr, Found_Type);
12432             end if;
12433          end if;
12434
12435       --  Normal case of one type found, some other type expected
12436
12437       else
12438          --  If the names of the two types are the same, see if some number
12439          --  of levels of qualification will help. Don't try more than three
12440          --  levels, and if we get to standard, it's no use (and probably
12441          --  represents an error in the compiler) Also do not bother with
12442          --  internal scope names.
12443
12444          declare
12445             Expec_Scope : Entity_Id;
12446             Found_Scope : Entity_Id;
12447
12448          begin
12449             Expec_Scope := Expec_Type;
12450             Found_Scope := Found_Type;
12451
12452             for Levels in Int range 0 .. 3 loop
12453                if Chars (Expec_Scope) /= Chars (Found_Scope) then
12454                   Error_Msg_Qual_Level := Levels;
12455                   exit;
12456                end if;
12457
12458                Expec_Scope := Scope (Expec_Scope);
12459                Found_Scope := Scope (Found_Scope);
12460
12461                exit when Expec_Scope = Standard_Standard
12462                  or else Found_Scope = Standard_Standard
12463                  or else not Comes_From_Source (Expec_Scope)
12464                  or else not Comes_From_Source (Found_Scope);
12465             end loop;
12466          end;
12467
12468          if Is_Record_Type (Expec_Type)
12469            and then Present (Corresponding_Remote_Type (Expec_Type))
12470          then
12471             Error_Msg_NE ("expected}!", Expr,
12472                           Corresponding_Remote_Type (Expec_Type));
12473          else
12474             Error_Msg_NE ("expected}!", Expr, Expec_Type);
12475          end if;
12476
12477          if Is_Entity_Name (Expr)
12478            and then Is_Package_Or_Generic_Package (Entity (Expr))
12479          then
12480             Error_Msg_N ("\\found package name!", Expr);
12481
12482          elsif Is_Entity_Name (Expr)
12483            and then
12484              (Ekind (Entity (Expr)) = E_Procedure
12485                 or else
12486               Ekind (Entity (Expr)) = E_Generic_Procedure)
12487          then
12488             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
12489                Error_Msg_N
12490                  ("found procedure name, possibly missing Access attribute!",
12491                    Expr);
12492             else
12493                Error_Msg_N
12494                  ("\\found procedure name instead of function!", Expr);
12495             end if;
12496
12497          elsif Nkind (Expr) = N_Function_Call
12498            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
12499            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
12500            and then No (Parameter_Associations (Expr))
12501          then
12502             Error_Msg_N
12503               ("found function name, possibly missing Access attribute!",
12504                Expr);
12505
12506          --  Catch common error: a prefix or infix operator which is not
12507          --  directly visible because the type isn't.
12508
12509          elsif Nkind (Expr) in N_Op
12510             and then Is_Overloaded (Expr)
12511             and then not Is_Immediately_Visible (Expec_Type)
12512             and then not Is_Potentially_Use_Visible (Expec_Type)
12513             and then not In_Use (Expec_Type)
12514             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
12515          then
12516             Error_Msg_N
12517               ("operator of the type is not directly visible!", Expr);
12518
12519          elsif Ekind (Found_Type) = E_Void
12520            and then Present (Parent (Found_Type))
12521            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
12522          then
12523             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
12524
12525          else
12526             Error_Msg_NE ("\\found}!", Expr, Found_Type);
12527          end if;
12528
12529          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
12530          --  of the same modular type, and (M1 and M2) = 0 was intended.
12531
12532          if Expec_Type = Standard_Boolean
12533            and then Is_Modular_Integer_Type (Found_Type)
12534            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
12535            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
12536          then
12537             declare
12538                Op : constant Node_Id := Right_Opnd (Parent (Expr));
12539                L  : constant Node_Id := Left_Opnd (Op);
12540                R  : constant Node_Id := Right_Opnd (Op);
12541             begin
12542                --  The case for the message is when the left operand of the
12543                --  comparison is the same modular type, or when it is an
12544                --  integer literal (or other universal integer expression),
12545                --  which would have been typed as the modular type if the
12546                --  parens had been there.
12547
12548                if (Etype (L) = Found_Type
12549                      or else
12550                    Etype (L) = Universal_Integer)
12551                  and then Is_Integer_Type (Etype (R))
12552                then
12553                   Error_Msg_N
12554                     ("\\possible missing parens for modular operation", Expr);
12555                end if;
12556             end;
12557          end if;
12558
12559          --  Reset error message qualification indication
12560
12561          Error_Msg_Qual_Level := 0;
12562       end if;
12563    end Wrong_Type;
12564
12565 end Sem_Util;