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