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_AAMP_Float --
5708    -------------------
5709
5710    function Is_AAMP_Float (E : Entity_Id) return Boolean is
5711       pragma Assert (Is_Type (E));
5712    begin
5713       return AAMP_On_Target
5714          and then Is_Floating_Point_Type (E)
5715          and then E = Base_Type (E);
5716    end Is_AAMP_Float;
5717
5718    -----------------------------
5719    -- Is_Actual_Out_Parameter --
5720    -----------------------------
5721
5722    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
5723       Formal : Entity_Id;
5724       Call   : Node_Id;
5725    begin
5726       Find_Actual (N, Formal, Call);
5727       return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
5728    end Is_Actual_Out_Parameter;
5729
5730    -------------------------
5731    -- Is_Actual_Parameter --
5732    -------------------------
5733
5734    function Is_Actual_Parameter (N : Node_Id) return Boolean is
5735       PK : constant Node_Kind := Nkind (Parent (N));
5736
5737    begin
5738       case PK is
5739          when N_Parameter_Association =>
5740             return N = Explicit_Actual_Parameter (Parent (N));
5741
5742          when N_Function_Call | N_Procedure_Call_Statement =>
5743             return Is_List_Member (N)
5744               and then
5745                 List_Containing (N) = Parameter_Associations (Parent (N));
5746
5747          when others =>
5748             return False;
5749       end case;
5750    end Is_Actual_Parameter;
5751
5752    ---------------------
5753    -- Is_Aliased_View --
5754    ---------------------
5755
5756    function Is_Aliased_View (Obj : Node_Id) return Boolean is
5757       E : Entity_Id;
5758
5759    begin
5760       if Is_Entity_Name (Obj) then
5761
5762          E := Entity (Obj);
5763
5764          return
5765            (Is_Object (E)
5766              and then
5767                (Is_Aliased (E)
5768                   or else (Present (Renamed_Object (E))
5769                              and then Is_Aliased_View (Renamed_Object (E)))))
5770
5771            or else ((Is_Formal (E)
5772                       or else Ekind (E) = E_Generic_In_Out_Parameter
5773                       or else Ekind (E) = E_Generic_In_Parameter)
5774                     and then Is_Tagged_Type (Etype (E)))
5775
5776            or else (Is_Concurrent_Type (E)
5777                      and then In_Open_Scopes (E))
5778
5779             --  Current instance of type, either directly or as rewritten
5780             --  reference to the current object.
5781
5782            or else (Is_Entity_Name (Original_Node (Obj))
5783                      and then Present (Entity (Original_Node (Obj)))
5784                      and then Is_Type (Entity (Original_Node (Obj))))
5785
5786            or else (Is_Type (E) and then E = Current_Scope)
5787
5788            or else (Is_Incomplete_Or_Private_Type (E)
5789                      and then Full_View (E) = Current_Scope);
5790
5791       elsif Nkind (Obj) = N_Selected_Component then
5792          return Is_Aliased (Entity (Selector_Name (Obj)));
5793
5794       elsif Nkind (Obj) = N_Indexed_Component then
5795          return Has_Aliased_Components (Etype (Prefix (Obj)))
5796            or else
5797              (Is_Access_Type (Etype (Prefix (Obj)))
5798                and then
5799               Has_Aliased_Components
5800                 (Designated_Type (Etype (Prefix (Obj)))));
5801
5802       elsif Nkind (Obj) = N_Unchecked_Type_Conversion
5803         or else Nkind (Obj) = N_Type_Conversion
5804       then
5805          return Is_Tagged_Type (Etype (Obj))
5806            and then Is_Aliased_View (Expression (Obj));
5807
5808       elsif Nkind (Obj) = N_Explicit_Dereference then
5809          return Nkind (Original_Node (Obj)) /= N_Function_Call;
5810
5811       else
5812          return False;
5813       end if;
5814    end Is_Aliased_View;
5815
5816    -------------------------
5817    -- Is_Ancestor_Package --
5818    -------------------------
5819
5820    function Is_Ancestor_Package
5821      (E1 : Entity_Id;
5822       E2 : Entity_Id) return Boolean
5823    is
5824       Par : Entity_Id;
5825
5826    begin
5827       Par := E2;
5828       while Present (Par)
5829         and then Par /= Standard_Standard
5830       loop
5831          if Par = E1 then
5832             return True;
5833          end if;
5834
5835          Par := Scope (Par);
5836       end loop;
5837
5838       return False;
5839    end Is_Ancestor_Package;
5840
5841    ----------------------
5842    -- Is_Atomic_Object --
5843    ----------------------
5844
5845    function Is_Atomic_Object (N : Node_Id) return Boolean is
5846
5847       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
5848       --  Determines if given object has atomic components
5849
5850       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
5851       --  If prefix is an implicit dereference, examine designated type
5852
5853       ----------------------
5854       -- Is_Atomic_Prefix --
5855       ----------------------
5856
5857       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
5858       begin
5859          if Is_Access_Type (Etype (N)) then
5860             return
5861               Has_Atomic_Components (Designated_Type (Etype (N)));
5862          else
5863             return Object_Has_Atomic_Components (N);
5864          end if;
5865       end Is_Atomic_Prefix;
5866
5867       ----------------------------------
5868       -- Object_Has_Atomic_Components --
5869       ----------------------------------
5870
5871       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
5872       begin
5873          if Has_Atomic_Components (Etype (N))
5874            or else Is_Atomic (Etype (N))
5875          then
5876             return True;
5877
5878          elsif Is_Entity_Name (N)
5879            and then (Has_Atomic_Components (Entity (N))
5880                       or else Is_Atomic (Entity (N)))
5881          then
5882             return True;
5883
5884          elsif Nkind (N) = N_Indexed_Component
5885            or else Nkind (N) = N_Selected_Component
5886          then
5887             return Is_Atomic_Prefix (Prefix (N));
5888
5889          else
5890             return False;
5891          end if;
5892       end Object_Has_Atomic_Components;
5893
5894    --  Start of processing for Is_Atomic_Object
5895
5896    begin
5897       --  Predicate is not relevant to subprograms
5898
5899       if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
5900          return False;
5901
5902       elsif Is_Atomic (Etype (N))
5903         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
5904       then
5905          return True;
5906
5907       elsif Nkind (N) = N_Indexed_Component
5908         or else Nkind (N) = N_Selected_Component
5909       then
5910          return Is_Atomic_Prefix (Prefix (N));
5911
5912       else
5913          return False;
5914       end if;
5915    end Is_Atomic_Object;
5916
5917    -------------------------
5918    -- Is_Coextension_Root --
5919    -------------------------
5920
5921    function Is_Coextension_Root (N : Node_Id) return Boolean is
5922    begin
5923       return
5924         Nkind (N) = N_Allocator
5925           and then Present (Coextensions (N))
5926
5927          --  Anonymous access discriminants carry a list of all nested
5928          --  controlled coextensions.
5929
5930           and then not Is_Dynamic_Coextension (N)
5931           and then not Is_Static_Coextension (N);
5932    end Is_Coextension_Root;
5933
5934    -----------------------------
5935    -- Is_Concurrent_Interface --
5936    -----------------------------
5937
5938    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
5939    begin
5940       return
5941         Is_Interface (T)
5942           and then
5943             (Is_Protected_Interface (T)
5944                or else Is_Synchronized_Interface (T)
5945                or else Is_Task_Interface (T));
5946    end Is_Concurrent_Interface;
5947
5948    --------------------------------------
5949    -- Is_Controlling_Limited_Procedure --
5950    --------------------------------------
5951
5952    function Is_Controlling_Limited_Procedure
5953      (Proc_Nam : Entity_Id) return Boolean
5954    is
5955       Param_Typ : Entity_Id := Empty;
5956
5957    begin
5958       if Ekind (Proc_Nam) = E_Procedure
5959         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
5960       then
5961          Param_Typ := Etype (Parameter_Type (First (
5962                         Parameter_Specifications (Parent (Proc_Nam)))));
5963
5964       --  In this case where an Itype was created, the procedure call has been
5965       --  rewritten.
5966
5967       elsif Present (Associated_Node_For_Itype (Proc_Nam))
5968         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
5969         and then
5970           Present (Parameter_Associations
5971                      (Associated_Node_For_Itype (Proc_Nam)))
5972       then
5973          Param_Typ :=
5974            Etype (First (Parameter_Associations
5975                           (Associated_Node_For_Itype (Proc_Nam))));
5976       end if;
5977
5978       if Present (Param_Typ) then
5979          return
5980            Is_Interface (Param_Typ)
5981              and then Is_Limited_Record (Param_Typ);
5982       end if;
5983
5984       return False;
5985    end Is_Controlling_Limited_Procedure;
5986
5987    -----------------------------
5988    -- Is_CPP_Constructor_Call --
5989    -----------------------------
5990
5991    function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
5992    begin
5993       return Nkind (N) = N_Function_Call
5994         and then Is_CPP_Class (Etype (Etype (N)))
5995         and then Is_Constructor (Entity (Name (N)))
5996         and then Is_Imported (Entity (Name (N)));
5997    end Is_CPP_Constructor_Call;
5998
5999    -----------------
6000    -- Is_Delegate --
6001    -----------------
6002
6003    function Is_Delegate (T : Entity_Id) return Boolean is
6004       Desig_Type : Entity_Id;
6005
6006    begin
6007       if VM_Target /= CLI_Target then
6008          return False;
6009       end if;
6010
6011       --  Access-to-subprograms are delegates in CIL
6012
6013       if Ekind (T) = E_Access_Subprogram_Type then
6014          return True;
6015       end if;
6016
6017       if Ekind (T) not in Access_Kind then
6018
6019          --  A delegate is a managed pointer. If no designated type is defined
6020          --  it means that it's not a delegate.
6021
6022          return False;
6023       end if;
6024
6025       Desig_Type := Etype (Directly_Designated_Type (T));
6026
6027       if not Is_Tagged_Type (Desig_Type) then
6028          return False;
6029       end if;
6030
6031       --  Test if the type is inherited from [mscorlib]System.Delegate
6032
6033       while Etype (Desig_Type) /= Desig_Type loop
6034          if Chars (Scope (Desig_Type)) /= No_Name
6035            and then Is_Imported (Scope (Desig_Type))
6036            and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
6037          then
6038             return True;
6039          end if;
6040
6041          Desig_Type := Etype (Desig_Type);
6042       end loop;
6043
6044       return False;
6045    end Is_Delegate;
6046
6047    ----------------------------------------------
6048    -- Is_Dependent_Component_Of_Mutable_Object --
6049    ----------------------------------------------
6050
6051    function Is_Dependent_Component_Of_Mutable_Object
6052      (Object : Node_Id) return Boolean
6053    is
6054       P           : Node_Id;
6055       Prefix_Type : Entity_Id;
6056       P_Aliased   : Boolean := False;
6057       Comp        : Entity_Id;
6058
6059       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
6060       --  Returns True if and only if Comp is declared within a variant part
6061
6062       --------------------------------
6063       -- Is_Declared_Within_Variant --
6064       --------------------------------
6065
6066       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
6067          Comp_Decl : constant Node_Id   := Parent (Comp);
6068          Comp_List : constant Node_Id   := Parent (Comp_Decl);
6069       begin
6070          return Nkind (Parent (Comp_List)) = N_Variant;
6071       end Is_Declared_Within_Variant;
6072
6073    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
6074
6075    begin
6076       if Is_Variable (Object) then
6077
6078          if Nkind (Object) = N_Selected_Component then
6079             P := Prefix (Object);
6080             Prefix_Type := Etype (P);
6081
6082             if Is_Entity_Name (P) then
6083
6084                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
6085                   Prefix_Type := Base_Type (Prefix_Type);
6086                end if;
6087
6088                if Is_Aliased (Entity (P)) then
6089                   P_Aliased := True;
6090                end if;
6091
6092             --  A discriminant check on a selected component may be expanded
6093             --  into a dereference when removing side-effects. Recover the
6094             --  original node and its type, which may be unconstrained.
6095
6096             elsif Nkind (P) = N_Explicit_Dereference
6097               and then not (Comes_From_Source (P))
6098             then
6099                P := Original_Node (P);
6100                Prefix_Type := Etype (P);
6101
6102             else
6103                --  Check for prefix being an aliased component???
6104
6105                null;
6106
6107             end if;
6108
6109             --  A heap object is constrained by its initial value
6110
6111             --  Ada 2005 (AI-363): Always assume the object could be mutable in
6112             --  the dereferenced case, since the access value might denote an
6113             --  unconstrained aliased object, whereas in Ada 95 the designated
6114             --  object is guaranteed to be constrained. A worst-case assumption
6115             --  has to apply in Ada 2005 because we can't tell at compile time
6116             --  whether the object is "constrained by its initial value"
6117             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
6118             --  semantic rules -- these rules are acknowledged to need fixing).
6119
6120             if Ada_Version < Ada_2005 then
6121                if Is_Access_Type (Prefix_Type)
6122                  or else Nkind (P) = N_Explicit_Dereference
6123                then
6124                   return False;
6125                end if;
6126
6127             elsif Ada_Version >= Ada_2005 then
6128                if Is_Access_Type (Prefix_Type) then
6129
6130                   --  If the access type is pool-specific, and there is no
6131                   --  constrained partial view of the designated type, then the
6132                   --  designated object is known to be constrained.
6133
6134                   if Ekind (Prefix_Type) = E_Access_Type
6135                     and then not Has_Constrained_Partial_View
6136                                    (Designated_Type (Prefix_Type))
6137                   then
6138                      return False;
6139
6140                   --  Otherwise (general access type, or there is a constrained
6141                   --  partial view of the designated type), we need to check
6142                   --  based on the designated type.
6143
6144                   else
6145                      Prefix_Type := Designated_Type (Prefix_Type);
6146                   end if;
6147                end if;
6148             end if;
6149
6150             Comp :=
6151               Original_Record_Component (Entity (Selector_Name (Object)));
6152
6153             --  As per AI-0017, the renaming is illegal in a generic body, even
6154             --  if the subtype is indefinite.
6155
6156             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
6157
6158             if not Is_Constrained (Prefix_Type)
6159               and then (not Is_Indefinite_Subtype (Prefix_Type)
6160                          or else
6161                           (Is_Generic_Type (Prefix_Type)
6162                             and then Ekind (Current_Scope) = E_Generic_Package
6163                             and then In_Package_Body (Current_Scope)))
6164
6165               and then (Is_Declared_Within_Variant (Comp)
6166                           or else Has_Discriminant_Dependent_Constraint (Comp))
6167               and then (not P_Aliased or else Ada_Version >= Ada_2005)
6168             then
6169                return True;
6170
6171             else
6172                return
6173                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6174
6175             end if;
6176
6177          elsif Nkind (Object) = N_Indexed_Component
6178            or else Nkind (Object) = N_Slice
6179          then
6180             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6181
6182          --  A type conversion that Is_Variable is a view conversion:
6183          --  go back to the denoted object.
6184
6185          elsif Nkind (Object) = N_Type_Conversion then
6186             return
6187               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
6188          end if;
6189       end if;
6190
6191       return False;
6192    end Is_Dependent_Component_Of_Mutable_Object;
6193
6194    ---------------------
6195    -- Is_Dereferenced --
6196    ---------------------
6197
6198    function Is_Dereferenced (N : Node_Id) return Boolean is
6199       P : constant Node_Id := Parent (N);
6200    begin
6201       return
6202          (Nkind (P) = N_Selected_Component
6203             or else
6204           Nkind (P) = N_Explicit_Dereference
6205             or else
6206           Nkind (P) = N_Indexed_Component
6207             or else
6208           Nkind (P) = N_Slice)
6209         and then Prefix (P) = N;
6210    end Is_Dereferenced;
6211
6212    ----------------------
6213    -- Is_Descendent_Of --
6214    ----------------------
6215
6216    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
6217       T    : Entity_Id;
6218       Etyp : Entity_Id;
6219
6220    begin
6221       pragma Assert (Nkind (T1) in N_Entity);
6222       pragma Assert (Nkind (T2) in N_Entity);
6223
6224       T := Base_Type (T1);
6225
6226       --  Immediate return if the types match
6227
6228       if T = T2 then
6229          return True;
6230
6231       --  Comment needed here ???
6232
6233       elsif Ekind (T) = E_Class_Wide_Type then
6234          return Etype (T) = T2;
6235
6236       --  All other cases
6237
6238       else
6239          loop
6240             Etyp := Etype (T);
6241
6242             --  Done if we found the type we are looking for
6243
6244             if Etyp = T2 then
6245                return True;
6246
6247             --  Done if no more derivations to check
6248
6249             elsif T = T1
6250               or else T = Etyp
6251             then
6252                return False;
6253
6254             --  Following test catches error cases resulting from prev errors
6255
6256             elsif No (Etyp) then
6257                return False;
6258
6259             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
6260                return False;
6261
6262             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
6263                return False;
6264             end if;
6265
6266             T := Base_Type (Etyp);
6267          end loop;
6268       end if;
6269    end Is_Descendent_Of;
6270
6271    --------------
6272    -- Is_False --
6273    --------------
6274
6275    function Is_False (U : Uint) return Boolean is
6276    begin
6277       return (U = 0);
6278    end Is_False;
6279
6280    ---------------------------
6281    -- Is_Fixed_Model_Number --
6282    ---------------------------
6283
6284    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
6285       S : constant Ureal := Small_Value (T);
6286       M : Urealp.Save_Mark;
6287       R : Boolean;
6288    begin
6289       M := Urealp.Mark;
6290       R := (U = UR_Trunc (U / S) * S);
6291       Urealp.Release (M);
6292       return R;
6293    end Is_Fixed_Model_Number;
6294
6295    -------------------------------
6296    -- Is_Fully_Initialized_Type --
6297    -------------------------------
6298
6299    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
6300    begin
6301       if Is_Scalar_Type (Typ) then
6302          return False;
6303
6304       elsif Is_Access_Type (Typ) then
6305          return True;
6306
6307       elsif Is_Array_Type (Typ) then
6308          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
6309             return True;
6310          end if;
6311
6312          --  An interesting case, if we have a constrained type one of whose
6313          --  bounds is known to be null, then there are no elements to be
6314          --  initialized, so all the elements are initialized!
6315
6316          if Is_Constrained (Typ) then
6317             declare
6318                Indx     : Node_Id;
6319                Indx_Typ : Entity_Id;
6320                Lbd, Hbd : Node_Id;
6321
6322             begin
6323                Indx := First_Index (Typ);
6324                while Present (Indx) loop
6325                   if Etype (Indx) = Any_Type then
6326                      return False;
6327
6328                   --  If index is a range, use directly
6329
6330                   elsif Nkind (Indx) = N_Range then
6331                      Lbd := Low_Bound  (Indx);
6332                      Hbd := High_Bound (Indx);
6333
6334                   else
6335                      Indx_Typ := Etype (Indx);
6336
6337                      if Is_Private_Type (Indx_Typ)  then
6338                         Indx_Typ := Full_View (Indx_Typ);
6339                      end if;
6340
6341                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
6342                         return False;
6343                      else
6344                         Lbd := Type_Low_Bound  (Indx_Typ);
6345                         Hbd := Type_High_Bound (Indx_Typ);
6346                      end if;
6347                   end if;
6348
6349                   if Compile_Time_Known_Value (Lbd)
6350                     and then Compile_Time_Known_Value (Hbd)
6351                   then
6352                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
6353                         return True;
6354                      end if;
6355                   end if;
6356
6357                   Next_Index (Indx);
6358                end loop;
6359             end;
6360          end if;
6361
6362          --  If no null indexes, then type is not fully initialized
6363
6364          return False;
6365
6366       --  Record types
6367
6368       elsif Is_Record_Type (Typ) then
6369          if Has_Discriminants (Typ)
6370            and then
6371              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
6372            and then Is_Fully_Initialized_Variant (Typ)
6373          then
6374             return True;
6375          end if;
6376
6377          --  Controlled records are considered to be fully initialized if
6378          --  there is a user defined Initialize routine. This may not be
6379          --  entirely correct, but as the spec notes, we are guessing here
6380          --  what is best from the point of view of issuing warnings.
6381
6382          if Is_Controlled (Typ) then
6383             declare
6384                Utyp : constant Entity_Id := Underlying_Type (Typ);
6385
6386             begin
6387                if Present (Utyp) then
6388                   declare
6389                      Init : constant Entity_Id :=
6390                               (Find_Prim_Op
6391                                  (Underlying_Type (Typ), Name_Initialize));
6392
6393                   begin
6394                      if Present (Init)
6395                        and then Comes_From_Source (Init)
6396                        and then not
6397                          Is_Predefined_File_Name
6398                            (File_Name (Get_Source_File_Index (Sloc (Init))))
6399                      then
6400                         return True;
6401
6402                      elsif Has_Null_Extension (Typ)
6403                         and then
6404                           Is_Fully_Initialized_Type
6405                             (Etype (Base_Type (Typ)))
6406                      then
6407                         return True;
6408                      end if;
6409                   end;
6410                end if;
6411             end;
6412          end if;
6413
6414          --  Otherwise see if all record components are initialized
6415
6416          declare
6417             Ent : Entity_Id;
6418
6419          begin
6420             Ent := First_Entity (Typ);
6421             while Present (Ent) loop
6422                if Chars (Ent) = Name_uController then
6423                   null;
6424
6425                elsif Ekind (Ent) = E_Component
6426                  and then (No (Parent (Ent))
6427                              or else No (Expression (Parent (Ent))))
6428                  and then not Is_Fully_Initialized_Type (Etype (Ent))
6429
6430                   --  Special VM case for tag components, which need to be
6431                   --  defined in this case, but are never initialized as VMs
6432                   --  are using other dispatching mechanisms. Ignore this
6433                   --  uninitialized case. Note that this applies both to the
6434                   --  uTag entry and the main vtable pointer (CPP_Class case).
6435
6436                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
6437                then
6438                   return False;
6439                end if;
6440
6441                Next_Entity (Ent);
6442             end loop;
6443          end;
6444
6445          --  No uninitialized components, so type is fully initialized.
6446          --  Note that this catches the case of no components as well.
6447
6448          return True;
6449
6450       elsif Is_Concurrent_Type (Typ) then
6451          return True;
6452
6453       elsif Is_Private_Type (Typ) then
6454          declare
6455             U : constant Entity_Id := Underlying_Type (Typ);
6456
6457          begin
6458             if No (U) then
6459                return False;
6460             else
6461                return Is_Fully_Initialized_Type (U);
6462             end if;
6463          end;
6464
6465       else
6466          return False;
6467       end if;
6468    end Is_Fully_Initialized_Type;
6469
6470    ----------------------------------
6471    -- Is_Fully_Initialized_Variant --
6472    ----------------------------------
6473
6474    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
6475       Loc           : constant Source_Ptr := Sloc (Typ);
6476       Constraints   : constant List_Id    := New_List;
6477       Components    : constant Elist_Id   := New_Elmt_List;
6478       Comp_Elmt     : Elmt_Id;
6479       Comp_Id       : Node_Id;
6480       Comp_List     : Node_Id;
6481       Discr         : Entity_Id;
6482       Discr_Val     : Node_Id;
6483
6484       Report_Errors : Boolean;
6485       pragma Warnings (Off, Report_Errors);
6486
6487    begin
6488       if Serious_Errors_Detected > 0 then
6489          return False;
6490       end if;
6491
6492       if Is_Record_Type (Typ)
6493         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
6494         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
6495       then
6496          Comp_List := Component_List (Type_Definition (Parent (Typ)));
6497
6498          Discr := First_Discriminant (Typ);
6499          while Present (Discr) loop
6500             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
6501                Discr_Val := Expression (Parent (Discr));
6502
6503                if Present (Discr_Val)
6504                  and then Is_OK_Static_Expression (Discr_Val)
6505                then
6506                   Append_To (Constraints,
6507                     Make_Component_Association (Loc,
6508                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
6509                       Expression => New_Copy (Discr_Val)));
6510                else
6511                   return False;
6512                end if;
6513             else
6514                return False;
6515             end if;
6516
6517             Next_Discriminant (Discr);
6518          end loop;
6519
6520          Gather_Components
6521            (Typ           => Typ,
6522             Comp_List     => Comp_List,
6523             Governed_By   => Constraints,
6524             Into          => Components,
6525             Report_Errors => Report_Errors);
6526
6527          --  Check that each component present is fully initialized
6528
6529          Comp_Elmt := First_Elmt (Components);
6530          while Present (Comp_Elmt) loop
6531             Comp_Id := Node (Comp_Elmt);
6532
6533             if Ekind (Comp_Id) = E_Component
6534               and then (No (Parent (Comp_Id))
6535                          or else No (Expression (Parent (Comp_Id))))
6536               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
6537             then
6538                return False;
6539             end if;
6540
6541             Next_Elmt (Comp_Elmt);
6542          end loop;
6543
6544          return True;
6545
6546       elsif Is_Private_Type (Typ) then
6547          declare
6548             U : constant Entity_Id := Underlying_Type (Typ);
6549
6550          begin
6551             if No (U) then
6552                return False;
6553             else
6554                return Is_Fully_Initialized_Variant (U);
6555             end if;
6556          end;
6557       else
6558          return False;
6559       end if;
6560    end Is_Fully_Initialized_Variant;
6561
6562    ------------
6563    -- Is_LHS --
6564    ------------
6565
6566    --  We seem to have a lot of overlapping functions that do similar things
6567    --  (testing for left hand sides or lvalues???). Anyway, since this one is
6568    --  purely syntactic, it should be in Sem_Aux I would think???
6569
6570    function Is_LHS (N : Node_Id) return Boolean is
6571       P : constant Node_Id := Parent (N);
6572    begin
6573       return Nkind (P) = N_Assignment_Statement
6574         and then Name (P) = N;
6575    end Is_LHS;
6576
6577    ----------------------------
6578    -- Is_Inherited_Operation --
6579    ----------------------------
6580
6581    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
6582       Kind : constant Node_Kind := Nkind (Parent (E));
6583    begin
6584       pragma Assert (Is_Overloadable (E));
6585       return Kind = N_Full_Type_Declaration
6586         or else Kind = N_Private_Extension_Declaration
6587         or else Kind = N_Subtype_Declaration
6588         or else (Ekind (E) = E_Enumeration_Literal
6589                   and then Is_Derived_Type (Etype (E)));
6590    end Is_Inherited_Operation;
6591
6592    -----------------------------
6593    -- Is_Library_Level_Entity --
6594    -----------------------------
6595
6596    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
6597    begin
6598       --  The following is a small optimization, and it also properly handles
6599       --  discriminals, which in task bodies might appear in expressions before
6600       --  the corresponding procedure has been created, and which therefore do
6601       --  not have an assigned scope.
6602
6603       if Is_Formal (E) then
6604          return False;
6605       end if;
6606
6607       --  Normal test is simply that the enclosing dynamic scope is Standard
6608
6609       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
6610    end Is_Library_Level_Entity;
6611
6612    ---------------------------------
6613    -- Is_Local_Variable_Reference --
6614    ---------------------------------
6615
6616    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
6617    begin
6618       if not Is_Entity_Name (Expr) then
6619          return False;
6620
6621       else
6622          declare
6623             Ent : constant Entity_Id := Entity (Expr);
6624             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
6625          begin
6626             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
6627                return False;
6628             else
6629                return Present (Sub) and then Sub = Current_Subprogram;
6630             end if;
6631          end;
6632       end if;
6633    end Is_Local_Variable_Reference;
6634
6635    -------------------------
6636    -- Is_Object_Reference --
6637    -------------------------
6638
6639    function Is_Object_Reference (N : Node_Id) return Boolean is
6640    begin
6641       if Is_Entity_Name (N) then
6642          return Present (Entity (N)) and then Is_Object (Entity (N));
6643
6644       else
6645          case Nkind (N) is
6646             when N_Indexed_Component | N_Slice =>
6647                return
6648                  Is_Object_Reference (Prefix (N))
6649                    or else Is_Access_Type (Etype (Prefix (N)));
6650
6651             --  In Ada95, a function call is a constant object; a procedure
6652             --  call is not.
6653
6654             when N_Function_Call =>
6655                return Etype (N) /= Standard_Void_Type;
6656
6657             --  A reference to the stream attribute Input is a function call
6658
6659             when N_Attribute_Reference =>
6660                return Attribute_Name (N) = Name_Input;
6661
6662             when N_Selected_Component =>
6663                return
6664                  Is_Object_Reference (Selector_Name (N))
6665                    and then
6666                      (Is_Object_Reference (Prefix (N))
6667                         or else Is_Access_Type (Etype (Prefix (N))));
6668
6669             when N_Explicit_Dereference =>
6670                return True;
6671
6672             --  A view conversion of a tagged object is an object reference
6673
6674             when N_Type_Conversion =>
6675                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
6676                  and then Is_Tagged_Type (Etype (Expression (N)))
6677                  and then Is_Object_Reference (Expression (N));
6678
6679             --  An unchecked type conversion is considered to be an object if
6680             --  the operand is an object (this construction arises only as a
6681             --  result of expansion activities).
6682
6683             when N_Unchecked_Type_Conversion =>
6684                return True;
6685
6686             when others =>
6687                return False;
6688          end case;
6689       end if;
6690    end Is_Object_Reference;
6691
6692    -----------------------------------
6693    -- Is_OK_Variable_For_Out_Formal --
6694    -----------------------------------
6695
6696    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
6697    begin
6698       Note_Possible_Modification (AV, Sure => True);
6699
6700       --  We must reject parenthesized variable names. The check for
6701       --  Comes_From_Source is present because there are currently
6702       --  cases where the compiler violates this rule (e.g. passing
6703       --  a task object to its controlled Initialize routine).
6704
6705       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
6706          return False;
6707
6708       --  A variable is always allowed
6709
6710       elsif Is_Variable (AV) then
6711          return True;
6712
6713       --  Unchecked conversions are allowed only if they come from the
6714       --  generated code, which sometimes uses unchecked conversions for out
6715       --  parameters in cases where code generation is unaffected. We tell
6716       --  source unchecked conversions by seeing if they are rewrites of an
6717       --  original Unchecked_Conversion function call, or of an explicit
6718       --  conversion of a function call.
6719
6720       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
6721          if Nkind (Original_Node (AV)) = N_Function_Call then
6722             return False;
6723
6724          elsif Comes_From_Source (AV)
6725            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
6726          then
6727             return False;
6728
6729          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
6730             return Is_OK_Variable_For_Out_Formal (Expression (AV));
6731
6732          else
6733             return True;
6734          end if;
6735
6736       --  Normal type conversions are allowed if argument is a variable
6737
6738       elsif Nkind (AV) = N_Type_Conversion then
6739          if Is_Variable (Expression (AV))
6740            and then Paren_Count (Expression (AV)) = 0
6741          then
6742             Note_Possible_Modification (Expression (AV), Sure => True);
6743             return True;
6744
6745          --  We also allow a non-parenthesized expression that raises
6746          --  constraint error if it rewrites what used to be a variable
6747
6748          elsif Raises_Constraint_Error (Expression (AV))
6749             and then Paren_Count (Expression (AV)) = 0
6750             and then Is_Variable (Original_Node (Expression (AV)))
6751          then
6752             return True;
6753
6754          --  Type conversion of something other than a variable
6755
6756          else
6757             return False;
6758          end if;
6759
6760       --  If this node is rewritten, then test the original form, if that is
6761       --  OK, then we consider the rewritten node OK (for example, if the
6762       --  original node is a conversion, then Is_Variable will not be true
6763       --  but we still want to allow the conversion if it converts a variable).
6764
6765       elsif Original_Node (AV) /= AV then
6766          return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
6767
6768       --  All other non-variables are rejected
6769
6770       else
6771          return False;
6772       end if;
6773    end Is_OK_Variable_For_Out_Formal;
6774
6775    -----------------------------------
6776    -- Is_Partially_Initialized_Type --
6777    -----------------------------------
6778
6779    function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
6780    begin
6781       if Is_Scalar_Type (Typ) then
6782          return False;
6783
6784       elsif Is_Access_Type (Typ) then
6785          return True;
6786
6787       elsif Is_Array_Type (Typ) then
6788
6789          --  If component type is partially initialized, so is array type
6790
6791          if Is_Partially_Initialized_Type (Component_Type (Typ)) then
6792             return True;
6793
6794          --  Otherwise we are only partially initialized if we are fully
6795          --  initialized (this is the empty array case, no point in us
6796          --  duplicating that code here).
6797
6798          else
6799             return Is_Fully_Initialized_Type (Typ);
6800          end if;
6801
6802       elsif Is_Record_Type (Typ) then
6803
6804          --  A discriminated type is always partially initialized
6805
6806          if Has_Discriminants (Typ) then
6807             return True;
6808
6809          --  A tagged type is always partially initialized
6810
6811          elsif Is_Tagged_Type (Typ) then
6812             return True;
6813
6814          --  Case of non-discriminated record
6815
6816          else
6817             declare
6818                Ent : Entity_Id;
6819
6820                Component_Present : Boolean := False;
6821                --  Set True if at least one component is present. If no
6822                --  components are present, then record type is fully
6823                --  initialized (another odd case, like the null array).
6824
6825             begin
6826                --  Loop through components
6827
6828                Ent := First_Entity (Typ);
6829                while Present (Ent) loop
6830                   if Ekind (Ent) = E_Component then
6831                      Component_Present := True;
6832
6833                      --  If a component has an initialization expression then
6834                      --  the enclosing record type is partially initialized
6835
6836                      if Present (Parent (Ent))
6837                        and then Present (Expression (Parent (Ent)))
6838                      then
6839                         return True;
6840
6841                      --  If a component is of a type which is itself partially
6842                      --  initialized, then the enclosing record type is also.
6843
6844                      elsif Is_Partially_Initialized_Type (Etype (Ent)) then
6845                         return True;
6846                      end if;
6847                   end if;
6848
6849                   Next_Entity (Ent);
6850                end loop;
6851
6852                --  No initialized components found. If we found any components
6853                --  they were all uninitialized so the result is false.
6854
6855                if Component_Present then
6856                   return False;
6857
6858                --  But if we found no components, then all the components are
6859                --  initialized so we consider the type to be initialized.
6860
6861                else
6862                   return True;
6863                end if;
6864             end;
6865          end if;
6866
6867       --  Concurrent types are always fully initialized
6868
6869       elsif Is_Concurrent_Type (Typ) then
6870          return True;
6871
6872       --  For a private type, go to underlying type. If there is no underlying
6873       --  type then just assume this partially initialized. Not clear if this
6874       --  can happen in a non-error case, but no harm in testing for this.
6875
6876       elsif Is_Private_Type (Typ) then
6877          declare
6878             U : constant Entity_Id := Underlying_Type (Typ);
6879          begin
6880             if No (U) then
6881                return True;
6882             else
6883                return Is_Partially_Initialized_Type (U);
6884             end if;
6885          end;
6886
6887       --  For any other type (are there any?) assume partially initialized
6888
6889       else
6890          return True;
6891       end if;
6892    end Is_Partially_Initialized_Type;
6893
6894    ------------------------------------
6895    -- Is_Potentially_Persistent_Type --
6896    ------------------------------------
6897
6898    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
6899       Comp : Entity_Id;
6900       Indx : Node_Id;
6901
6902    begin
6903       --  For private type, test corresponding full type
6904
6905       if Is_Private_Type (T) then
6906          return Is_Potentially_Persistent_Type (Full_View (T));
6907
6908       --  Scalar types are potentially persistent
6909
6910       elsif Is_Scalar_Type (T) then
6911          return True;
6912
6913       --  Record type is potentially persistent if not tagged and the types of
6914       --  all it components are potentially persistent, and no component has
6915       --  an initialization expression.
6916
6917       elsif Is_Record_Type (T)
6918         and then not Is_Tagged_Type (T)
6919         and then not Is_Partially_Initialized_Type (T)
6920       then
6921          Comp := First_Component (T);
6922          while Present (Comp) loop
6923             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
6924                return False;
6925             else
6926                Next_Entity (Comp);
6927             end if;
6928          end loop;
6929
6930          return True;
6931
6932       --  Array type is potentially persistent if its component type is
6933       --  potentially persistent and if all its constraints are static.
6934
6935       elsif Is_Array_Type (T) then
6936          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
6937             return False;
6938          end if;
6939
6940          Indx := First_Index (T);
6941          while Present (Indx) loop
6942             if not Is_OK_Static_Subtype (Etype (Indx)) then
6943                return False;
6944             else
6945                Next_Index (Indx);
6946             end if;
6947          end loop;
6948
6949          return True;
6950
6951       --  All other types are not potentially persistent
6952
6953       else
6954          return False;
6955       end if;
6956    end Is_Potentially_Persistent_Type;
6957
6958    ---------------------------------
6959    -- Is_Protected_Self_Reference --
6960    ---------------------------------
6961
6962    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
6963
6964       function In_Access_Definition (N : Node_Id) return Boolean;
6965       --  Returns true if N belongs to an access definition
6966
6967       --------------------------
6968       -- In_Access_Definition --
6969       --------------------------
6970
6971       function In_Access_Definition (N : Node_Id) return Boolean is
6972          P : Node_Id;
6973
6974       begin
6975          P := Parent (N);
6976          while Present (P) loop
6977             if Nkind (P) = N_Access_Definition then
6978                return True;
6979             end if;
6980
6981             P := Parent (P);
6982          end loop;
6983
6984          return False;
6985       end In_Access_Definition;
6986
6987    --  Start of processing for Is_Protected_Self_Reference
6988
6989    begin
6990       --  Verify that prefix is analyzed and has the proper form. Note that
6991       --  the attributes Elab_Spec, Elab_Body, and UET_Address, which also
6992       --  produce the address of an entity, do not analyze their prefix
6993       --  because they denote entities that are not necessarily visible.
6994       --  Neither of them can apply to a protected type.
6995
6996       return Ada_Version >= Ada_2005
6997         and then Is_Entity_Name (N)
6998         and then Present (Entity (N))
6999         and then Is_Protected_Type (Entity (N))
7000         and then In_Open_Scopes (Entity (N))
7001         and then not In_Access_Definition (N);
7002    end Is_Protected_Self_Reference;
7003
7004    -----------------------------
7005    -- Is_RCI_Pkg_Spec_Or_Body --
7006    -----------------------------
7007
7008    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
7009
7010       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
7011       --  Return True if the unit of Cunit is an RCI package declaration
7012
7013       ---------------------------
7014       -- Is_RCI_Pkg_Decl_Cunit --
7015       ---------------------------
7016
7017       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
7018          The_Unit : constant Node_Id := Unit (Cunit);
7019
7020       begin
7021          if Nkind (The_Unit) /= N_Package_Declaration then
7022             return False;
7023          end if;
7024
7025          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
7026       end Is_RCI_Pkg_Decl_Cunit;
7027
7028    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
7029
7030    begin
7031       return Is_RCI_Pkg_Decl_Cunit (Cunit)
7032         or else
7033          (Nkind (Unit (Cunit)) = N_Package_Body
7034            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
7035    end Is_RCI_Pkg_Spec_Or_Body;
7036
7037    -----------------------------------------
7038    -- Is_Remote_Access_To_Class_Wide_Type --
7039    -----------------------------------------
7040
7041    function Is_Remote_Access_To_Class_Wide_Type
7042      (E : Entity_Id) return Boolean
7043    is
7044    begin
7045       --  A remote access to class-wide type is a general access to object type
7046       --  declared in the visible part of a Remote_Types or Remote_Call_
7047       --  Interface unit.
7048
7049       return Ekind (E) = E_General_Access_Type
7050         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7051    end Is_Remote_Access_To_Class_Wide_Type;
7052
7053    -----------------------------------------
7054    -- Is_Remote_Access_To_Subprogram_Type --
7055    -----------------------------------------
7056
7057    function Is_Remote_Access_To_Subprogram_Type
7058      (E : Entity_Id) return Boolean
7059    is
7060    begin
7061       return (Ekind (E) = E_Access_Subprogram_Type
7062                 or else (Ekind (E) = E_Record_Type
7063                            and then Present (Corresponding_Remote_Type (E))))
7064         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7065    end Is_Remote_Access_To_Subprogram_Type;
7066
7067    --------------------
7068    -- Is_Remote_Call --
7069    --------------------
7070
7071    function Is_Remote_Call (N : Node_Id) return Boolean is
7072    begin
7073       if Nkind (N) /= N_Procedure_Call_Statement
7074         and then Nkind (N) /= N_Function_Call
7075       then
7076          --  An entry call cannot be remote
7077
7078          return False;
7079
7080       elsif Nkind (Name (N)) in N_Has_Entity
7081         and then Is_Remote_Call_Interface (Entity (Name (N)))
7082       then
7083          --  A subprogram declared in the spec of a RCI package is remote
7084
7085          return True;
7086
7087       elsif Nkind (Name (N)) = N_Explicit_Dereference
7088         and then Is_Remote_Access_To_Subprogram_Type
7089                    (Etype (Prefix (Name (N))))
7090       then
7091          --  The dereference of a RAS is a remote call
7092
7093          return True;
7094
7095       elsif Present (Controlling_Argument (N))
7096         and then Is_Remote_Access_To_Class_Wide_Type
7097           (Etype (Controlling_Argument (N)))
7098       then
7099          --  Any primitive operation call with a controlling argument of
7100          --  a RACW type is a remote call.
7101
7102          return True;
7103       end if;
7104
7105       --  All other calls are local calls
7106
7107       return False;
7108    end Is_Remote_Call;
7109
7110    ----------------------
7111    -- Is_Renamed_Entry --
7112    ----------------------
7113
7114    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
7115       Orig_Node : Node_Id := Empty;
7116       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
7117
7118       function Is_Entry (Nam : Node_Id) return Boolean;
7119       --  Determine whether Nam is an entry. Traverse selectors if there are
7120       --  nested selected components.
7121
7122       --------------
7123       -- Is_Entry --
7124       --------------
7125
7126       function Is_Entry (Nam : Node_Id) return Boolean is
7127       begin
7128          if Nkind (Nam) = N_Selected_Component then
7129             return Is_Entry (Selector_Name (Nam));
7130          end if;
7131
7132          return Ekind (Entity (Nam)) = E_Entry;
7133       end Is_Entry;
7134
7135    --  Start of processing for Is_Renamed_Entry
7136
7137    begin
7138       if Present (Alias (Proc_Nam)) then
7139          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
7140       end if;
7141
7142       --  Look for a rewritten subprogram renaming declaration
7143
7144       if Nkind (Subp_Decl) = N_Subprogram_Declaration
7145         and then Present (Original_Node (Subp_Decl))
7146       then
7147          Orig_Node := Original_Node (Subp_Decl);
7148       end if;
7149
7150       --  The rewritten subprogram is actually an entry
7151
7152       if Present (Orig_Node)
7153         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
7154         and then Is_Entry (Name (Orig_Node))
7155       then
7156          return True;
7157       end if;
7158
7159       return False;
7160    end Is_Renamed_Entry;
7161
7162    ----------------------
7163    -- Is_Selector_Name --
7164    ----------------------
7165
7166    function Is_Selector_Name (N : Node_Id) return Boolean is
7167    begin
7168       if not Is_List_Member (N) then
7169          declare
7170             P : constant Node_Id   := Parent (N);
7171             K : constant Node_Kind := Nkind (P);
7172          begin
7173             return
7174               (K = N_Expanded_Name          or else
7175                K = N_Generic_Association    or else
7176                K = N_Parameter_Association  or else
7177                K = N_Selected_Component)
7178               and then Selector_Name (P) = N;
7179          end;
7180
7181       else
7182          declare
7183             L : constant List_Id := List_Containing (N);
7184             P : constant Node_Id := Parent (L);
7185          begin
7186             return (Nkind (P) = N_Discriminant_Association
7187                      and then Selector_Names (P) = L)
7188               or else
7189                    (Nkind (P) = N_Component_Association
7190                      and then Choices (P) = L);
7191          end;
7192       end if;
7193    end Is_Selector_Name;
7194
7195    ------------------
7196    -- Is_Statement --
7197    ------------------
7198
7199    function Is_Statement (N : Node_Id) return Boolean is
7200    begin
7201       return
7202         Nkind (N) in N_Statement_Other_Than_Procedure_Call
7203           or else Nkind (N) = N_Procedure_Call_Statement;
7204    end Is_Statement;
7205
7206    ---------------------------------
7207    -- Is_Synchronized_Tagged_Type --
7208    ---------------------------------
7209
7210    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
7211       Kind : constant Entity_Kind := Ekind (Base_Type (E));
7212
7213    begin
7214       --  A task or protected type derived from an interface is a tagged type.
7215       --  Such a tagged type is called a synchronized tagged type, as are
7216       --  synchronized interfaces and private extensions whose declaration
7217       --  includes the reserved word synchronized.
7218
7219       return (Is_Tagged_Type (E)
7220                 and then (Kind = E_Task_Type
7221                            or else Kind = E_Protected_Type))
7222             or else
7223              (Is_Interface (E)
7224                 and then Is_Synchronized_Interface (E))
7225             or else
7226              (Ekind (E) = E_Record_Type_With_Private
7227                 and then (Synchronized_Present (Parent (E))
7228                            or else Is_Synchronized_Interface (Etype (E))));
7229    end Is_Synchronized_Tagged_Type;
7230
7231    -----------------
7232    -- Is_Transfer --
7233    -----------------
7234
7235    function Is_Transfer (N : Node_Id) return Boolean is
7236       Kind : constant Node_Kind := Nkind (N);
7237
7238    begin
7239       if Kind = N_Simple_Return_Statement
7240            or else
7241          Kind = N_Extended_Return_Statement
7242            or else
7243          Kind = N_Goto_Statement
7244            or else
7245          Kind = N_Raise_Statement
7246            or else
7247          Kind = N_Requeue_Statement
7248       then
7249          return True;
7250
7251       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
7252         and then No (Condition (N))
7253       then
7254          return True;
7255
7256       elsif Kind = N_Procedure_Call_Statement
7257         and then Is_Entity_Name (Name (N))
7258         and then Present (Entity (Name (N)))
7259         and then No_Return (Entity (Name (N)))
7260       then
7261          return True;
7262
7263       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
7264          return True;
7265
7266       else
7267          return False;
7268       end if;
7269    end Is_Transfer;
7270
7271    -------------
7272    -- Is_True --
7273    -------------
7274
7275    function Is_True (U : Uint) return Boolean is
7276    begin
7277       return (U /= 0);
7278    end Is_True;
7279
7280    -------------------------------
7281    -- Is_Universal_Numeric_Type --
7282    -------------------------------
7283
7284    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
7285    begin
7286       return T = Universal_Integer or else T = Universal_Real;
7287    end Is_Universal_Numeric_Type;
7288
7289    -------------------
7290    -- Is_Value_Type --
7291    -------------------
7292
7293    function Is_Value_Type (T : Entity_Id) return Boolean is
7294    begin
7295       return VM_Target = CLI_Target
7296         and then Nkind (T) in N_Has_Chars
7297         and then Chars (T) /= No_Name
7298         and then Get_Name_String (Chars (T)) = "valuetype";
7299    end Is_Value_Type;
7300
7301    ---------------------
7302    -- Is_VMS_Operator --
7303    ---------------------
7304
7305    function Is_VMS_Operator (Op : Entity_Id) return Boolean is
7306    begin
7307       --  The VMS operators are declared in a child of System that is loaded
7308       --  through pragma Extend_System. In some rare cases a program is run
7309       --  with this extension but without indicating that the target is VMS.
7310
7311       return Ekind (Op) = E_Function
7312         and then Is_Intrinsic_Subprogram (Op)
7313         and then
7314           ((Present_System_Aux
7315             and then Scope (Op) = System_Aux_Id)
7316            or else
7317            (True_VMS_Target
7318              and then Scope (Scope (Op)) = RTU_Entity (System)));
7319    end Is_VMS_Operator;
7320
7321    -----------------
7322    -- Is_Variable --
7323    -----------------
7324
7325    function Is_Variable (N : Node_Id) return Boolean is
7326
7327       Orig_Node : constant Node_Id := Original_Node (N);
7328       --  We do the test on the original node, since this is basically a test
7329       --  of syntactic categories, so it must not be disturbed by whatever
7330       --  rewriting might have occurred. For example, an aggregate, which is
7331       --  certainly NOT a variable, could be turned into a variable by
7332       --  expansion.
7333
7334       function In_Protected_Function (E : Entity_Id) return Boolean;
7335       --  Within a protected function, the private components of the enclosing
7336       --  protected type are constants. A function nested within a (protected)
7337       --  procedure is not itself protected.
7338
7339       function Is_Variable_Prefix (P : Node_Id) return Boolean;
7340       --  Prefixes can involve implicit dereferences, in which case we must
7341       --  test for the case of a reference of a constant access type, which can
7342       --  can never be a variable.
7343
7344       ---------------------------
7345       -- In_Protected_Function --
7346       ---------------------------
7347
7348       function In_Protected_Function (E : Entity_Id) return Boolean is
7349          Prot : constant Entity_Id := Scope (E);
7350          S    : Entity_Id;
7351
7352       begin
7353          if not Is_Protected_Type (Prot) then
7354             return False;
7355          else
7356             S := Current_Scope;
7357             while Present (S) and then S /= Prot loop
7358                if Ekind (S) = E_Function and then Scope (S) = Prot then
7359                   return True;
7360                end if;
7361
7362                S := Scope (S);
7363             end loop;
7364
7365             return False;
7366          end if;
7367       end In_Protected_Function;
7368
7369       ------------------------
7370       -- Is_Variable_Prefix --
7371       ------------------------
7372
7373       function Is_Variable_Prefix (P : Node_Id) return Boolean is
7374       begin
7375          if Is_Access_Type (Etype (P)) then
7376             return not Is_Access_Constant (Root_Type (Etype (P)));
7377
7378          --  For the case of an indexed component whose prefix has a packed
7379          --  array type, the prefix has been rewritten into a type conversion.
7380          --  Determine variable-ness from the converted expression.
7381
7382          elsif Nkind (P) = N_Type_Conversion
7383            and then not Comes_From_Source (P)
7384            and then Is_Array_Type (Etype (P))
7385            and then Is_Packed (Etype (P))
7386          then
7387             return Is_Variable (Expression (P));
7388
7389          else
7390             return Is_Variable (P);
7391          end if;
7392       end Is_Variable_Prefix;
7393
7394    --  Start of processing for Is_Variable
7395
7396    begin
7397       --  Definitely OK if Assignment_OK is set. Since this is something that
7398       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
7399
7400       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
7401          return True;
7402
7403       --  Normally we go to the original node, but there is one exception where
7404       --  we use the rewritten node, namely when it is an explicit dereference.
7405       --  The generated code may rewrite a prefix which is an access type with
7406       --  an explicit dereference. The dereference is a variable, even though
7407       --  the original node may not be (since it could be a constant of the
7408       --  access type).
7409
7410       --  In Ada 2005 we have a further case to consider: the prefix may be a
7411       --  function call given in prefix notation. The original node appears to
7412       --  be a selected component, but we need to examine the call.
7413
7414       elsif Nkind (N) = N_Explicit_Dereference
7415         and then Nkind (Orig_Node) /= N_Explicit_Dereference
7416         and then Present (Etype (Orig_Node))
7417         and then Is_Access_Type (Etype (Orig_Node))
7418       then
7419          --  Note that if the prefix is an explicit dereference that does not
7420          --  come from source, we must check for a rewritten function call in
7421          --  prefixed notation before other forms of rewriting, to prevent a
7422          --  compiler crash.
7423
7424          return
7425            (Nkind (Orig_Node) = N_Function_Call
7426              and then not Is_Access_Constant (Etype (Prefix (N))))
7427            or else
7428              Is_Variable_Prefix (Original_Node (Prefix (N)));
7429
7430       --  A function call is never a variable
7431
7432       elsif Nkind (N) = N_Function_Call then
7433          return False;
7434
7435       --  All remaining checks use the original node
7436
7437       elsif Is_Entity_Name (Orig_Node)
7438         and then Present (Entity (Orig_Node))
7439       then
7440          declare
7441             E : constant Entity_Id := Entity (Orig_Node);
7442             K : constant Entity_Kind := Ekind (E);
7443
7444          begin
7445             return (K = E_Variable
7446                       and then Nkind (Parent (E)) /= N_Exception_Handler)
7447               or else  (K = E_Component
7448                           and then not In_Protected_Function (E))
7449               or else  K = E_Out_Parameter
7450               or else  K = E_In_Out_Parameter
7451               or else  K = E_Generic_In_Out_Parameter
7452
7453                --  Current instance of type:
7454
7455               or else (Is_Type (E) and then In_Open_Scopes (E))
7456               or else (Is_Incomplete_Or_Private_Type (E)
7457                         and then In_Open_Scopes (Full_View (E)));
7458          end;
7459
7460       else
7461          case Nkind (Orig_Node) is
7462             when N_Indexed_Component | N_Slice =>
7463                return Is_Variable_Prefix (Prefix (Orig_Node));
7464
7465             when N_Selected_Component =>
7466                return Is_Variable_Prefix (Prefix (Orig_Node))
7467                  and then Is_Variable (Selector_Name (Orig_Node));
7468
7469             --  For an explicit dereference, the type of the prefix cannot
7470             --  be an access to constant or an access to subprogram.
7471
7472             when N_Explicit_Dereference =>
7473                declare
7474                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
7475                begin
7476                   return Is_Access_Type (Typ)
7477                     and then not Is_Access_Constant (Root_Type (Typ))
7478                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
7479                end;
7480
7481             --  The type conversion is the case where we do not deal with the
7482             --  context dependent special case of an actual parameter. Thus
7483             --  the type conversion is only considered a variable for the
7484             --  purposes of this routine if the target type is tagged. However,
7485             --  a type conversion is considered to be a variable if it does not
7486             --  come from source (this deals for example with the conversions
7487             --  of expressions to their actual subtypes).
7488
7489             when N_Type_Conversion =>
7490                return Is_Variable (Expression (Orig_Node))
7491                  and then
7492                    (not Comes_From_Source (Orig_Node)
7493                       or else
7494                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
7495                           and then
7496                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
7497
7498             --  GNAT allows an unchecked type conversion as a variable. This
7499             --  only affects the generation of internal expanded code, since
7500             --  calls to instantiations of Unchecked_Conversion are never
7501             --  considered variables (since they are function calls).
7502             --  This is also true for expression actions.
7503
7504             when N_Unchecked_Type_Conversion =>
7505                return Is_Variable (Expression (Orig_Node));
7506
7507             when others =>
7508                return False;
7509          end case;
7510       end if;
7511    end Is_Variable;
7512
7513    ---------------------------
7514    -- Is_Visibly_Controlled --
7515    ---------------------------
7516
7517    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
7518       Root : constant Entity_Id := Root_Type (T);
7519    begin
7520       return Chars (Scope (Root)) = Name_Finalization
7521         and then Chars (Scope (Scope (Root))) = Name_Ada
7522         and then Scope (Scope (Scope (Root))) = Standard_Standard;
7523    end Is_Visibly_Controlled;
7524
7525    ------------------------
7526    -- Is_Volatile_Object --
7527    ------------------------
7528
7529    function Is_Volatile_Object (N : Node_Id) return Boolean is
7530
7531       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
7532       --  Determines if given object has volatile components
7533
7534       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
7535       --  If prefix is an implicit dereference, examine designated type
7536
7537       ------------------------
7538       -- Is_Volatile_Prefix --
7539       ------------------------
7540
7541       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
7542          Typ  : constant Entity_Id := Etype (N);
7543
7544       begin
7545          if Is_Access_Type (Typ) then
7546             declare
7547                Dtyp : constant Entity_Id := Designated_Type (Typ);
7548
7549             begin
7550                return Is_Volatile (Dtyp)
7551                  or else Has_Volatile_Components (Dtyp);
7552             end;
7553
7554          else
7555             return Object_Has_Volatile_Components (N);
7556          end if;
7557       end Is_Volatile_Prefix;
7558
7559       ------------------------------------
7560       -- Object_Has_Volatile_Components --
7561       ------------------------------------
7562
7563       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
7564          Typ : constant Entity_Id := Etype (N);
7565
7566       begin
7567          if Is_Volatile (Typ)
7568            or else Has_Volatile_Components (Typ)
7569          then
7570             return True;
7571
7572          elsif Is_Entity_Name (N)
7573            and then (Has_Volatile_Components (Entity (N))
7574                       or else Is_Volatile (Entity (N)))
7575          then
7576             return True;
7577
7578          elsif Nkind (N) = N_Indexed_Component
7579            or else Nkind (N) = N_Selected_Component
7580          then
7581             return Is_Volatile_Prefix (Prefix (N));
7582
7583          else
7584             return False;
7585          end if;
7586       end Object_Has_Volatile_Components;
7587
7588    --  Start of processing for Is_Volatile_Object
7589
7590    begin
7591       if Is_Volatile (Etype (N))
7592         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
7593       then
7594          return True;
7595
7596       elsif Nkind (N) = N_Indexed_Component
7597         or else Nkind (N) = N_Selected_Component
7598       then
7599          return Is_Volatile_Prefix (Prefix (N));
7600
7601       else
7602          return False;
7603       end if;
7604    end Is_Volatile_Object;
7605
7606    -------------------------
7607    -- Kill_Current_Values --
7608    -------------------------
7609
7610    procedure Kill_Current_Values
7611      (Ent                  : Entity_Id;
7612       Last_Assignment_Only : Boolean := False)
7613    is
7614    begin
7615       --  ??? do we have to worry about clearing cached checks?
7616
7617       if Is_Assignable (Ent) then
7618          Set_Last_Assignment (Ent, Empty);
7619       end if;
7620
7621       if Is_Object (Ent) then
7622          if not Last_Assignment_Only then
7623             Kill_Checks (Ent);
7624             Set_Current_Value (Ent, Empty);
7625
7626             if not Can_Never_Be_Null (Ent) then
7627                Set_Is_Known_Non_Null (Ent, False);
7628             end if;
7629
7630             Set_Is_Known_Null (Ent, False);
7631
7632             --  Reset Is_Known_Valid unless type is always valid, or if we have
7633             --  a loop parameter (loop parameters are always valid, since their
7634             --  bounds are defined by the bounds given in the loop header).
7635
7636             if not Is_Known_Valid (Etype (Ent))
7637               and then Ekind (Ent) /= E_Loop_Parameter
7638             then
7639                Set_Is_Known_Valid (Ent, False);
7640             end if;
7641          end if;
7642       end if;
7643    end Kill_Current_Values;
7644
7645    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
7646       S : Entity_Id;
7647
7648       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
7649       --  Clear current value for entity E and all entities chained to E
7650
7651       ------------------------------------------
7652       -- Kill_Current_Values_For_Entity_Chain --
7653       ------------------------------------------
7654
7655       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
7656          Ent : Entity_Id;
7657       begin
7658          Ent := E;
7659          while Present (Ent) loop
7660             Kill_Current_Values (Ent, Last_Assignment_Only);
7661             Next_Entity (Ent);
7662          end loop;
7663       end Kill_Current_Values_For_Entity_Chain;
7664
7665    --  Start of processing for Kill_Current_Values
7666
7667    begin
7668       --  Kill all saved checks, a special case of killing saved values
7669
7670       if not Last_Assignment_Only then
7671          Kill_All_Checks;
7672       end if;
7673
7674       --  Loop through relevant scopes, which includes the current scope and
7675       --  any parent scopes if the current scope is a block or a package.
7676
7677       S := Current_Scope;
7678       Scope_Loop : loop
7679
7680          --  Clear current values of all entities in current scope
7681
7682          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
7683
7684          --  If scope is a package, also clear current values of all
7685          --  private entities in the scope.
7686
7687          if Is_Package_Or_Generic_Package (S)
7688            or else Is_Concurrent_Type (S)
7689          then
7690             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
7691          end if;
7692
7693          --  If this is a not a subprogram, deal with parents
7694
7695          if not Is_Subprogram (S) then
7696             S := Scope (S);
7697             exit Scope_Loop when S = Standard_Standard;
7698          else
7699             exit Scope_Loop;
7700          end if;
7701       end loop Scope_Loop;
7702    end Kill_Current_Values;
7703
7704    --------------------------
7705    -- Kill_Size_Check_Code --
7706    --------------------------
7707
7708    procedure Kill_Size_Check_Code (E : Entity_Id) is
7709    begin
7710       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
7711         and then Present (Size_Check_Code (E))
7712       then
7713          Remove (Size_Check_Code (E));
7714          Set_Size_Check_Code (E, Empty);
7715       end if;
7716    end Kill_Size_Check_Code;
7717
7718    --------------------------
7719    -- Known_To_Be_Assigned --
7720    --------------------------
7721
7722    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
7723       P : constant Node_Id := Parent (N);
7724
7725    begin
7726       case Nkind (P) is
7727
7728          --  Test left side of assignment
7729
7730          when N_Assignment_Statement =>
7731             return N = Name (P);
7732
7733             --  Function call arguments are never lvalues
7734
7735          when N_Function_Call =>
7736             return False;
7737
7738          --  Positional parameter for procedure or accept call
7739
7740          when N_Procedure_Call_Statement |
7741               N_Accept_Statement
7742           =>
7743             declare
7744                Proc : Entity_Id;
7745                Form : Entity_Id;
7746                Act  : Node_Id;
7747
7748             begin
7749                Proc := Get_Subprogram_Entity (P);
7750
7751                if No (Proc) then
7752                   return False;
7753                end if;
7754
7755                --  If we are not a list member, something is strange, so
7756                --  be conservative and return False.
7757
7758                if not Is_List_Member (N) then
7759                   return False;
7760                end if;
7761
7762                --  We are going to find the right formal by stepping forward
7763                --  through the formals, as we step backwards in the actuals.
7764
7765                Form := First_Formal (Proc);
7766                Act  := N;
7767                loop
7768                   --  If no formal, something is weird, so be conservative
7769                   --  and return False.
7770
7771                   if No (Form) then
7772                      return False;
7773                   end if;
7774
7775                   Prev (Act);
7776                   exit when No (Act);
7777                   Next_Formal (Form);
7778                end loop;
7779
7780                return Ekind (Form) /= E_In_Parameter;
7781             end;
7782
7783          --  Named parameter for procedure or accept call
7784
7785          when N_Parameter_Association =>
7786             declare
7787                Proc : Entity_Id;
7788                Form : Entity_Id;
7789
7790             begin
7791                Proc := Get_Subprogram_Entity (Parent (P));
7792
7793                if No (Proc) then
7794                   return False;
7795                end if;
7796
7797                --  Loop through formals to find the one that matches
7798
7799                Form := First_Formal (Proc);
7800                loop
7801                   --  If no matching formal, that's peculiar, some kind of
7802                   --  previous error, so return False to be conservative.
7803
7804                   if No (Form) then
7805                      return False;
7806                   end if;
7807
7808                   --  Else test for match
7809
7810                   if Chars (Form) = Chars (Selector_Name (P)) then
7811                      return Ekind (Form) /= E_In_Parameter;
7812                   end if;
7813
7814                   Next_Formal (Form);
7815                end loop;
7816             end;
7817
7818          --  Test for appearing in a conversion that itself appears
7819          --  in an lvalue context, since this should be an lvalue.
7820
7821          when N_Type_Conversion =>
7822             return Known_To_Be_Assigned (P);
7823
7824          --  All other references are definitely not known to be modifications
7825
7826          when others =>
7827             return False;
7828
7829       end case;
7830    end Known_To_Be_Assigned;
7831
7832    -------------------
7833    -- May_Be_Lvalue --
7834    -------------------
7835
7836    function May_Be_Lvalue (N : Node_Id) return Boolean is
7837       P : constant Node_Id := Parent (N);
7838
7839    begin
7840       case Nkind (P) is
7841
7842          --  Test left side of assignment
7843
7844          when N_Assignment_Statement =>
7845             return N = Name (P);
7846
7847          --  Test prefix of component or attribute. Note that the prefix of an
7848          --  explicit or implicit dereference cannot be an l-value.
7849
7850          when N_Attribute_Reference =>
7851             return N = Prefix (P)
7852               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
7853
7854          --  For an expanded name, the name is an lvalue if the expanded name
7855          --  is an lvalue, but the prefix is never an lvalue, since it is just
7856          --  the scope where the name is found.
7857
7858          when N_Expanded_Name        =>
7859             if N = Prefix (P) then
7860                return May_Be_Lvalue (P);
7861             else
7862                return False;
7863             end if;
7864
7865          --  For a selected component A.B, A is certainly an lvalue if A.B is.
7866          --  B is a little interesting, if we have A.B := 3, there is some
7867          --  discussion as to whether B is an lvalue or not, we choose to say
7868          --  it is. Note however that A is not an lvalue if it is of an access
7869          --  type since this is an implicit dereference.
7870
7871          when N_Selected_Component   =>
7872             if N = Prefix (P)
7873               and then Present (Etype (N))
7874               and then Is_Access_Type (Etype (N))
7875             then
7876                return False;
7877             else
7878                return May_Be_Lvalue (P);
7879             end if;
7880
7881          --  For an indexed component or slice, the index or slice bounds is
7882          --  never an lvalue. The prefix is an lvalue if the indexed component
7883          --  or slice is an lvalue, except if it is an access type, where we
7884          --  have an implicit dereference.
7885
7886          when N_Indexed_Component    =>
7887             if N /= Prefix (P)
7888               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
7889             then
7890                return False;
7891             else
7892                return May_Be_Lvalue (P);
7893             end if;
7894
7895          --  Prefix of a reference is an lvalue if the reference is an lvalue
7896
7897          when N_Reference            =>
7898             return May_Be_Lvalue (P);
7899
7900          --  Prefix of explicit dereference is never an lvalue
7901
7902          when N_Explicit_Dereference =>
7903             return False;
7904
7905          --  Function call arguments are never lvalues
7906
7907          when N_Function_Call =>
7908             return False;
7909
7910          --  Positional parameter for procedure, entry,  or accept call
7911
7912          when N_Procedure_Call_Statement |
7913               N_Entry_Call_Statement     |
7914               N_Accept_Statement
7915          =>
7916             declare
7917                Proc : Entity_Id;
7918                Form : Entity_Id;
7919                Act  : Node_Id;
7920
7921             begin
7922                Proc := Get_Subprogram_Entity (P);
7923
7924                if No (Proc) then
7925                   return True;
7926                end if;
7927
7928                --  If we are not a list member, something is strange, so
7929                --  be conservative and return True.
7930
7931                if not Is_List_Member (N) then
7932                   return True;
7933                end if;
7934
7935                --  We are going to find the right formal by stepping forward
7936                --  through the formals, as we step backwards in the actuals.
7937
7938                Form := First_Formal (Proc);
7939                Act  := N;
7940                loop
7941                   --  If no formal, something is weird, so be conservative
7942                   --  and return True.
7943
7944                   if No (Form) then
7945                      return True;
7946                   end if;
7947
7948                   Prev (Act);
7949                   exit when No (Act);
7950                   Next_Formal (Form);
7951                end loop;
7952
7953                return Ekind (Form) /= E_In_Parameter;
7954             end;
7955
7956          --  Named parameter for procedure or accept call
7957
7958          when N_Parameter_Association =>
7959             declare
7960                Proc : Entity_Id;
7961                Form : Entity_Id;
7962
7963             begin
7964                Proc := Get_Subprogram_Entity (Parent (P));
7965
7966                if No (Proc) then
7967                   return True;
7968                end if;
7969
7970                --  Loop through formals to find the one that matches
7971
7972                Form := First_Formal (Proc);
7973                loop
7974                   --  If no matching formal, that's peculiar, some kind of
7975                   --  previous error, so return True to be conservative.
7976
7977                   if No (Form) then
7978                      return True;
7979                   end if;
7980
7981                   --  Else test for match
7982
7983                   if Chars (Form) = Chars (Selector_Name (P)) then
7984                      return Ekind (Form) /= E_In_Parameter;
7985                   end if;
7986
7987                   Next_Formal (Form);
7988                end loop;
7989             end;
7990
7991          --  Test for appearing in a conversion that itself appears in an
7992          --  lvalue context, since this should be an lvalue.
7993
7994          when N_Type_Conversion =>
7995             return May_Be_Lvalue (P);
7996
7997          --  Test for appearance in object renaming declaration
7998
7999          when N_Object_Renaming_Declaration =>
8000             return True;
8001
8002          --  All other references are definitely not lvalues
8003
8004          when others =>
8005             return False;
8006
8007       end case;
8008    end May_Be_Lvalue;
8009
8010    -----------------------
8011    -- Mark_Coextensions --
8012    -----------------------
8013
8014    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
8015       Is_Dynamic : Boolean;
8016       --  Indicates whether the context causes nested coextensions to be
8017       --  dynamic or static
8018
8019       function Mark_Allocator (N : Node_Id) return Traverse_Result;
8020       --  Recognize an allocator node and label it as a dynamic coextension
8021
8022       --------------------
8023       -- Mark_Allocator --
8024       --------------------
8025
8026       function Mark_Allocator (N : Node_Id) return Traverse_Result is
8027       begin
8028          if Nkind (N) = N_Allocator then
8029             if Is_Dynamic then
8030                Set_Is_Dynamic_Coextension (N);
8031
8032             --  If the allocator expression is potentially dynamic, it may
8033             --  be expanded out of order and require dynamic allocation
8034             --  anyway, so we treat the coextension itself as dynamic.
8035             --  Potential optimization ???
8036
8037             elsif Nkind (Expression (N)) = N_Qualified_Expression
8038               and then Nkind (Expression (Expression (N))) = N_Op_Concat
8039             then
8040                Set_Is_Dynamic_Coextension (N);
8041
8042             else
8043                Set_Is_Static_Coextension (N);
8044             end if;
8045          end if;
8046
8047          return OK;
8048       end Mark_Allocator;
8049
8050       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
8051
8052    --  Start of processing Mark_Coextensions
8053
8054    begin
8055       case Nkind (Context_Nod) is
8056          when N_Assignment_Statement    |
8057               N_Simple_Return_Statement =>
8058             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
8059
8060          when N_Object_Declaration =>
8061             Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
8062
8063          --  This routine should not be called for constructs which may not
8064          --  contain coextensions.
8065
8066          when others =>
8067             raise Program_Error;
8068       end case;
8069
8070       Mark_Allocators (Root_Nod);
8071    end Mark_Coextensions;
8072
8073    ----------------------
8074    -- Needs_One_Actual --
8075    ----------------------
8076
8077    function Needs_One_Actual (E : Entity_Id) return Boolean is
8078       Formal : Entity_Id;
8079
8080    begin
8081       if Ada_Version >= Ada_2005
8082         and then Present (First_Formal (E))
8083       then
8084          Formal := Next_Formal (First_Formal (E));
8085          while Present (Formal) loop
8086             if No (Default_Value (Formal)) then
8087                return False;
8088             end if;
8089
8090             Next_Formal (Formal);
8091          end loop;
8092
8093          return True;
8094
8095       else
8096          return False;
8097       end if;
8098    end Needs_One_Actual;
8099
8100    ------------------------
8101    -- New_Copy_List_Tree --
8102    ------------------------
8103
8104    function New_Copy_List_Tree (List : List_Id) return List_Id is
8105       NL : List_Id;
8106       E  : Node_Id;
8107
8108    begin
8109       if List = No_List then
8110          return No_List;
8111
8112       else
8113          NL := New_List;
8114          E := First (List);
8115
8116          while Present (E) loop
8117             Append (New_Copy_Tree (E), NL);
8118             E := Next (E);
8119          end loop;
8120
8121          return NL;
8122       end if;
8123    end New_Copy_List_Tree;
8124
8125    -------------------
8126    -- New_Copy_Tree --
8127    -------------------
8128
8129    use Atree.Unchecked_Access;
8130    use Atree_Private_Part;
8131
8132    --  Our approach here requires a two pass traversal of the tree. The
8133    --  first pass visits all nodes that eventually will be copied looking
8134    --  for defining Itypes. If any defining Itypes are found, then they are
8135    --  copied, and an entry is added to the replacement map. In the second
8136    --  phase, the tree is copied, using the replacement map to replace any
8137    --  Itype references within the copied tree.
8138
8139    --  The following hash tables are used if the Map supplied has more
8140    --  than hash threshhold entries to speed up access to the map. If
8141    --  there are fewer entries, then the map is searched sequentially
8142    --  (because setting up a hash table for only a few entries takes
8143    --  more time than it saves.
8144
8145    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
8146    --  Hash function used for hash operations
8147
8148    -------------------
8149    -- New_Copy_Hash --
8150    -------------------
8151
8152    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
8153    begin
8154       return Nat (E) mod (NCT_Header_Num'Last + 1);
8155    end New_Copy_Hash;
8156
8157    ---------------
8158    -- NCT_Assoc --
8159    ---------------
8160
8161    --  The hash table NCT_Assoc associates old entities in the table
8162    --  with their corresponding new entities (i.e. the pairs of entries
8163    --  presented in the original Map argument are Key-Element pairs).
8164
8165    package NCT_Assoc is new Simple_HTable (
8166      Header_Num => NCT_Header_Num,
8167      Element    => Entity_Id,
8168      No_Element => Empty,
8169      Key        => Entity_Id,
8170      Hash       => New_Copy_Hash,
8171      Equal      => Types."=");
8172
8173    ---------------------
8174    -- NCT_Itype_Assoc --
8175    ---------------------
8176
8177    --  The hash table NCT_Itype_Assoc contains entries only for those
8178    --  old nodes which have a non-empty Associated_Node_For_Itype set.
8179    --  The key is the associated node, and the element is the new node
8180    --  itself (NOT the associated node for the new node).
8181
8182    package NCT_Itype_Assoc is new Simple_HTable (
8183      Header_Num => NCT_Header_Num,
8184      Element    => Entity_Id,
8185      No_Element => Empty,
8186      Key        => Entity_Id,
8187      Hash       => New_Copy_Hash,
8188      Equal      => Types."=");
8189
8190    --  Start of processing for New_Copy_Tree function
8191
8192    function New_Copy_Tree
8193      (Source    : Node_Id;
8194       Map       : Elist_Id := No_Elist;
8195       New_Sloc  : Source_Ptr := No_Location;
8196       New_Scope : Entity_Id := Empty) return Node_Id
8197    is
8198       Actual_Map : Elist_Id := Map;
8199       --  This is the actual map for the copy. It is initialized with the
8200       --  given elements, and then enlarged as required for Itypes that are
8201       --  copied during the first phase of the copy operation. The visit
8202       --  procedures add elements to this map as Itypes are encountered.
8203       --  The reason we cannot use Map directly, is that it may well be
8204       --  (and normally is) initialized to No_Elist, and if we have mapped
8205       --  entities, we have to reset it to point to a real Elist.
8206
8207       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
8208       --  Called during second phase to map entities into their corresponding
8209       --  copies using Actual_Map. If the argument is not an entity, or is not
8210       --  in Actual_Map, then it is returned unchanged.
8211
8212       procedure Build_NCT_Hash_Tables;
8213       --  Builds hash tables (number of elements >= threshold value)
8214
8215       function Copy_Elist_With_Replacement
8216         (Old_Elist : Elist_Id) return Elist_Id;
8217       --  Called during second phase to copy element list doing replacements
8218
8219       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
8220       --  Called during the second phase to process a copied Itype. The actual
8221       --  copy happened during the first phase (so that we could make the entry
8222       --  in the mapping), but we still have to deal with the descendents of
8223       --  the copied Itype and copy them where necessary.
8224
8225       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
8226       --  Called during second phase to copy list doing replacements
8227
8228       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
8229       --  Called during second phase to copy node doing replacements
8230
8231       procedure Visit_Elist (E : Elist_Id);
8232       --  Called during first phase to visit all elements of an Elist
8233
8234       procedure Visit_Field (F : Union_Id; N : Node_Id);
8235       --  Visit a single field, recursing to call Visit_Node or Visit_List
8236       --  if the field is a syntactic descendent of the current node (i.e.
8237       --  its parent is Node N).
8238
8239       procedure Visit_Itype (Old_Itype : Entity_Id);
8240       --  Called during first phase to visit subsidiary fields of a defining
8241       --  Itype, and also create a copy and make an entry in the replacement
8242       --  map for the new copy.
8243
8244       procedure Visit_List (L : List_Id);
8245       --  Called during first phase to visit all elements of a List
8246
8247       procedure Visit_Node (N : Node_Or_Entity_Id);
8248       --  Called during first phase to visit a node and all its subtrees
8249
8250       -----------
8251       -- Assoc --
8252       -----------
8253
8254       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
8255          E   : Elmt_Id;
8256          Ent : Entity_Id;
8257
8258       begin
8259          if not Has_Extension (N) or else No (Actual_Map) then
8260             return N;
8261
8262          elsif NCT_Hash_Tables_Used then
8263             Ent := NCT_Assoc.Get (Entity_Id (N));
8264
8265             if Present (Ent) then
8266                return Ent;
8267             else
8268                return N;
8269             end if;
8270
8271          --  No hash table used, do serial search
8272
8273          else
8274             E := First_Elmt (Actual_Map);
8275             while Present (E) loop
8276                if Node (E) = N then
8277                   return Node (Next_Elmt (E));
8278                else
8279                   E := Next_Elmt (Next_Elmt (E));
8280                end if;
8281             end loop;
8282          end if;
8283
8284          return N;
8285       end Assoc;
8286
8287       ---------------------------
8288       -- Build_NCT_Hash_Tables --
8289       ---------------------------
8290
8291       procedure Build_NCT_Hash_Tables is
8292          Elmt : Elmt_Id;
8293          Ent  : Entity_Id;
8294       begin
8295          if NCT_Hash_Table_Setup then
8296             NCT_Assoc.Reset;
8297             NCT_Itype_Assoc.Reset;
8298          end if;
8299
8300          Elmt := First_Elmt (Actual_Map);
8301          while Present (Elmt) loop
8302             Ent := Node (Elmt);
8303
8304             --  Get new entity, and associate old and new
8305
8306             Next_Elmt (Elmt);
8307             NCT_Assoc.Set (Ent, Node (Elmt));
8308
8309             if Is_Type (Ent) then
8310                declare
8311                   Anode : constant Entity_Id :=
8312                             Associated_Node_For_Itype (Ent);
8313
8314                begin
8315                   if Present (Anode) then
8316
8317                      --  Enter a link between the associated node of the
8318                      --  old Itype and the new Itype, for updating later
8319                      --  when node is copied.
8320
8321                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
8322                   end if;
8323                end;
8324             end if;
8325
8326             Next_Elmt (Elmt);
8327          end loop;
8328
8329          NCT_Hash_Tables_Used := True;
8330          NCT_Hash_Table_Setup := True;
8331       end Build_NCT_Hash_Tables;
8332
8333       ---------------------------------
8334       -- Copy_Elist_With_Replacement --
8335       ---------------------------------
8336
8337       function Copy_Elist_With_Replacement
8338         (Old_Elist : Elist_Id) return Elist_Id
8339       is
8340          M         : Elmt_Id;
8341          New_Elist : Elist_Id;
8342
8343       begin
8344          if No (Old_Elist) then
8345             return No_Elist;
8346
8347          else
8348             New_Elist := New_Elmt_List;
8349
8350             M := First_Elmt (Old_Elist);
8351             while Present (M) loop
8352                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
8353                Next_Elmt (M);
8354             end loop;
8355          end if;
8356
8357          return New_Elist;
8358       end Copy_Elist_With_Replacement;
8359
8360       ---------------------------------
8361       -- Copy_Itype_With_Replacement --
8362       ---------------------------------
8363
8364       --  This routine exactly parallels its phase one analog Visit_Itype,
8365
8366       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
8367       begin
8368          --  Translate Next_Entity, Scope and Etype fields, in case they
8369          --  reference entities that have been mapped into copies.
8370
8371          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
8372          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
8373
8374          if Present (New_Scope) then
8375             Set_Scope    (New_Itype, New_Scope);
8376          else
8377             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
8378          end if;
8379
8380          --  Copy referenced fields
8381
8382          if Is_Discrete_Type (New_Itype) then
8383             Set_Scalar_Range (New_Itype,
8384               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
8385
8386          elsif Has_Discriminants (Base_Type (New_Itype)) then
8387             Set_Discriminant_Constraint (New_Itype,
8388               Copy_Elist_With_Replacement
8389                 (Discriminant_Constraint (New_Itype)));
8390
8391          elsif Is_Array_Type (New_Itype) then
8392             if Present (First_Index (New_Itype)) then
8393                Set_First_Index (New_Itype,
8394                  First (Copy_List_With_Replacement
8395                          (List_Containing (First_Index (New_Itype)))));
8396             end if;
8397
8398             if Is_Packed (New_Itype) then
8399                Set_Packed_Array_Type (New_Itype,
8400                  Copy_Node_With_Replacement
8401                    (Packed_Array_Type (New_Itype)));
8402             end if;
8403          end if;
8404       end Copy_Itype_With_Replacement;
8405
8406       --------------------------------
8407       -- Copy_List_With_Replacement --
8408       --------------------------------
8409
8410       function Copy_List_With_Replacement
8411         (Old_List : List_Id) return List_Id
8412       is
8413          New_List : List_Id;
8414          E        : Node_Id;
8415
8416       begin
8417          if Old_List = No_List then
8418             return No_List;
8419
8420          else
8421             New_List := Empty_List;
8422
8423             E := First (Old_List);
8424             while Present (E) loop
8425                Append (Copy_Node_With_Replacement (E), New_List);
8426                Next (E);
8427             end loop;
8428
8429             return New_List;
8430          end if;
8431       end Copy_List_With_Replacement;
8432
8433       --------------------------------
8434       -- Copy_Node_With_Replacement --
8435       --------------------------------
8436
8437       function Copy_Node_With_Replacement
8438         (Old_Node : Node_Id) return Node_Id
8439       is
8440          New_Node : Node_Id;
8441
8442          procedure Adjust_Named_Associations
8443            (Old_Node : Node_Id;
8444             New_Node : Node_Id);
8445          --  If a call node has named associations, these are chained through
8446          --  the First_Named_Actual, Next_Named_Actual links. These must be
8447          --  propagated separately to the new parameter list, because these
8448          --  are not syntactic fields.
8449
8450          function Copy_Field_With_Replacement
8451            (Field : Union_Id) return Union_Id;
8452          --  Given Field, which is a field of Old_Node, return a copy of it
8453          --  if it is a syntactic field (i.e. its parent is Node), setting
8454          --  the parent of the copy to poit to New_Node. Otherwise returns
8455          --  the field (possibly mapped if it is an entity).
8456
8457          -------------------------------
8458          -- Adjust_Named_Associations --
8459          -------------------------------
8460
8461          procedure Adjust_Named_Associations
8462            (Old_Node : Node_Id;
8463             New_Node : Node_Id)
8464          is
8465             Old_E : Node_Id;
8466             New_E : Node_Id;
8467
8468             Old_Next : Node_Id;
8469             New_Next : Node_Id;
8470
8471          begin
8472             Old_E := First (Parameter_Associations (Old_Node));
8473             New_E := First (Parameter_Associations (New_Node));
8474             while Present (Old_E) loop
8475                if Nkind (Old_E) = N_Parameter_Association
8476                  and then Present (Next_Named_Actual (Old_E))
8477                then
8478                   if First_Named_Actual (Old_Node)
8479                     =  Explicit_Actual_Parameter (Old_E)
8480                   then
8481                      Set_First_Named_Actual
8482                        (New_Node, Explicit_Actual_Parameter (New_E));
8483                   end if;
8484
8485                   --  Now scan parameter list from the beginning,to locate
8486                   --  next named actual, which can be out of order.
8487
8488                   Old_Next := First (Parameter_Associations (Old_Node));
8489                   New_Next := First (Parameter_Associations (New_Node));
8490
8491                   while Nkind (Old_Next) /= N_Parameter_Association
8492                     or else  Explicit_Actual_Parameter (Old_Next)
8493                       /= Next_Named_Actual (Old_E)
8494                   loop
8495                      Next (Old_Next);
8496                      Next (New_Next);
8497                   end loop;
8498
8499                   Set_Next_Named_Actual
8500                     (New_E, Explicit_Actual_Parameter (New_Next));
8501                end if;
8502
8503                Next (Old_E);
8504                Next (New_E);
8505             end loop;
8506          end Adjust_Named_Associations;
8507
8508          ---------------------------------
8509          -- Copy_Field_With_Replacement --
8510          ---------------------------------
8511
8512          function Copy_Field_With_Replacement
8513            (Field : Union_Id) return Union_Id
8514          is
8515          begin
8516             if Field = Union_Id (Empty) then
8517                return Field;
8518
8519             elsif Field in Node_Range then
8520                declare
8521                   Old_N : constant Node_Id := Node_Id (Field);
8522                   New_N : Node_Id;
8523
8524                begin
8525                   --  If syntactic field, as indicated by the parent pointer
8526                   --  being set, then copy the referenced node recursively.
8527
8528                   if Parent (Old_N) = Old_Node then
8529                      New_N := Copy_Node_With_Replacement (Old_N);
8530
8531                      if New_N /= Old_N then
8532                         Set_Parent (New_N, New_Node);
8533                      end if;
8534
8535                   --  For semantic fields, update possible entity reference
8536                   --  from the replacement map.
8537
8538                   else
8539                      New_N := Assoc (Old_N);
8540                   end if;
8541
8542                   return Union_Id (New_N);
8543                end;
8544
8545             elsif Field in List_Range then
8546                declare
8547                   Old_L : constant List_Id := List_Id (Field);
8548                   New_L : List_Id;
8549
8550                begin
8551                   --  If syntactic field, as indicated by the parent pointer,
8552                   --  then recursively copy the entire referenced list.
8553
8554                   if Parent (Old_L) = Old_Node then
8555                      New_L := Copy_List_With_Replacement (Old_L);
8556                      Set_Parent (New_L, New_Node);
8557
8558                   --  For semantic list, just returned unchanged
8559
8560                   else
8561                      New_L := Old_L;
8562                   end if;
8563
8564                   return Union_Id (New_L);
8565                end;
8566
8567             --  Anything other than a list or a node is returned unchanged
8568
8569             else
8570                return Field;
8571             end if;
8572          end Copy_Field_With_Replacement;
8573
8574       --  Start of processing for Copy_Node_With_Replacement
8575
8576       begin
8577          if Old_Node <= Empty_Or_Error then
8578             return Old_Node;
8579
8580          elsif Has_Extension (Old_Node) then
8581             return Assoc (Old_Node);
8582
8583          else
8584             New_Node := New_Copy (Old_Node);
8585
8586             --  If the node we are copying is the associated node of a
8587             --  previously copied Itype, then adjust the associated node
8588             --  of the copy of that Itype accordingly.
8589
8590             if Present (Actual_Map) then
8591                declare
8592                   E   : Elmt_Id;
8593                   Ent : Entity_Id;
8594
8595                begin
8596                   --  Case of hash table used
8597
8598                   if NCT_Hash_Tables_Used then
8599                      Ent := NCT_Itype_Assoc.Get (Old_Node);
8600
8601                      if Present (Ent) then
8602                         Set_Associated_Node_For_Itype (Ent, New_Node);
8603                      end if;
8604
8605                   --  Case of no hash table used
8606
8607                   else
8608                      E := First_Elmt (Actual_Map);
8609                      while Present (E) loop
8610                         if Is_Itype (Node (E))
8611                           and then
8612                             Old_Node = Associated_Node_For_Itype (Node (E))
8613                         then
8614                            Set_Associated_Node_For_Itype
8615                              (Node (Next_Elmt (E)), New_Node);
8616                         end if;
8617
8618                         E := Next_Elmt (Next_Elmt (E));
8619                      end loop;
8620                   end if;
8621                end;
8622             end if;
8623
8624             --  Recursively copy descendents
8625
8626             Set_Field1
8627               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
8628             Set_Field2
8629               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
8630             Set_Field3
8631               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
8632             Set_Field4
8633               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
8634             Set_Field5
8635               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
8636
8637             --  Adjust Sloc of new node if necessary
8638
8639             if New_Sloc /= No_Location then
8640                Set_Sloc (New_Node, New_Sloc);
8641
8642                --  If we adjust the Sloc, then we are essentially making
8643                --  a completely new node, so the Comes_From_Source flag
8644                --  should be reset to the proper default value.
8645
8646                Nodes.Table (New_Node).Comes_From_Source :=
8647                  Default_Node.Comes_From_Source;
8648             end if;
8649
8650             --  If the node is call and has named associations,
8651             --  set the corresponding links in the copy.
8652
8653             if (Nkind (Old_Node) = N_Function_Call
8654                  or else Nkind (Old_Node) = N_Entry_Call_Statement
8655                  or else
8656                    Nkind (Old_Node) = N_Procedure_Call_Statement)
8657               and then Present (First_Named_Actual (Old_Node))
8658             then
8659                Adjust_Named_Associations (Old_Node, New_Node);
8660             end if;
8661
8662             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
8663             --  The replacement mechanism applies to entities, and is not used
8664             --  here. Eventually we may need a more general graph-copying
8665             --  routine. For now, do a sequential search to find desired node.
8666
8667             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
8668               and then Present (First_Real_Statement (Old_Node))
8669             then
8670                declare
8671                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
8672                   N1, N2 : Node_Id;
8673
8674                begin
8675                   N1 := First (Statements (Old_Node));
8676                   N2 := First (Statements (New_Node));
8677
8678                   while N1 /= Old_F loop
8679                      Next (N1);
8680                      Next (N2);
8681                   end loop;
8682
8683                   Set_First_Real_Statement (New_Node, N2);
8684                end;
8685             end if;
8686          end if;
8687
8688          --  All done, return copied node
8689
8690          return New_Node;
8691       end Copy_Node_With_Replacement;
8692
8693       -----------------
8694       -- Visit_Elist --
8695       -----------------
8696
8697       procedure Visit_Elist (E : Elist_Id) is
8698          Elmt : Elmt_Id;
8699       begin
8700          if Present (E) then
8701             Elmt := First_Elmt (E);
8702
8703             while Elmt /= No_Elmt loop
8704                Visit_Node (Node (Elmt));
8705                Next_Elmt (Elmt);
8706             end loop;
8707          end if;
8708       end Visit_Elist;
8709
8710       -----------------
8711       -- Visit_Field --
8712       -----------------
8713
8714       procedure Visit_Field (F : Union_Id; N : Node_Id) is
8715       begin
8716          if F = Union_Id (Empty) then
8717             return;
8718
8719          elsif F in Node_Range then
8720
8721             --  Copy node if it is syntactic, i.e. its parent pointer is
8722             --  set to point to the field that referenced it (certain
8723             --  Itypes will also meet this criterion, which is fine, since
8724             --  these are clearly Itypes that do need to be copied, since
8725             --  we are copying their parent.)
8726
8727             if Parent (Node_Id (F)) = N then
8728                Visit_Node (Node_Id (F));
8729                return;
8730
8731             --  Another case, if we are pointing to an Itype, then we want
8732             --  to copy it if its associated node is somewhere in the tree
8733             --  being copied.
8734
8735             --  Note: the exclusion of self-referential copies is just an
8736             --  optimization, since the search of the already copied list
8737             --  would catch it, but it is a common case (Etype pointing
8738             --  to itself for an Itype that is a base type).
8739
8740             elsif Has_Extension (Node_Id (F))
8741               and then Is_Itype (Entity_Id (F))
8742               and then Node_Id (F) /= N
8743             then
8744                declare
8745                   P : Node_Id;
8746
8747                begin
8748                   P := Associated_Node_For_Itype (Node_Id (F));
8749                   while Present (P) loop
8750                      if P = Source then
8751                         Visit_Node (Node_Id (F));
8752                         return;
8753                      else
8754                         P := Parent (P);
8755                      end if;
8756                   end loop;
8757
8758                   --  An Itype whose parent is not being copied definitely
8759                   --  should NOT be copied, since it does not belong in any
8760                   --  sense to the copied subtree.
8761
8762                   return;
8763                end;
8764             end if;
8765
8766          elsif F in List_Range
8767            and then Parent (List_Id (F)) = N
8768          then
8769             Visit_List (List_Id (F));
8770             return;
8771          end if;
8772       end Visit_Field;
8773
8774       -----------------
8775       -- Visit_Itype --
8776       -----------------
8777
8778       procedure Visit_Itype (Old_Itype : Entity_Id) is
8779          New_Itype : Entity_Id;
8780          E         : Elmt_Id;
8781          Ent       : Entity_Id;
8782
8783       begin
8784          --  Itypes that describe the designated type of access to subprograms
8785          --  have the structure of subprogram declarations, with signatures,
8786          --  etc. Either we duplicate the signatures completely, or choose to
8787          --  share such itypes, which is fine because their elaboration will
8788          --  have no side effects.
8789
8790          if Ekind (Old_Itype) = E_Subprogram_Type then
8791             return;
8792          end if;
8793
8794          New_Itype := New_Copy (Old_Itype);
8795
8796          --  The new Itype has all the attributes of the old one, and
8797          --  we just copy the contents of the entity. However, the back-end
8798          --  needs different names for debugging purposes, so we create a
8799          --  new internal name for it in all cases.
8800
8801          Set_Chars (New_Itype, New_Internal_Name ('T'));
8802
8803          --  If our associated node is an entity that has already been copied,
8804          --  then set the associated node of the copy to point to the right
8805          --  copy. If we have copied an Itype that is itself the associated
8806          --  node of some previously copied Itype, then we set the right
8807          --  pointer in the other direction.
8808
8809          if Present (Actual_Map) then
8810
8811             --  Case of hash tables used
8812
8813             if NCT_Hash_Tables_Used then
8814
8815                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
8816
8817                if Present (Ent) then
8818                   Set_Associated_Node_For_Itype (New_Itype, Ent);
8819                end if;
8820
8821                Ent := NCT_Itype_Assoc.Get (Old_Itype);
8822                if Present (Ent) then
8823                   Set_Associated_Node_For_Itype (Ent, New_Itype);
8824
8825                --  If the hash table has no association for this Itype and
8826                --  its associated node, enter one now.
8827
8828                else
8829                   NCT_Itype_Assoc.Set
8830                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
8831                end if;
8832
8833             --  Case of hash tables not used
8834
8835             else
8836                E := First_Elmt (Actual_Map);
8837                while Present (E) loop
8838                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
8839                      Set_Associated_Node_For_Itype
8840                        (New_Itype, Node (Next_Elmt (E)));
8841                   end if;
8842
8843                   if Is_Type (Node (E))
8844                     and then
8845                       Old_Itype = Associated_Node_For_Itype (Node (E))
8846                   then
8847                      Set_Associated_Node_For_Itype
8848                        (Node (Next_Elmt (E)), New_Itype);
8849                   end if;
8850
8851                   E := Next_Elmt (Next_Elmt (E));
8852                end loop;
8853             end if;
8854          end if;
8855
8856          if Present (Freeze_Node (New_Itype)) then
8857             Set_Is_Frozen (New_Itype, False);
8858             Set_Freeze_Node (New_Itype, Empty);
8859          end if;
8860
8861          --  Add new association to map
8862
8863          if No (Actual_Map) then
8864             Actual_Map := New_Elmt_List;
8865          end if;
8866
8867          Append_Elmt (Old_Itype, Actual_Map);
8868          Append_Elmt (New_Itype, Actual_Map);
8869
8870          if NCT_Hash_Tables_Used then
8871             NCT_Assoc.Set (Old_Itype, New_Itype);
8872
8873          else
8874             NCT_Table_Entries := NCT_Table_Entries + 1;
8875
8876             if NCT_Table_Entries > NCT_Hash_Threshhold then
8877                Build_NCT_Hash_Tables;
8878             end if;
8879          end if;
8880
8881          --  If a record subtype is simply copied, the entity list will be
8882          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
8883
8884          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
8885             Set_Cloned_Subtype (New_Itype, Old_Itype);
8886          end if;
8887
8888          --  Visit descendents that eventually get copied
8889
8890          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
8891
8892          if Is_Discrete_Type (Old_Itype) then
8893             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
8894
8895          elsif Has_Discriminants (Base_Type (Old_Itype)) then
8896             --  ??? This should involve call to Visit_Field
8897             Visit_Elist (Discriminant_Constraint (Old_Itype));
8898
8899          elsif Is_Array_Type (Old_Itype) then
8900             if Present (First_Index (Old_Itype)) then
8901                Visit_Field (Union_Id (List_Containing
8902                                 (First_Index (Old_Itype))),
8903                             Old_Itype);
8904             end if;
8905
8906             if Is_Packed (Old_Itype) then
8907                Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
8908                             Old_Itype);
8909             end if;
8910          end if;
8911       end Visit_Itype;
8912
8913       ----------------
8914       -- Visit_List --
8915       ----------------
8916
8917       procedure Visit_List (L : List_Id) is
8918          N : Node_Id;
8919       begin
8920          if L /= No_List then
8921             N := First (L);
8922
8923             while Present (N) loop
8924                Visit_Node (N);
8925                Next (N);
8926             end loop;
8927          end if;
8928       end Visit_List;
8929
8930       ----------------
8931       -- Visit_Node --
8932       ----------------
8933
8934       procedure Visit_Node (N : Node_Or_Entity_Id) is
8935
8936       --  Start of processing for Visit_Node
8937
8938       begin
8939          --  Handle case of an Itype, which must be copied
8940
8941          if Has_Extension (N)
8942            and then Is_Itype (N)
8943          then
8944             --  Nothing to do if already in the list. This can happen with an
8945             --  Itype entity that appears more than once in the tree.
8946             --  Note that we do not want to visit descendents in this case.
8947
8948             --  Test for already in list when hash table is used
8949
8950             if NCT_Hash_Tables_Used then
8951                if Present (NCT_Assoc.Get (Entity_Id (N))) then
8952                   return;
8953                end if;
8954
8955             --  Test for already in list when hash table not used
8956
8957             else
8958                declare
8959                   E : Elmt_Id;
8960                begin
8961                   if Present (Actual_Map) then
8962                      E := First_Elmt (Actual_Map);
8963                      while Present (E) loop
8964                         if Node (E) = N then
8965                            return;
8966                         else
8967                            E := Next_Elmt (Next_Elmt (E));
8968                         end if;
8969                      end loop;
8970                   end if;
8971                end;
8972             end if;
8973
8974             Visit_Itype (N);
8975          end if;
8976
8977          --  Visit descendents
8978
8979          Visit_Field (Field1 (N), N);
8980          Visit_Field (Field2 (N), N);
8981          Visit_Field (Field3 (N), N);
8982          Visit_Field (Field4 (N), N);
8983          Visit_Field (Field5 (N), N);
8984       end Visit_Node;
8985
8986    --  Start of processing for New_Copy_Tree
8987
8988    begin
8989       Actual_Map := Map;
8990
8991       --  See if we should use hash table
8992
8993       if No (Actual_Map) then
8994          NCT_Hash_Tables_Used := False;
8995
8996       else
8997          declare
8998             Elmt : Elmt_Id;
8999
9000          begin
9001             NCT_Table_Entries := 0;
9002
9003             Elmt := First_Elmt (Actual_Map);
9004             while Present (Elmt) loop
9005                NCT_Table_Entries := NCT_Table_Entries + 1;
9006                Next_Elmt (Elmt);
9007                Next_Elmt (Elmt);
9008             end loop;
9009
9010             if NCT_Table_Entries > NCT_Hash_Threshhold then
9011                Build_NCT_Hash_Tables;
9012             else
9013                NCT_Hash_Tables_Used := False;
9014             end if;
9015          end;
9016       end if;
9017
9018       --  Hash table set up if required, now start phase one by visiting
9019       --  top node (we will recursively visit the descendents).
9020
9021       Visit_Node (Source);
9022
9023       --  Now the second phase of the copy can start. First we process
9024       --  all the mapped entities, copying their descendents.
9025
9026       if Present (Actual_Map) then
9027          declare
9028             Elmt      : Elmt_Id;
9029             New_Itype : Entity_Id;
9030          begin
9031             Elmt := First_Elmt (Actual_Map);
9032             while Present (Elmt) loop
9033                Next_Elmt (Elmt);
9034                New_Itype := Node (Elmt);
9035                Copy_Itype_With_Replacement (New_Itype);
9036                Next_Elmt (Elmt);
9037             end loop;
9038          end;
9039       end if;
9040
9041       --  Now we can copy the actual tree
9042
9043       return Copy_Node_With_Replacement (Source);
9044    end New_Copy_Tree;
9045
9046    -------------------------
9047    -- New_External_Entity --
9048    -------------------------
9049
9050    function New_External_Entity
9051      (Kind         : Entity_Kind;
9052       Scope_Id     : Entity_Id;
9053       Sloc_Value   : Source_Ptr;
9054       Related_Id   : Entity_Id;
9055       Suffix       : Character;
9056       Suffix_Index : Nat := 0;
9057       Prefix       : Character := ' ') return Entity_Id
9058    is
9059       N : constant Entity_Id :=
9060             Make_Defining_Identifier (Sloc_Value,
9061               New_External_Name
9062                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
9063
9064    begin
9065       Set_Ekind          (N, Kind);
9066       Set_Is_Internal    (N, True);
9067       Append_Entity      (N, Scope_Id);
9068       Set_Public_Status  (N);
9069
9070       if Kind in Type_Kind then
9071          Init_Size_Align (N);
9072       end if;
9073
9074       return N;
9075    end New_External_Entity;
9076
9077    -------------------------
9078    -- New_Internal_Entity --
9079    -------------------------
9080
9081    function New_Internal_Entity
9082      (Kind       : Entity_Kind;
9083       Scope_Id   : Entity_Id;
9084       Sloc_Value : Source_Ptr;
9085       Id_Char    : Character) return Entity_Id
9086    is
9087       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
9088
9089    begin
9090       Set_Ekind          (N, Kind);
9091       Set_Is_Internal    (N, True);
9092       Append_Entity      (N, Scope_Id);
9093
9094       if Kind in Type_Kind then
9095          Init_Size_Align (N);
9096       end if;
9097
9098       return N;
9099    end New_Internal_Entity;
9100
9101    -----------------
9102    -- Next_Actual --
9103    -----------------
9104
9105    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
9106       N  : Node_Id;
9107
9108    begin
9109       --  If we are pointing at a positional parameter, it is a member of a
9110       --  node list (the list of parameters), and the next parameter is the
9111       --  next node on the list, unless we hit a parameter association, then
9112       --  we shift to using the chain whose head is the First_Named_Actual in
9113       --  the parent, and then is threaded using the Next_Named_Actual of the
9114       --  Parameter_Association. All this fiddling is because the original node
9115       --  list is in the textual call order, and what we need is the
9116       --  declaration order.
9117
9118       if Is_List_Member (Actual_Id) then
9119          N := Next (Actual_Id);
9120
9121          if Nkind (N) = N_Parameter_Association then
9122             return First_Named_Actual (Parent (Actual_Id));
9123          else
9124             return N;
9125          end if;
9126
9127       else
9128          return Next_Named_Actual (Parent (Actual_Id));
9129       end if;
9130    end Next_Actual;
9131
9132    procedure Next_Actual (Actual_Id : in out Node_Id) is
9133    begin
9134       Actual_Id := Next_Actual (Actual_Id);
9135    end Next_Actual;
9136
9137    -----------------------
9138    -- Normalize_Actuals --
9139    -----------------------
9140
9141    --  Chain actuals according to formals of subprogram. If there are no named
9142    --  associations, the chain is simply the list of Parameter Associations,
9143    --  since the order is the same as the declaration order. If there are named
9144    --  associations, then the First_Named_Actual field in the N_Function_Call
9145    --  or N_Procedure_Call_Statement node points to the Parameter_Association
9146    --  node for the parameter that comes first in declaration order. The
9147    --  remaining named parameters are then chained in declaration order using
9148    --  Next_Named_Actual.
9149
9150    --  This routine also verifies that the number of actuals is compatible with
9151    --  the number and default values of formals, but performs no type checking
9152    --  (type checking is done by the caller).
9153
9154    --  If the matching succeeds, Success is set to True and the caller proceeds
9155    --  with type-checking. If the match is unsuccessful, then Success is set to
9156    --  False, and the caller attempts a different interpretation, if there is
9157    --  one.
9158
9159    --  If the flag Report is on, the call is not overloaded, and a failure to
9160    --  match can be reported here, rather than in the caller.
9161
9162    procedure Normalize_Actuals
9163      (N       : Node_Id;
9164       S       : Entity_Id;
9165       Report  : Boolean;
9166       Success : out Boolean)
9167    is
9168       Actuals     : constant List_Id := Parameter_Associations (N);
9169       Actual      : Node_Id := Empty;
9170       Formal      : Entity_Id;
9171       Last        : Node_Id := Empty;
9172       First_Named : Node_Id := Empty;
9173       Found       : Boolean;
9174
9175       Formals_To_Match : Integer := 0;
9176       Actuals_To_Match : Integer := 0;
9177
9178       procedure Chain (A : Node_Id);
9179       --  Add named actual at the proper place in the list, using the
9180       --  Next_Named_Actual link.
9181
9182       function Reporting return Boolean;
9183       --  Determines if an error is to be reported. To report an error, we
9184       --  need Report to be True, and also we do not report errors caused
9185       --  by calls to init procs that occur within other init procs. Such
9186       --  errors must always be cascaded errors, since if all the types are
9187       --  declared correctly, the compiler will certainly build decent calls!
9188
9189       -----------
9190       -- Chain --
9191       -----------
9192
9193       procedure Chain (A : Node_Id) is
9194       begin
9195          if No (Last) then
9196
9197             --  Call node points to first actual in list
9198
9199             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
9200
9201          else
9202             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
9203          end if;
9204
9205          Last := A;
9206          Set_Next_Named_Actual (Last, Empty);
9207       end Chain;
9208
9209       ---------------
9210       -- Reporting --
9211       ---------------
9212
9213       function Reporting return Boolean is
9214       begin
9215          if not Report then
9216             return False;
9217
9218          elsif not Within_Init_Proc then
9219             return True;
9220
9221          elsif Is_Init_Proc (Entity (Name (N))) then
9222             return False;
9223
9224          else
9225             return True;
9226          end if;
9227       end Reporting;
9228
9229    --  Start of processing for Normalize_Actuals
9230
9231    begin
9232       if Is_Access_Type (S) then
9233
9234          --  The name in the call is a function call that returns an access
9235          --  to subprogram. The designated type has the list of formals.
9236
9237          Formal := First_Formal (Designated_Type (S));
9238       else
9239          Formal := First_Formal (S);
9240       end if;
9241
9242       while Present (Formal) loop
9243          Formals_To_Match := Formals_To_Match + 1;
9244          Next_Formal (Formal);
9245       end loop;
9246
9247       --  Find if there is a named association, and verify that no positional
9248       --  associations appear after named ones.
9249
9250       if Present (Actuals) then
9251          Actual := First (Actuals);
9252       end if;
9253
9254       while Present (Actual)
9255         and then Nkind (Actual) /= N_Parameter_Association
9256       loop
9257          Actuals_To_Match := Actuals_To_Match + 1;
9258          Next (Actual);
9259       end loop;
9260
9261       if No (Actual) and Actuals_To_Match = Formals_To_Match then
9262
9263          --  Most common case: positional notation, no defaults
9264
9265          Success := True;
9266          return;
9267
9268       elsif Actuals_To_Match > Formals_To_Match then
9269
9270          --  Too many actuals: will not work
9271
9272          if Reporting then
9273             if Is_Entity_Name (Name (N)) then
9274                Error_Msg_N ("too many arguments in call to&", Name (N));
9275             else
9276                Error_Msg_N ("too many arguments in call", N);
9277             end if;
9278          end if;
9279
9280          Success := False;
9281          return;
9282       end if;
9283
9284       First_Named := Actual;
9285
9286       while Present (Actual) loop
9287          if Nkind (Actual) /= N_Parameter_Association then
9288             Error_Msg_N
9289               ("positional parameters not allowed after named ones", Actual);
9290             Success := False;
9291             return;
9292
9293          else
9294             Actuals_To_Match := Actuals_To_Match + 1;
9295          end if;
9296
9297          Next (Actual);
9298       end loop;
9299
9300       if Present (Actuals) then
9301          Actual := First (Actuals);
9302       end if;
9303
9304       Formal := First_Formal (S);
9305       while Present (Formal) loop
9306
9307          --  Match the formals in order. If the corresponding actual is
9308          --  positional, nothing to do. Else scan the list of named actuals
9309          --  to find the one with the right name.
9310
9311          if Present (Actual)
9312            and then Nkind (Actual) /= N_Parameter_Association
9313          then
9314             Next (Actual);
9315             Actuals_To_Match := Actuals_To_Match - 1;
9316             Formals_To_Match := Formals_To_Match - 1;
9317
9318          else
9319             --  For named parameters, search the list of actuals to find
9320             --  one that matches the next formal name.
9321
9322             Actual := First_Named;
9323             Found  := False;
9324             while Present (Actual) loop
9325                if Chars (Selector_Name (Actual)) = Chars (Formal) then
9326                   Found := True;
9327                   Chain (Actual);
9328                   Actuals_To_Match := Actuals_To_Match - 1;
9329                   Formals_To_Match := Formals_To_Match - 1;
9330                   exit;
9331                end if;
9332
9333                Next (Actual);
9334             end loop;
9335
9336             if not Found then
9337                if Ekind (Formal) /= E_In_Parameter
9338                  or else No (Default_Value (Formal))
9339                then
9340                   if Reporting then
9341                      if (Comes_From_Source (S)
9342                           or else Sloc (S) = Standard_Location)
9343                        and then Is_Overloadable (S)
9344                      then
9345                         if No (Actuals)
9346                           and then
9347                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
9348                              or else
9349                            (Nkind (Parent (N)) = N_Function_Call
9350                              or else
9351                             Nkind (Parent (N)) = N_Parameter_Association))
9352                           and then Ekind (S) /= E_Function
9353                         then
9354                            Set_Etype (N, Etype (S));
9355                         else
9356                            Error_Msg_Name_1 := Chars (S);
9357                            Error_Msg_Sloc := Sloc (S);
9358                            Error_Msg_NE
9359                              ("missing argument for parameter & " &
9360                                 "in call to % declared #", N, Formal);
9361                         end if;
9362
9363                      elsif Is_Overloadable (S) then
9364                         Error_Msg_Name_1 := Chars (S);
9365
9366                         --  Point to type derivation that generated the
9367                         --  operation.
9368
9369                         Error_Msg_Sloc := Sloc (Parent (S));
9370
9371                         Error_Msg_NE
9372                           ("missing argument for parameter & " &
9373                              "in call to % (inherited) #", N, Formal);
9374
9375                      else
9376                         Error_Msg_NE
9377                           ("missing argument for parameter &", N, Formal);
9378                      end if;
9379                   end if;
9380
9381                   Success := False;
9382                   return;
9383
9384                else
9385                   Formals_To_Match := Formals_To_Match - 1;
9386                end if;
9387             end if;
9388          end if;
9389
9390          Next_Formal (Formal);
9391       end loop;
9392
9393       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
9394          Success := True;
9395          return;
9396
9397       else
9398          if Reporting then
9399
9400             --  Find some superfluous named actual that did not get
9401             --  attached to the list of associations.
9402
9403             Actual := First (Actuals);
9404             while Present (Actual) loop
9405                if Nkind (Actual) = N_Parameter_Association
9406                  and then Actual /= Last
9407                  and then No (Next_Named_Actual (Actual))
9408                then
9409                   Error_Msg_N ("unmatched actual & in call",
9410                     Selector_Name (Actual));
9411                   exit;
9412                end if;
9413
9414                Next (Actual);
9415             end loop;
9416          end if;
9417
9418          Success := False;
9419          return;
9420       end if;
9421    end Normalize_Actuals;
9422
9423    --------------------------------
9424    -- Note_Possible_Modification --
9425    --------------------------------
9426
9427    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
9428       Modification_Comes_From_Source : constant Boolean :=
9429                                          Comes_From_Source (Parent (N));
9430
9431       Ent : Entity_Id;
9432       Exp : Node_Id;
9433
9434    begin
9435       --  Loop to find referenced entity, if there is one
9436
9437       Exp := N;
9438       loop
9439          <<Continue>>
9440          Ent := Empty;
9441
9442          if Is_Entity_Name (Exp) then
9443             Ent := Entity (Exp);
9444
9445             --  If the entity is missing, it is an undeclared identifier,
9446             --  and there is nothing to annotate.
9447
9448             if No (Ent) then
9449                return;
9450             end if;
9451
9452          elsif Nkind (Exp) = N_Explicit_Dereference then
9453             declare
9454                P : constant Node_Id := Prefix (Exp);
9455
9456             begin
9457                if Nkind (P) = N_Selected_Component
9458                  and then Present (
9459                    Entry_Formal (Entity (Selector_Name (P))))
9460                then
9461                   --  Case of a reference to an entry formal
9462
9463                   Ent := Entry_Formal (Entity (Selector_Name (P)));
9464
9465                elsif Nkind (P) = N_Identifier
9466                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
9467                  and then Present (Expression (Parent (Entity (P))))
9468                  and then Nkind (Expression (Parent (Entity (P))))
9469                    = N_Reference
9470                then
9471                   --  Case of a reference to a value on which side effects have
9472                   --  been removed.
9473
9474                   Exp := Prefix (Expression (Parent (Entity (P))));
9475                   goto Continue;
9476
9477                else
9478                   return;
9479
9480                end if;
9481             end;
9482
9483          elsif     Nkind (Exp) = N_Type_Conversion
9484            or else Nkind (Exp) = N_Unchecked_Type_Conversion
9485          then
9486             Exp := Expression (Exp);
9487             goto Continue;
9488
9489          elsif     Nkind (Exp) = N_Slice
9490            or else Nkind (Exp) = N_Indexed_Component
9491            or else Nkind (Exp) = N_Selected_Component
9492          then
9493             Exp := Prefix (Exp);
9494             goto Continue;
9495
9496          else
9497             return;
9498          end if;
9499
9500          --  Now look for entity being referenced
9501
9502          if Present (Ent) then
9503             if Is_Object (Ent) then
9504                if Comes_From_Source (Exp)
9505                  or else Modification_Comes_From_Source
9506                then
9507                   --  Give warning if pragma unmodified given and we are
9508                   --  sure this is a modification.
9509
9510                   if Has_Pragma_Unmodified (Ent) and then Sure then
9511                      Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
9512                   end if;
9513
9514                   Set_Never_Set_In_Source (Ent, False);
9515                end if;
9516
9517                Set_Is_True_Constant (Ent, False);
9518                Set_Current_Value    (Ent, Empty);
9519                Set_Is_Known_Null    (Ent, False);
9520
9521                if not Can_Never_Be_Null (Ent) then
9522                   Set_Is_Known_Non_Null (Ent, False);
9523                end if;
9524
9525                --  Follow renaming chain
9526
9527                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
9528                  and then Present (Renamed_Object (Ent))
9529                then
9530                   Exp := Renamed_Object (Ent);
9531                   goto Continue;
9532                end if;
9533
9534                --  Generate a reference only if the assignment comes from
9535                --  source. This excludes, for example, calls to a dispatching
9536                --  assignment operation when the left-hand side is tagged.
9537
9538                if Modification_Comes_From_Source then
9539                   Generate_Reference (Ent, Exp, 'm');
9540                end if;
9541
9542                Check_Nested_Access (Ent);
9543             end if;
9544
9545             Kill_Checks (Ent);
9546
9547             --  If we are sure this is a modification from source, and we know
9548             --  this modifies a constant, then give an appropriate warning.
9549
9550             if Overlays_Constant (Ent)
9551               and then Modification_Comes_From_Source
9552               and then Sure
9553             then
9554                declare
9555                   A : constant Node_Id := Address_Clause (Ent);
9556                begin
9557                   if Present (A) then
9558                      declare
9559                         Exp : constant Node_Id := Expression (A);
9560                      begin
9561                         if Nkind (Exp) = N_Attribute_Reference
9562                           and then Attribute_Name (Exp) = Name_Address
9563                           and then Is_Entity_Name (Prefix (Exp))
9564                         then
9565                            Error_Msg_Sloc := Sloc (A);
9566                            Error_Msg_NE
9567                              ("constant& may be modified via address clause#?",
9568                               N, Entity (Prefix (Exp)));
9569                         end if;
9570                      end;
9571                   end if;
9572                end;
9573             end if;
9574
9575             return;
9576          end if;
9577       end loop;
9578    end Note_Possible_Modification;
9579
9580    -------------------------
9581    -- Object_Access_Level --
9582    -------------------------
9583
9584    function Object_Access_Level (Obj : Node_Id) return Uint is
9585       E : Entity_Id;
9586
9587    --  Returns the static accessibility level of the view denoted by Obj. Note
9588    --  that the value returned is the result of a call to Scope_Depth. Only
9589    --  scope depths associated with dynamic scopes can actually be returned.
9590    --  Since only relative levels matter for accessibility checking, the fact
9591    --  that the distance between successive levels of accessibility is not
9592    --  always one is immaterial (invariant: if level(E2) is deeper than
9593    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
9594
9595       function Reference_To (Obj : Node_Id) return Node_Id;
9596       --  An explicit dereference is created when removing side-effects from
9597       --  expressions for constraint checking purposes. In this case a local
9598       --  access type is created for it. The correct access level is that of
9599       --  the original source node. We detect this case by noting that the
9600       --  prefix of the dereference is created by an object declaration whose
9601       --  initial expression is a reference.
9602
9603       ------------------
9604       -- Reference_To --
9605       ------------------
9606
9607       function Reference_To (Obj : Node_Id) return Node_Id is
9608          Pref : constant Node_Id := Prefix (Obj);
9609       begin
9610          if Is_Entity_Name (Pref)
9611            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
9612            and then Present (Expression (Parent (Entity (Pref))))
9613            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
9614          then
9615             return (Prefix (Expression (Parent (Entity (Pref)))));
9616          else
9617             return Empty;
9618          end if;
9619       end Reference_To;
9620
9621    --  Start of processing for Object_Access_Level
9622
9623    begin
9624       if Is_Entity_Name (Obj) then
9625          E := Entity (Obj);
9626
9627          if Is_Prival (E) then
9628             E := Prival_Link (E);
9629          end if;
9630
9631          --  If E is a type then it denotes a current instance. For this case
9632          --  we add one to the normal accessibility level of the type to ensure
9633          --  that current instances are treated as always being deeper than
9634          --  than the level of any visible named access type (see 3.10.2(21)).
9635
9636          if Is_Type (E) then
9637             return Type_Access_Level (E) +  1;
9638
9639          elsif Present (Renamed_Object (E)) then
9640             return Object_Access_Level (Renamed_Object (E));
9641
9642          --  Similarly, if E is a component of the current instance of a
9643          --  protected type, any instance of it is assumed to be at a deeper
9644          --  level than the type. For a protected object (whose type is an
9645          --  anonymous protected type) its components are at the same level
9646          --  as the type itself.
9647
9648          elsif not Is_Overloadable (E)
9649            and then Ekind (Scope (E)) = E_Protected_Type
9650            and then Comes_From_Source (Scope (E))
9651          then
9652             return Type_Access_Level (Scope (E)) + 1;
9653
9654          else
9655             return Scope_Depth (Enclosing_Dynamic_Scope (E));
9656          end if;
9657
9658       elsif Nkind (Obj) = N_Selected_Component then
9659          if Is_Access_Type (Etype (Prefix (Obj))) then
9660             return Type_Access_Level (Etype (Prefix (Obj)));
9661          else
9662             return Object_Access_Level (Prefix (Obj));
9663          end if;
9664
9665       elsif Nkind (Obj) = N_Indexed_Component then
9666          if Is_Access_Type (Etype (Prefix (Obj))) then
9667             return Type_Access_Level (Etype (Prefix (Obj)));
9668          else
9669             return Object_Access_Level (Prefix (Obj));
9670          end if;
9671
9672       elsif Nkind (Obj) = N_Explicit_Dereference then
9673
9674          --  If the prefix is a selected access discriminant then we make a
9675          --  recursive call on the prefix, which will in turn check the level
9676          --  of the prefix object of the selected discriminant.
9677
9678          if Nkind (Prefix (Obj)) = N_Selected_Component
9679            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
9680            and then
9681              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
9682          then
9683             return Object_Access_Level (Prefix (Obj));
9684
9685          elsif not (Comes_From_Source (Obj)) then
9686             declare
9687                Ref : constant Node_Id := Reference_To (Obj);
9688             begin
9689                if Present (Ref) then
9690                   return Object_Access_Level (Ref);
9691                else
9692                   return Type_Access_Level (Etype (Prefix (Obj)));
9693                end if;
9694             end;
9695
9696          else
9697             return Type_Access_Level (Etype (Prefix (Obj)));
9698          end if;
9699
9700       elsif Nkind (Obj) = N_Type_Conversion
9701         or else Nkind (Obj) = N_Unchecked_Type_Conversion
9702       then
9703          return Object_Access_Level (Expression (Obj));
9704
9705       elsif Nkind (Obj) = N_Function_Call then
9706
9707          --  Function results are objects, so we get either the access level of
9708          --  the function or, in the case of an indirect call, the level of the
9709          --  access-to-subprogram type. (This code is used for Ada 95, but it
9710          --  looks wrong, because it seems that we should be checking the level
9711          --  of the call itself, even for Ada 95. However, using the Ada 2005
9712          --  version of the code causes regressions in several tests that are
9713          --  compiled with -gnat95. ???)
9714
9715          if Ada_Version < Ada_2005 then
9716             if Is_Entity_Name (Name (Obj)) then
9717                return Subprogram_Access_Level (Entity (Name (Obj)));
9718             else
9719                return Type_Access_Level (Etype (Prefix (Name (Obj))));
9720             end if;
9721
9722          --  For Ada 2005, the level of the result object of a function call is
9723          --  defined to be the level of the call's innermost enclosing master.
9724          --  We determine that by querying the depth of the innermost enclosing
9725          --  dynamic scope.
9726
9727          else
9728             Return_Master_Scope_Depth_Of_Call : declare
9729
9730                function Innermost_Master_Scope_Depth
9731                  (N : Node_Id) return Uint;
9732                --  Returns the scope depth of the given node's innermost
9733                --  enclosing dynamic scope (effectively the accessibility
9734                --  level of the innermost enclosing master).
9735
9736                ----------------------------------
9737                -- Innermost_Master_Scope_Depth --
9738                ----------------------------------
9739
9740                function Innermost_Master_Scope_Depth
9741                  (N : Node_Id) return Uint
9742                is
9743                   Node_Par : Node_Id := Parent (N);
9744
9745                begin
9746                   --  Locate the nearest enclosing node (by traversing Parents)
9747                   --  that Defining_Entity can be applied to, and return the
9748                   --  depth of that entity's nearest enclosing dynamic scope.
9749
9750                   while Present (Node_Par) loop
9751                      case Nkind (Node_Par) is
9752                         when N_Component_Declaration           |
9753                              N_Entry_Declaration               |
9754                              N_Formal_Object_Declaration       |
9755                              N_Formal_Type_Declaration         |
9756                              N_Full_Type_Declaration           |
9757                              N_Incomplete_Type_Declaration     |
9758                              N_Loop_Parameter_Specification    |
9759                              N_Object_Declaration              |
9760                              N_Protected_Type_Declaration      |
9761                              N_Private_Extension_Declaration   |
9762                              N_Private_Type_Declaration        |
9763                              N_Subtype_Declaration             |
9764                              N_Function_Specification          |
9765                              N_Procedure_Specification         |
9766                              N_Task_Type_Declaration           |
9767                              N_Body_Stub                       |
9768                              N_Generic_Instantiation           |
9769                              N_Proper_Body                     |
9770                              N_Implicit_Label_Declaration      |
9771                              N_Package_Declaration             |
9772                              N_Single_Task_Declaration         |
9773                              N_Subprogram_Declaration          |
9774                              N_Generic_Declaration             |
9775                              N_Renaming_Declaration            |
9776                              N_Block_Statement                 |
9777                              N_Formal_Subprogram_Declaration   |
9778                              N_Abstract_Subprogram_Declaration |
9779                              N_Entry_Body                      |
9780                              N_Exception_Declaration           |
9781                              N_Formal_Package_Declaration      |
9782                              N_Number_Declaration              |
9783                              N_Package_Specification           |
9784                              N_Parameter_Specification         |
9785                              N_Single_Protected_Declaration    |
9786                              N_Subunit                         =>
9787
9788                            return Scope_Depth
9789                                     (Nearest_Dynamic_Scope
9790                                        (Defining_Entity (Node_Par)));
9791
9792                         when others =>
9793                            null;
9794                      end case;
9795
9796                      Node_Par := Parent (Node_Par);
9797                   end loop;
9798
9799                   pragma Assert (False);
9800
9801                   --  Should never reach the following return
9802
9803                   return Scope_Depth (Current_Scope) + 1;
9804                end Innermost_Master_Scope_Depth;
9805
9806             --  Start of processing for Return_Master_Scope_Depth_Of_Call
9807
9808             begin
9809                return Innermost_Master_Scope_Depth (Obj);
9810             end Return_Master_Scope_Depth_Of_Call;
9811          end if;
9812
9813       --  For convenience we handle qualified expressions, even though
9814       --  they aren't technically object names.
9815
9816       elsif Nkind (Obj) = N_Qualified_Expression then
9817          return Object_Access_Level (Expression (Obj));
9818
9819       --  Otherwise return the scope level of Standard.
9820       --  (If there are cases that fall through
9821       --  to this point they will be treated as
9822       --  having global accessibility for now. ???)
9823
9824       else
9825          return Scope_Depth (Standard_Standard);
9826       end if;
9827    end Object_Access_Level;
9828
9829    --------------------------------------
9830    -- Original_Corresponding_Operation --
9831    --------------------------------------
9832
9833    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
9834    is
9835       Typ : constant Entity_Id := Find_Dispatching_Type (S);
9836
9837    begin
9838       --  If S is an inherited primitive S2 the original corresponding
9839       --  operation of S is the original corresponding operation of S2
9840
9841       if Present (Alias (S))
9842         and then Find_Dispatching_Type (Alias (S)) /= Typ
9843       then
9844          return Original_Corresponding_Operation (Alias (S));
9845
9846       --  If S overrides an inherted subprogram S2 the original corresponding
9847       --  operation of S is the original corresponding operation of S2
9848
9849       elsif Is_Overriding_Operation (S)
9850         and then Present (Overridden_Operation (S))
9851       then
9852          return Original_Corresponding_Operation (Overridden_Operation (S));
9853
9854       --  otherwise it is S itself
9855
9856       else
9857          return S;
9858       end if;
9859    end Original_Corresponding_Operation;
9860
9861    -----------------------
9862    -- Private_Component --
9863    -----------------------
9864
9865    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
9866       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
9867
9868       function Trace_Components
9869         (T     : Entity_Id;
9870          Check : Boolean) return Entity_Id;
9871       --  Recursive function that does the work, and checks against circular
9872       --  definition for each subcomponent type.
9873
9874       ----------------------
9875       -- Trace_Components --
9876       ----------------------
9877
9878       function Trace_Components
9879          (T     : Entity_Id;
9880           Check : Boolean) return Entity_Id
9881        is
9882          Btype     : constant Entity_Id := Base_Type (T);
9883          Component : Entity_Id;
9884          P         : Entity_Id;
9885          Candidate : Entity_Id := Empty;
9886
9887       begin
9888          if Check and then Btype = Ancestor then
9889             Error_Msg_N ("circular type definition", Type_Id);
9890             return Any_Type;
9891          end if;
9892
9893          if Is_Private_Type (Btype)
9894            and then not Is_Generic_Type (Btype)
9895          then
9896             if Present (Full_View (Btype))
9897               and then Is_Record_Type (Full_View (Btype))
9898               and then not Is_Frozen (Btype)
9899             then
9900                --  To indicate that the ancestor depends on a private type, the
9901                --  current Btype is sufficient. However, to check for circular
9902                --  definition we must recurse on the full view.
9903
9904                Candidate := Trace_Components (Full_View (Btype), True);
9905
9906                if Candidate = Any_Type then
9907                   return Any_Type;
9908                else
9909                   return Btype;
9910                end if;
9911
9912             else
9913                return Btype;
9914             end if;
9915
9916          elsif Is_Array_Type (Btype) then
9917             return Trace_Components (Component_Type (Btype), True);
9918
9919          elsif Is_Record_Type (Btype) then
9920             Component := First_Entity (Btype);
9921             while Present (Component) loop
9922
9923                --  Skip anonymous types generated by constrained components
9924
9925                if not Is_Type (Component) then
9926                   P := Trace_Components (Etype (Component), True);
9927
9928                   if Present (P) then
9929                      if P = Any_Type then
9930                         return P;
9931                      else
9932                         Candidate := P;
9933                      end if;
9934                   end if;
9935                end if;
9936
9937                Next_Entity (Component);
9938             end loop;
9939
9940             return Candidate;
9941
9942          else
9943             return Empty;
9944          end if;
9945       end Trace_Components;
9946
9947    --  Start of processing for Private_Component
9948
9949    begin
9950       return Trace_Components (Type_Id, False);
9951    end Private_Component;
9952
9953    ---------------------------
9954    -- Primitive_Names_Match --
9955    ---------------------------
9956
9957    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
9958
9959       function Non_Internal_Name (E : Entity_Id) return Name_Id;
9960       --  Given an internal name, returns the corresponding non-internal name
9961
9962       ------------------------
9963       --  Non_Internal_Name --
9964       ------------------------
9965
9966       function Non_Internal_Name (E : Entity_Id) return Name_Id is
9967       begin
9968          Get_Name_String (Chars (E));
9969          Name_Len := Name_Len - 1;
9970          return Name_Find;
9971       end Non_Internal_Name;
9972
9973    --  Start of processing for Primitive_Names_Match
9974
9975    begin
9976       pragma Assert (Present (E1) and then Present (E2));
9977
9978       return Chars (E1) = Chars (E2)
9979         or else
9980            (not Is_Internal_Name (Chars (E1))
9981               and then Is_Internal_Name (Chars (E2))
9982               and then Non_Internal_Name (E2) = Chars (E1))
9983         or else
9984            (not Is_Internal_Name (Chars (E2))
9985               and then Is_Internal_Name (Chars (E1))
9986               and then Non_Internal_Name (E1) = Chars (E2))
9987         or else
9988            (Is_Predefined_Dispatching_Operation (E1)
9989               and then Is_Predefined_Dispatching_Operation (E2)
9990               and then Same_TSS (E1, E2))
9991         or else
9992            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
9993    end Primitive_Names_Match;
9994
9995    -----------------------
9996    -- Process_End_Label --
9997    -----------------------
9998
9999    procedure Process_End_Label
10000      (N   : Node_Id;
10001       Typ : Character;
10002       Ent  : Entity_Id)
10003    is
10004       Loc  : Source_Ptr;
10005       Nam  : Node_Id;
10006       Scop : Entity_Id;
10007
10008       Label_Ref : Boolean;
10009       --  Set True if reference to end label itself is required
10010
10011       Endl : Node_Id;
10012       --  Gets set to the operator symbol or identifier that references the
10013       --  entity Ent. For the child unit case, this is the identifier from the
10014       --  designator. For other cases, this is simply Endl.
10015
10016       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
10017       --  N is an identifier node that appears as a parent unit reference in
10018       --  the case where Ent is a child unit. This procedure generates an
10019       --  appropriate cross-reference entry. E is the corresponding entity.
10020
10021       -------------------------
10022       -- Generate_Parent_Ref --
10023       -------------------------
10024
10025       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
10026       begin
10027          --  If names do not match, something weird, skip reference
10028
10029          if Chars (E) = Chars (N) then
10030
10031             --  Generate the reference. We do NOT consider this as a reference
10032             --  for unreferenced symbol purposes.
10033
10034             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
10035
10036             if Style_Check then
10037                Style.Check_Identifier (N, E);
10038             end if;
10039          end if;
10040       end Generate_Parent_Ref;
10041
10042    --  Start of processing for Process_End_Label
10043
10044    begin
10045       --  If no node, ignore. This happens in some error situations, and
10046       --  also for some internally generated structures where no end label
10047       --  references are required in any case.
10048
10049       if No (N) then
10050          return;
10051       end if;
10052
10053       --  Nothing to do if no End_Label, happens for internally generated
10054       --  constructs where we don't want an end label reference anyway. Also
10055       --  nothing to do if Endl is a string literal, which means there was
10056       --  some prior error (bad operator symbol)
10057
10058       Endl := End_Label (N);
10059
10060       if No (Endl) or else Nkind (Endl) = N_String_Literal then
10061          return;
10062       end if;
10063
10064       --  Reference node is not in extended main source unit
10065
10066       if not In_Extended_Main_Source_Unit (N) then
10067
10068          --  Generally we do not collect references except for the extended
10069          --  main source unit. The one exception is the 'e' entry for a
10070          --  package spec, where it is useful for a client to have the
10071          --  ending information to define scopes.
10072
10073          if Typ /= 'e' then
10074             return;
10075
10076          else
10077             Label_Ref := False;
10078
10079             --  For this case, we can ignore any parent references, but we
10080             --  need the package name itself for the 'e' entry.
10081
10082             if Nkind (Endl) = N_Designator then
10083                Endl := Identifier (Endl);
10084             end if;
10085          end if;
10086
10087       --  Reference is in extended main source unit
10088
10089       else
10090          Label_Ref := True;
10091
10092          --  For designator, generate references for the parent entries
10093
10094          if Nkind (Endl) = N_Designator then
10095
10096             --  Generate references for the prefix if the END line comes from
10097             --  source (otherwise we do not need these references) We climb the
10098             --  scope stack to find the expected entities.
10099
10100             if Comes_From_Source (Endl) then
10101                Nam  := Name (Endl);
10102                Scop := Current_Scope;
10103                while Nkind (Nam) = N_Selected_Component loop
10104                   Scop := Scope (Scop);
10105                   exit when No (Scop);
10106                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
10107                   Nam := Prefix (Nam);
10108                end loop;
10109
10110                if Present (Scop) then
10111                   Generate_Parent_Ref (Nam, Scope (Scop));
10112                end if;
10113             end if;
10114
10115             Endl := Identifier (Endl);
10116          end if;
10117       end if;
10118
10119       --  If the end label is not for the given entity, then either we have
10120       --  some previous error, or this is a generic instantiation for which
10121       --  we do not need to make a cross-reference in this case anyway. In
10122       --  either case we simply ignore the call.
10123
10124       if Chars (Ent) /= Chars (Endl) then
10125          return;
10126       end if;
10127
10128       --  If label was really there, then generate a normal reference and then
10129       --  adjust the location in the end label to point past the name (which
10130       --  should almost always be the semicolon).
10131
10132       Loc := Sloc (Endl);
10133
10134       if Comes_From_Source (Endl) then
10135
10136          --  If a label reference is required, then do the style check and
10137          --  generate an l-type cross-reference entry for the label
10138
10139          if Label_Ref then
10140             if Style_Check then
10141                Style.Check_Identifier (Endl, Ent);
10142             end if;
10143
10144             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
10145          end if;
10146
10147          --  Set the location to point past the label (normally this will
10148          --  mean the semicolon immediately following the label). This is
10149          --  done for the sake of the 'e' or 't' entry generated below.
10150
10151          Get_Decoded_Name_String (Chars (Endl));
10152          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
10153       end if;
10154
10155       --  Now generate the e/t reference
10156
10157       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
10158
10159       --  Restore Sloc, in case modified above, since we have an identifier
10160       --  and the normal Sloc should be left set in the tree.
10161
10162       Set_Sloc (Endl, Loc);
10163    end Process_End_Label;
10164
10165    ------------------------------------
10166    -- References_Generic_Formal_Type --
10167    ------------------------------------
10168
10169    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
10170
10171       function Process (N : Node_Id) return Traverse_Result;
10172       --  Process one node in search for generic formal type
10173
10174       -------------
10175       -- Process --
10176       -------------
10177
10178       function Process (N : Node_Id) return Traverse_Result is
10179       begin
10180          if Nkind (N) in N_Has_Entity then
10181             declare
10182                E : constant Entity_Id := Entity (N);
10183             begin
10184                if Present (E) then
10185                   if Is_Generic_Type (E) then
10186                      return Abandon;
10187                   elsif Present (Etype (E))
10188                     and then Is_Generic_Type (Etype (E))
10189                   then
10190                      return Abandon;
10191                   end if;
10192                end if;
10193             end;
10194          end if;
10195
10196          return Atree.OK;
10197       end Process;
10198
10199       function Traverse is new Traverse_Func (Process);
10200       --  Traverse tree to look for generic type
10201
10202    begin
10203       if Inside_A_Generic then
10204          return Traverse (N) = Abandon;
10205       else
10206          return False;
10207       end if;
10208    end References_Generic_Formal_Type;
10209
10210    --------------------
10211    -- Remove_Homonym --
10212    --------------------
10213
10214    procedure Remove_Homonym (E : Entity_Id) is
10215       Prev  : Entity_Id := Empty;
10216       H     : Entity_Id;
10217
10218    begin
10219       if E = Current_Entity (E) then
10220          if Present (Homonym (E)) then
10221             Set_Current_Entity (Homonym (E));
10222          else
10223             Set_Name_Entity_Id (Chars (E), Empty);
10224          end if;
10225       else
10226          H := Current_Entity (E);
10227          while Present (H) and then H /= E loop
10228             Prev := H;
10229             H    := Homonym (H);
10230          end loop;
10231
10232          Set_Homonym (Prev, Homonym (E));
10233       end if;
10234    end Remove_Homonym;
10235
10236    ---------------------
10237    -- Rep_To_Pos_Flag --
10238    ---------------------
10239
10240    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
10241    begin
10242       return New_Occurrence_Of
10243                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
10244    end Rep_To_Pos_Flag;
10245
10246    --------------------
10247    -- Require_Entity --
10248    --------------------
10249
10250    procedure Require_Entity (N : Node_Id) is
10251    begin
10252       if Is_Entity_Name (N) and then No (Entity (N)) then
10253          if Total_Errors_Detected /= 0 then
10254             Set_Entity (N, Any_Id);
10255          else
10256             raise Program_Error;
10257          end if;
10258       end if;
10259    end Require_Entity;
10260
10261    ------------------------------
10262    -- Requires_Transient_Scope --
10263    ------------------------------
10264
10265    --  A transient scope is required when variable-sized temporaries are
10266    --  allocated in the primary or secondary stack, or when finalization
10267    --  actions must be generated before the next instruction.
10268
10269    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
10270       Typ : constant Entity_Id := Underlying_Type (Id);
10271
10272    --  Start of processing for Requires_Transient_Scope
10273
10274    begin
10275       --  This is a private type which is not completed yet. This can only
10276       --  happen in a default expression (of a formal parameter or of a
10277       --  record component). Do not expand transient scope in this case
10278
10279       if No (Typ) then
10280          return False;
10281
10282       --  Do not expand transient scope for non-existent procedure return
10283
10284       elsif Typ = Standard_Void_Type then
10285          return False;
10286
10287       --  Elementary types do not require a transient scope
10288
10289       elsif Is_Elementary_Type (Typ) then
10290          return False;
10291
10292       --  Generally, indefinite subtypes require a transient scope, since the
10293       --  back end cannot generate temporaries, since this is not a valid type
10294       --  for declaring an object. It might be possible to relax this in the
10295       --  future, e.g. by declaring the maximum possible space for the type.
10296
10297       elsif Is_Indefinite_Subtype (Typ) then
10298          return True;
10299
10300       --  Functions returning tagged types may dispatch on result so their
10301       --  returned value is allocated on the secondary stack. Controlled
10302       --  type temporaries need finalization.
10303
10304       elsif Is_Tagged_Type (Typ)
10305         or else Has_Controlled_Component (Typ)
10306       then
10307          return not Is_Value_Type (Typ);
10308
10309       --  Record type
10310
10311       elsif Is_Record_Type (Typ) then
10312          declare
10313             Comp : Entity_Id;
10314          begin
10315             Comp := First_Entity (Typ);
10316             while Present (Comp) loop
10317                if Ekind (Comp) = E_Component
10318                   and then Requires_Transient_Scope (Etype (Comp))
10319                then
10320                   return True;
10321                else
10322                   Next_Entity (Comp);
10323                end if;
10324             end loop;
10325          end;
10326
10327          return False;
10328
10329       --  String literal types never require transient scope
10330
10331       elsif Ekind (Typ) = E_String_Literal_Subtype then
10332          return False;
10333
10334       --  Array type. Note that we already know that this is a constrained
10335       --  array, since unconstrained arrays will fail the indefinite test.
10336
10337       elsif Is_Array_Type (Typ) then
10338
10339          --  If component type requires a transient scope, the array does too
10340
10341          if Requires_Transient_Scope (Component_Type (Typ)) then
10342             return True;
10343
10344          --  Otherwise, we only need a transient scope if the size is not
10345          --  known at compile time.
10346
10347          else
10348             return not Size_Known_At_Compile_Time (Typ);
10349          end if;
10350
10351       --  All other cases do not require a transient scope
10352
10353       else
10354          return False;
10355       end if;
10356    end Requires_Transient_Scope;
10357
10358    --------------------------
10359    -- Reset_Analyzed_Flags --
10360    --------------------------
10361
10362    procedure Reset_Analyzed_Flags (N : Node_Id) is
10363
10364       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
10365       --  Function used to reset Analyzed flags in tree. Note that we do
10366       --  not reset Analyzed flags in entities, since there is no need to
10367       --  reanalyze entities, and indeed, it is wrong to do so, since it
10368       --  can result in generating auxiliary stuff more than once.
10369
10370       --------------------
10371       -- Clear_Analyzed --
10372       --------------------
10373
10374       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
10375       begin
10376          if not Has_Extension (N) then
10377             Set_Analyzed (N, False);
10378          end if;
10379
10380          return OK;
10381       end Clear_Analyzed;
10382
10383       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
10384
10385    --  Start of processing for Reset_Analyzed_Flags
10386
10387    begin
10388       Reset_Analyzed (N);
10389    end Reset_Analyzed_Flags;
10390
10391    ---------------------------
10392    -- Safe_To_Capture_Value --
10393    ---------------------------
10394
10395    function Safe_To_Capture_Value
10396      (N    : Node_Id;
10397       Ent  : Entity_Id;
10398       Cond : Boolean := False) return Boolean
10399    is
10400    begin
10401       --  The only entities for which we track constant values are variables
10402       --  which are not renamings, constants, out parameters, and in out
10403       --  parameters, so check if we have this case.
10404
10405       --  Note: it may seem odd to track constant values for constants, but in
10406       --  fact this routine is used for other purposes than simply capturing
10407       --  the value. In particular, the setting of Known[_Non]_Null.
10408
10409       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
10410             or else
10411           Ekind (Ent) = E_Constant
10412             or else
10413           Ekind (Ent) = E_Out_Parameter
10414             or else
10415           Ekind (Ent) = E_In_Out_Parameter
10416       then
10417          null;
10418
10419       --  For conditionals, we also allow loop parameters and all formals,
10420       --  including in parameters.
10421
10422       elsif Cond
10423         and then
10424           (Ekind (Ent) = E_Loop_Parameter
10425              or else
10426            Ekind (Ent) = E_In_Parameter)
10427       then
10428          null;
10429
10430       --  For all other cases, not just unsafe, but impossible to capture
10431       --  Current_Value, since the above are the only entities which have
10432       --  Current_Value fields.
10433
10434       else
10435          return False;
10436       end if;
10437
10438       --  Skip if volatile or aliased, since funny things might be going on in
10439       --  these cases which we cannot necessarily track. Also skip any variable
10440       --  for which an address clause is given, or whose address is taken. Also
10441       --  never capture value of library level variables (an attempt to do so
10442       --  can occur in the case of package elaboration code).
10443
10444       if Treat_As_Volatile (Ent)
10445         or else Is_Aliased (Ent)
10446         or else Present (Address_Clause (Ent))
10447         or else Address_Taken (Ent)
10448         or else (Is_Library_Level_Entity (Ent)
10449                    and then Ekind (Ent) = E_Variable)
10450       then
10451          return False;
10452       end if;
10453
10454       --  OK, all above conditions are met. We also require that the scope of
10455       --  the reference be the same as the scope of the entity, not counting
10456       --  packages and blocks and loops.
10457
10458       declare
10459          E_Scope : constant Entity_Id := Scope (Ent);
10460          R_Scope : Entity_Id;
10461
10462       begin
10463          R_Scope := Current_Scope;
10464          while R_Scope /= Standard_Standard loop
10465             exit when R_Scope = E_Scope;
10466
10467             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
10468                return False;
10469             else
10470                R_Scope := Scope (R_Scope);
10471             end if;
10472          end loop;
10473       end;
10474
10475       --  We also require that the reference does not appear in a context
10476       --  where it is not sure to be executed (i.e. a conditional context
10477       --  or an exception handler). We skip this if Cond is True, since the
10478       --  capturing of values from conditional tests handles this ok.
10479
10480       if Cond then
10481          return True;
10482       end if;
10483
10484       declare
10485          Desc : Node_Id;
10486          P    : Node_Id;
10487
10488       begin
10489          Desc := N;
10490
10491          P := Parent (N);
10492          while Present (P) loop
10493             if         Nkind (P) = N_If_Statement
10494               or else  Nkind (P) = N_Case_Statement
10495               or else (Nkind (P) in N_Short_Circuit
10496                          and then Desc = Right_Opnd (P))
10497               or else (Nkind (P) = N_Conditional_Expression
10498                          and then Desc /= First (Expressions (P)))
10499               or else  Nkind (P) = N_Exception_Handler
10500               or else  Nkind (P) = N_Selective_Accept
10501               or else  Nkind (P) = N_Conditional_Entry_Call
10502               or else  Nkind (P) = N_Timed_Entry_Call
10503               or else  Nkind (P) = N_Asynchronous_Select
10504             then
10505                return False;
10506             else
10507                Desc := P;
10508                P    := Parent (P);
10509             end if;
10510          end loop;
10511       end;
10512
10513       --  OK, looks safe to set value
10514
10515       return True;
10516    end Safe_To_Capture_Value;
10517
10518    ---------------
10519    -- Same_Name --
10520    ---------------
10521
10522    function Same_Name (N1, N2 : Node_Id) return Boolean is
10523       K1 : constant Node_Kind := Nkind (N1);
10524       K2 : constant Node_Kind := Nkind (N2);
10525
10526    begin
10527       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
10528         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
10529       then
10530          return Chars (N1) = Chars (N2);
10531
10532       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
10533         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
10534       then
10535          return Same_Name (Selector_Name (N1), Selector_Name (N2))
10536            and then Same_Name (Prefix (N1), Prefix (N2));
10537
10538       else
10539          return False;
10540       end if;
10541    end Same_Name;
10542
10543    -----------------
10544    -- Same_Object --
10545    -----------------
10546
10547    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
10548       N1 : constant Node_Id := Original_Node (Node1);
10549       N2 : constant Node_Id := Original_Node (Node2);
10550       --  We do the tests on original nodes, since we are most interested
10551       --  in the original source, not any expansion that got in the way.
10552
10553       K1 : constant Node_Kind := Nkind (N1);
10554       K2 : constant Node_Kind := Nkind (N2);
10555
10556    begin
10557       --  First case, both are entities with same entity
10558
10559       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
10560          declare
10561             EN1 : constant Entity_Id := Entity (N1);
10562             EN2 : constant Entity_Id := Entity (N2);
10563          begin
10564             if Present (EN1) and then Present (EN2)
10565               and then (Ekind_In (EN1, E_Variable, E_Constant)
10566                          or else Is_Formal (EN1))
10567               and then EN1 = EN2
10568             then
10569                return True;
10570             end if;
10571          end;
10572       end if;
10573
10574       --  Second case, selected component with same selector, same record
10575
10576       if K1 = N_Selected_Component
10577         and then K2 = N_Selected_Component
10578         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
10579       then
10580          return Same_Object (Prefix (N1), Prefix (N2));
10581
10582       --  Third case, indexed component with same subscripts, same array
10583
10584       elsif K1 = N_Indexed_Component
10585         and then K2 = N_Indexed_Component
10586         and then Same_Object (Prefix (N1), Prefix (N2))
10587       then
10588          declare
10589             E1, E2 : Node_Id;
10590          begin
10591             E1 := First (Expressions (N1));
10592             E2 := First (Expressions (N2));
10593             while Present (E1) loop
10594                if not Same_Value (E1, E2) then
10595                   return False;
10596                else
10597                   Next (E1);
10598                   Next (E2);
10599                end if;
10600             end loop;
10601
10602             return True;
10603          end;
10604
10605       --  Fourth case, slice of same array with same bounds
10606
10607       elsif K1 = N_Slice
10608         and then K2 = N_Slice
10609         and then Nkind (Discrete_Range (N1)) = N_Range
10610         and then Nkind (Discrete_Range (N2)) = N_Range
10611         and then Same_Value (Low_Bound (Discrete_Range (N1)),
10612                              Low_Bound (Discrete_Range (N2)))
10613         and then Same_Value (High_Bound (Discrete_Range (N1)),
10614                              High_Bound (Discrete_Range (N2)))
10615       then
10616          return Same_Name (Prefix (N1), Prefix (N2));
10617
10618       --  All other cases, not clearly the same object
10619
10620       else
10621          return False;
10622       end if;
10623    end Same_Object;
10624
10625    ---------------
10626    -- Same_Type --
10627    ---------------
10628
10629    function Same_Type (T1, T2 : Entity_Id) return Boolean is
10630    begin
10631       if T1 = T2 then
10632          return True;
10633
10634       elsif not Is_Constrained (T1)
10635         and then not Is_Constrained (T2)
10636         and then Base_Type (T1) = Base_Type (T2)
10637       then
10638          return True;
10639
10640       --  For now don't bother with case of identical constraints, to be
10641       --  fiddled with later on perhaps (this is only used for optimization
10642       --  purposes, so it is not critical to do a best possible job)
10643
10644       else
10645          return False;
10646       end if;
10647    end Same_Type;
10648
10649    ----------------
10650    -- Same_Value --
10651    ----------------
10652
10653    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
10654    begin
10655       if Compile_Time_Known_Value (Node1)
10656         and then Compile_Time_Known_Value (Node2)
10657         and then Expr_Value (Node1) = Expr_Value (Node2)
10658       then
10659          return True;
10660       elsif Same_Object (Node1, Node2) then
10661          return True;
10662       else
10663          return False;
10664       end if;
10665    end Same_Value;
10666
10667    -----------------
10668    -- Save_Actual --
10669    -----------------
10670
10671    procedure Save_Actual (N : Node_Id;  Writable : Boolean := False) is
10672    begin
10673       if Is_Entity_Name (N)
10674         or else
10675           Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
10676         or else
10677           (Nkind (N) = N_Attribute_Reference
10678             and then Attribute_Name (N) = Name_Access)
10679
10680       then
10681          --  We are only interested in IN OUT parameters of inner calls
10682
10683          if not Writable
10684            or else Nkind (Parent (N)) = N_Function_Call
10685            or else Nkind (Parent (N)) in N_Op
10686          then
10687             Actuals_In_Call.Increment_Last;
10688             Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
10689          end if;
10690       end if;
10691    end Save_Actual;
10692
10693    ------------------------
10694    -- Scope_Is_Transient --
10695    ------------------------
10696
10697    function Scope_Is_Transient return Boolean is
10698    begin
10699       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
10700    end Scope_Is_Transient;
10701
10702    ------------------
10703    -- Scope_Within --
10704    ------------------
10705
10706    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
10707       Scop : Entity_Id;
10708
10709    begin
10710       Scop := Scope1;
10711       while Scop /= Standard_Standard loop
10712          Scop := Scope (Scop);
10713
10714          if Scop = Scope2 then
10715             return True;
10716          end if;
10717       end loop;
10718
10719       return False;
10720    end Scope_Within;
10721
10722    --------------------------
10723    -- Scope_Within_Or_Same --
10724    --------------------------
10725
10726    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
10727       Scop : Entity_Id;
10728
10729    begin
10730       Scop := Scope1;
10731       while Scop /= Standard_Standard loop
10732          if Scop = Scope2 then
10733             return True;
10734          else
10735             Scop := Scope (Scop);
10736          end if;
10737       end loop;
10738
10739       return False;
10740    end Scope_Within_Or_Same;
10741
10742    --------------------
10743    -- Set_Convention --
10744    --------------------
10745
10746    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
10747    begin
10748       Basic_Set_Convention (E, Val);
10749
10750       if Is_Type (E)
10751         and then Is_Access_Subprogram_Type (Base_Type (E))
10752         and then Has_Foreign_Convention (E)
10753       then
10754          Set_Can_Use_Internal_Rep (E, False);
10755       end if;
10756    end Set_Convention;
10757
10758    ------------------------
10759    -- Set_Current_Entity --
10760    ------------------------
10761
10762    --  The given entity is to be set as the currently visible definition
10763    --  of its associated name (i.e. the Node_Id associated with its name).
10764    --  All we have to do is to get the name from the identifier, and
10765    --  then set the associated Node_Id to point to the given entity.
10766
10767    procedure Set_Current_Entity (E : Entity_Id) is
10768    begin
10769       Set_Name_Entity_Id (Chars (E), E);
10770    end Set_Current_Entity;
10771
10772    ---------------------------
10773    -- Set_Debug_Info_Needed --
10774    ---------------------------
10775
10776    procedure Set_Debug_Info_Needed (T : Entity_Id) is
10777
10778       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
10779       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
10780       --  Used to set debug info in a related node if not set already
10781
10782       --------------------------------------
10783       -- Set_Debug_Info_Needed_If_Not_Set --
10784       --------------------------------------
10785
10786       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
10787       begin
10788          if Present (E)
10789            and then not Needs_Debug_Info (E)
10790          then
10791             Set_Debug_Info_Needed (E);
10792
10793             --  For a private type, indicate that the full view also needs
10794             --  debug information.
10795
10796             if Is_Type (E)
10797               and then Is_Private_Type (E)
10798               and then Present (Full_View (E))
10799             then
10800                Set_Debug_Info_Needed (Full_View (E));
10801             end if;
10802          end if;
10803       end Set_Debug_Info_Needed_If_Not_Set;
10804
10805    --  Start of processing for Set_Debug_Info_Needed
10806
10807    begin
10808       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
10809       --  indicates that Debug_Info_Needed is never required for the entity.
10810
10811       if No (T)
10812         or else Debug_Info_Off (T)
10813       then
10814          return;
10815       end if;
10816
10817       --  Set flag in entity itself. Note that we will go through the following
10818       --  circuitry even if the flag is already set on T. That's intentional,
10819       --  it makes sure that the flag will be set in subsidiary entities.
10820
10821       Set_Needs_Debug_Info (T);
10822
10823       --  Set flag on subsidiary entities if not set already
10824
10825       if Is_Object (T) then
10826          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
10827
10828       elsif Is_Type (T) then
10829          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
10830
10831          if Is_Record_Type (T) then
10832             declare
10833                Ent : Entity_Id := First_Entity (T);
10834             begin
10835                while Present (Ent) loop
10836                   Set_Debug_Info_Needed_If_Not_Set (Ent);
10837                   Next_Entity (Ent);
10838                end loop;
10839             end;
10840
10841             --  For a class wide subtype, we also need debug information
10842             --  for the equivalent type.
10843
10844             if Ekind (T) = E_Class_Wide_Subtype then
10845                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
10846             end if;
10847
10848          elsif Is_Array_Type (T) then
10849             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
10850
10851             declare
10852                Indx : Node_Id := First_Index (T);
10853             begin
10854                while Present (Indx) loop
10855                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
10856                   Indx := Next_Index (Indx);
10857                end loop;
10858             end;
10859
10860             if Is_Packed (T) then
10861                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
10862             end if;
10863
10864          elsif Is_Access_Type (T) then
10865             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
10866
10867          elsif Is_Private_Type (T) then
10868             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
10869
10870          elsif Is_Protected_Type (T) then
10871             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
10872          end if;
10873       end if;
10874    end Set_Debug_Info_Needed;
10875
10876    ---------------------------------
10877    -- Set_Entity_With_Style_Check --
10878    ---------------------------------
10879
10880    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
10881       Val_Actual : Entity_Id;
10882       Nod        : Node_Id;
10883
10884    begin
10885       Set_Entity (N, Val);
10886
10887       if Style_Check
10888         and then not Suppress_Style_Checks (Val)
10889         and then not In_Instance
10890       then
10891          if Nkind (N) = N_Identifier then
10892             Nod := N;
10893          elsif Nkind (N) = N_Expanded_Name then
10894             Nod := Selector_Name (N);
10895          else
10896             return;
10897          end if;
10898
10899          --  A special situation arises for derived operations, where we want
10900          --  to do the check against the parent (since the Sloc of the derived
10901          --  operation points to the derived type declaration itself).
10902
10903          Val_Actual := Val;
10904          while not Comes_From_Source (Val_Actual)
10905            and then Nkind (Val_Actual) in N_Entity
10906            and then (Ekind (Val_Actual) = E_Enumeration_Literal
10907                       or else Is_Subprogram (Val_Actual)
10908                       or else Is_Generic_Subprogram (Val_Actual))
10909            and then Present (Alias (Val_Actual))
10910          loop
10911             Val_Actual := Alias (Val_Actual);
10912          end loop;
10913
10914          --  Renaming declarations for generic actuals do not come from source,
10915          --  and have a different name from that of the entity they rename, so
10916          --  there is no style check to perform here.
10917
10918          if Chars (Nod) = Chars (Val_Actual) then
10919             Style.Check_Identifier (Nod, Val_Actual);
10920          end if;
10921       end if;
10922
10923       Set_Entity (N, Val);
10924    end Set_Entity_With_Style_Check;
10925
10926    ------------------------
10927    -- Set_Name_Entity_Id --
10928    ------------------------
10929
10930    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
10931    begin
10932       Set_Name_Table_Info (Id, Int (Val));
10933    end Set_Name_Entity_Id;
10934
10935    ---------------------
10936    -- Set_Next_Actual --
10937    ---------------------
10938
10939    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
10940    begin
10941       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
10942          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
10943       end if;
10944    end Set_Next_Actual;
10945
10946    ----------------------------------
10947    -- Set_Optimize_Alignment_Flags --
10948    ----------------------------------
10949
10950    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
10951    begin
10952       if Optimize_Alignment = 'S' then
10953          Set_Optimize_Alignment_Space (E);
10954       elsif Optimize_Alignment = 'T' then
10955          Set_Optimize_Alignment_Time (E);
10956       end if;
10957    end Set_Optimize_Alignment_Flags;
10958
10959    -----------------------
10960    -- Set_Public_Status --
10961    -----------------------
10962
10963    procedure Set_Public_Status (Id : Entity_Id) is
10964       S : constant Entity_Id := Current_Scope;
10965
10966       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
10967       --  Determines if E is defined within handled statement sequence or
10968       --  an if statement, returns True if so, False otherwise.
10969
10970       ----------------------
10971       -- Within_HSS_Or_If --
10972       ----------------------
10973
10974       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
10975          N : Node_Id;
10976       begin
10977          N := Declaration_Node (E);
10978          loop
10979             N := Parent (N);
10980
10981             if No (N) then
10982                return False;
10983
10984             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
10985                                N_If_Statement)
10986             then
10987                return True;
10988             end if;
10989          end loop;
10990       end Within_HSS_Or_If;
10991
10992    --  Start of processing for Set_Public_Status
10993
10994    begin
10995       --  Everything in the scope of Standard is public
10996
10997       if S = Standard_Standard then
10998          Set_Is_Public (Id);
10999
11000       --  Entity is definitely not public if enclosing scope is not public
11001
11002       elsif not Is_Public (S) then
11003          return;
11004
11005       --  An object or function declaration that occurs in a handled sequence
11006       --  of statements or within an if statement is the declaration for a
11007       --  temporary object or local subprogram generated by the expander. It
11008       --  never needs to be made public and furthermore, making it public can
11009       --  cause back end problems.
11010
11011       elsif Nkind_In (Parent (Id), N_Object_Declaration,
11012                                    N_Function_Specification)
11013         and then Within_HSS_Or_If (Id)
11014       then
11015          return;
11016
11017       --  Entities in public packages or records are public
11018
11019       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
11020          Set_Is_Public (Id);
11021
11022       --  The bounds of an entry family declaration can generate object
11023       --  declarations that are visible to the back-end, e.g. in the
11024       --  the declaration of a composite type that contains tasks.
11025
11026       elsif Is_Concurrent_Type (S)
11027         and then not Has_Completion (S)
11028         and then Nkind (Parent (Id)) = N_Object_Declaration
11029       then
11030          Set_Is_Public (Id);
11031       end if;
11032    end Set_Public_Status;
11033
11034    -----------------------------
11035    -- Set_Referenced_Modified --
11036    -----------------------------
11037
11038    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
11039       Pref : Node_Id;
11040
11041    begin
11042       --  Deal with indexed or selected component where prefix is modified
11043
11044       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
11045          Pref := Prefix (N);
11046
11047          --  If prefix is access type, then it is the designated object that is
11048          --  being modified, which means we have no entity to set the flag on.
11049
11050          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
11051             return;
11052
11053             --  Otherwise chase the prefix
11054
11055          else
11056             Set_Referenced_Modified (Pref, Out_Param);
11057          end if;
11058
11059       --  Otherwise see if we have an entity name (only other case to process)
11060
11061       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
11062          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
11063          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
11064       end if;
11065    end Set_Referenced_Modified;
11066
11067    ----------------------------
11068    -- Set_Scope_Is_Transient --
11069    ----------------------------
11070
11071    procedure Set_Scope_Is_Transient (V : Boolean := True) is
11072    begin
11073       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
11074    end Set_Scope_Is_Transient;
11075
11076    -------------------
11077    -- Set_Size_Info --
11078    -------------------
11079
11080    procedure Set_Size_Info (T1, T2 : Entity_Id) is
11081    begin
11082       --  We copy Esize, but not RM_Size, since in general RM_Size is
11083       --  subtype specific and does not get inherited by all subtypes.
11084
11085       Set_Esize                     (T1, Esize                     (T2));
11086       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
11087
11088       if Is_Discrete_Or_Fixed_Point_Type (T1)
11089            and then
11090          Is_Discrete_Or_Fixed_Point_Type (T2)
11091       then
11092          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
11093       end if;
11094
11095       Set_Alignment                 (T1, Alignment                 (T2));
11096    end Set_Size_Info;
11097
11098    --------------------
11099    -- Static_Integer --
11100    --------------------
11101
11102    function Static_Integer (N : Node_Id) return Uint is
11103    begin
11104       Analyze_And_Resolve (N, Any_Integer);
11105
11106       if N = Error
11107         or else Error_Posted (N)
11108         or else Etype (N) = Any_Type
11109       then
11110          return No_Uint;
11111       end if;
11112
11113       if Is_Static_Expression (N) then
11114          if not Raises_Constraint_Error (N) then
11115             return Expr_Value (N);
11116          else
11117             return No_Uint;
11118          end if;
11119
11120       elsif Etype (N) = Any_Type then
11121          return No_Uint;
11122
11123       else
11124          Flag_Non_Static_Expr
11125            ("static integer expression required here", N);
11126          return No_Uint;
11127       end if;
11128    end Static_Integer;
11129
11130    --------------------------
11131    -- Statically_Different --
11132    --------------------------
11133
11134    function Statically_Different (E1, E2 : Node_Id) return Boolean is
11135       R1 : constant Node_Id := Get_Referenced_Object (E1);
11136       R2 : constant Node_Id := Get_Referenced_Object (E2);
11137    begin
11138       return     Is_Entity_Name (R1)
11139         and then Is_Entity_Name (R2)
11140         and then Entity (R1) /= Entity (R2)
11141         and then not Is_Formal (Entity (R1))
11142         and then not Is_Formal (Entity (R2));
11143    end Statically_Different;
11144
11145    -----------------------------
11146    -- Subprogram_Access_Level --
11147    -----------------------------
11148
11149    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
11150    begin
11151       if Present (Alias (Subp)) then
11152          return Subprogram_Access_Level (Alias (Subp));
11153       else
11154          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
11155       end if;
11156    end Subprogram_Access_Level;
11157
11158    -----------------
11159    -- Trace_Scope --
11160    -----------------
11161
11162    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
11163    begin
11164       if Debug_Flag_W then
11165          for J in 0 .. Scope_Stack.Last loop
11166             Write_Str ("  ");
11167          end loop;
11168
11169          Write_Str (Msg);
11170          Write_Name (Chars (E));
11171          Write_Str (" from ");
11172          Write_Location (Sloc (N));
11173          Write_Eol;
11174       end if;
11175    end Trace_Scope;
11176
11177    -----------------------
11178    -- Transfer_Entities --
11179    -----------------------
11180
11181    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
11182       Ent : Entity_Id := First_Entity (From);
11183
11184    begin
11185       if No (Ent) then
11186          return;
11187       end if;
11188
11189       if (Last_Entity (To)) = Empty then
11190          Set_First_Entity (To, Ent);
11191       else
11192          Set_Next_Entity (Last_Entity (To), Ent);
11193       end if;
11194
11195       Set_Last_Entity (To, Last_Entity (From));
11196
11197       while Present (Ent) loop
11198          Set_Scope (Ent, To);
11199
11200          if not Is_Public (Ent) then
11201             Set_Public_Status (Ent);
11202
11203             if Is_Public (Ent)
11204               and then Ekind (Ent) = E_Record_Subtype
11205
11206             then
11207                --  The components of the propagated Itype must be public
11208                --  as well.
11209
11210                declare
11211                   Comp : Entity_Id;
11212                begin
11213                   Comp := First_Entity (Ent);
11214                   while Present (Comp) loop
11215                      Set_Is_Public (Comp);
11216                      Next_Entity (Comp);
11217                   end loop;
11218                end;
11219             end if;
11220          end if;
11221
11222          Next_Entity (Ent);
11223       end loop;
11224
11225       Set_First_Entity (From, Empty);
11226       Set_Last_Entity (From, Empty);
11227    end Transfer_Entities;
11228
11229    -----------------------
11230    -- Type_Access_Level --
11231    -----------------------
11232
11233    function Type_Access_Level (Typ : Entity_Id) return Uint is
11234       Btyp : Entity_Id;
11235
11236    begin
11237       Btyp := Base_Type (Typ);
11238
11239       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
11240       --  simply use the level where the type is declared. This is true for
11241       --  stand-alone object declarations, and for anonymous access types
11242       --  associated with components the level is the same as that of the
11243       --  enclosing composite type. However, special treatment is needed for
11244       --  the cases of access parameters, return objects of an anonymous access
11245       --  type, and, in Ada 95, access discriminants of limited types.
11246
11247       if Ekind (Btyp) in Access_Kind then
11248          if Ekind (Btyp) = E_Anonymous_Access_Type then
11249
11250             --  If the type is a nonlocal anonymous access type (such as for
11251             --  an access parameter) we treat it as being declared at the
11252             --  library level to ensure that names such as X.all'access don't
11253             --  fail static accessibility checks.
11254
11255             if not Is_Local_Anonymous_Access (Typ) then
11256                return Scope_Depth (Standard_Standard);
11257
11258             --  If this is a return object, the accessibility level is that of
11259             --  the result subtype of the enclosing function. The test here is
11260             --  little complicated, because we have to account for extended
11261             --  return statements that have been rewritten as blocks, in which
11262             --  case we have to find and the Is_Return_Object attribute of the
11263             --  itype's associated object. It would be nice to find a way to
11264             --  simplify this test, but it doesn't seem worthwhile to add a new
11265             --  flag just for purposes of this test. ???
11266
11267             elsif Ekind (Scope (Btyp)) = E_Return_Statement
11268               or else
11269                 (Is_Itype (Btyp)
11270                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
11271                              N_Object_Declaration
11272                   and then Is_Return_Object
11273                              (Defining_Identifier
11274                                 (Associated_Node_For_Itype (Btyp))))
11275             then
11276                declare
11277                   Scop : Entity_Id;
11278
11279                begin
11280                   Scop := Scope (Scope (Btyp));
11281                   while Present (Scop) loop
11282                      exit when Ekind (Scop) = E_Function;
11283                      Scop := Scope (Scop);
11284                   end loop;
11285
11286                   --  Treat the return object's type as having the level of the
11287                   --  function's result subtype (as per RM05-6.5(5.3/2)).
11288
11289                   return Type_Access_Level (Etype (Scop));
11290                end;
11291             end if;
11292          end if;
11293
11294          Btyp := Root_Type (Btyp);
11295
11296          --  The accessibility level of anonymous access types associated with
11297          --  discriminants is that of the current instance of the type, and
11298          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
11299
11300          --  AI-402: access discriminants have accessibility based on the
11301          --  object rather than the type in Ada 2005, so the above paragraph
11302          --  doesn't apply.
11303
11304          --  ??? Needs completion with rules from AI-416
11305
11306          if Ada_Version <= Ada_95
11307            and then Ekind (Typ) = E_Anonymous_Access_Type
11308            and then Present (Associated_Node_For_Itype (Typ))
11309            and then Nkind (Associated_Node_For_Itype (Typ)) =
11310                                                  N_Discriminant_Specification
11311          then
11312             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
11313          end if;
11314       end if;
11315
11316       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
11317    end Type_Access_Level;
11318
11319    --------------------------
11320    -- Unit_Declaration_Node --
11321    --------------------------
11322
11323    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
11324       N : Node_Id := Parent (Unit_Id);
11325
11326    begin
11327       --  Predefined operators do not have a full function declaration
11328
11329       if Ekind (Unit_Id) = E_Operator then
11330          return N;
11331       end if;
11332
11333       --  Isn't there some better way to express the following ???
11334
11335       while Nkind (N) /= N_Abstract_Subprogram_Declaration
11336         and then Nkind (N) /= N_Formal_Package_Declaration
11337         and then Nkind (N) /= N_Function_Instantiation
11338         and then Nkind (N) /= N_Generic_Package_Declaration
11339         and then Nkind (N) /= N_Generic_Subprogram_Declaration
11340         and then Nkind (N) /= N_Package_Declaration
11341         and then Nkind (N) /= N_Package_Body
11342         and then Nkind (N) /= N_Package_Instantiation
11343         and then Nkind (N) /= N_Package_Renaming_Declaration
11344         and then Nkind (N) /= N_Procedure_Instantiation
11345         and then Nkind (N) /= N_Protected_Body
11346         and then Nkind (N) /= N_Subprogram_Declaration
11347         and then Nkind (N) /= N_Subprogram_Body
11348         and then Nkind (N) /= N_Subprogram_Body_Stub
11349         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
11350         and then Nkind (N) /= N_Task_Body
11351         and then Nkind (N) /= N_Task_Type_Declaration
11352         and then Nkind (N) not in N_Formal_Subprogram_Declaration
11353         and then Nkind (N) not in N_Generic_Renaming_Declaration
11354       loop
11355          N := Parent (N);
11356          pragma Assert (Present (N));
11357       end loop;
11358
11359       return N;
11360    end Unit_Declaration_Node;
11361
11362    ------------------------------
11363    -- Universal_Interpretation --
11364    ------------------------------
11365
11366    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
11367       Index : Interp_Index;
11368       It    : Interp;
11369
11370    begin
11371       --  The argument may be a formal parameter of an operator or subprogram
11372       --  with multiple interpretations, or else an expression for an actual.
11373
11374       if Nkind (Opnd) = N_Defining_Identifier
11375         or else not Is_Overloaded (Opnd)
11376       then
11377          if Etype (Opnd) = Universal_Integer
11378            or else Etype (Opnd) = Universal_Real
11379          then
11380             return Etype (Opnd);
11381          else
11382             return Empty;
11383          end if;
11384
11385       else
11386          Get_First_Interp (Opnd, Index, It);
11387          while Present (It.Typ) loop
11388             if It.Typ = Universal_Integer
11389               or else It.Typ = Universal_Real
11390             then
11391                return It.Typ;
11392             end if;
11393
11394             Get_Next_Interp (Index, It);
11395          end loop;
11396
11397          return Empty;
11398       end if;
11399    end Universal_Interpretation;
11400
11401    ---------------
11402    -- Unqualify --
11403    ---------------
11404
11405    function Unqualify (Expr : Node_Id) return Node_Id is
11406    begin
11407       --  Recurse to handle unlikely case of multiple levels of qualification
11408
11409       if Nkind (Expr) = N_Qualified_Expression then
11410          return Unqualify (Expression (Expr));
11411
11412       --  Normal case, not a qualified expression
11413
11414       else
11415          return Expr;
11416       end if;
11417    end Unqualify;
11418
11419    -----------------------
11420    -- Visible_Ancestors --
11421    -----------------------
11422
11423    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
11424       List_1 : Elist_Id;
11425       List_2 : Elist_Id;
11426       Elmt   : Elmt_Id;
11427
11428    begin
11429       pragma Assert (Is_Record_Type (Typ)
11430         and then Is_Tagged_Type (Typ));
11431
11432       --  Collect all the parents and progenitors of Typ. If the full-view of
11433       --  private parents and progenitors is available then it is used to
11434       --  generate the list of visible ancestors; otherwise their partial
11435       --  view is added to the resulting list.
11436
11437       Collect_Parents
11438         (T               => Typ,
11439          List            => List_1,
11440          Use_Full_View   => True);
11441
11442       Collect_Interfaces
11443         (T               => Typ,
11444          Ifaces_List     => List_2,
11445          Exclude_Parents => True,
11446          Use_Full_View   => True);
11447
11448       --  Join the two lists. Avoid duplications because an interface may
11449       --  simultaneously be parent and progenitor of a type.
11450
11451       Elmt := First_Elmt (List_2);
11452       while Present (Elmt) loop
11453          Append_Unique_Elmt (Node (Elmt), List_1);
11454          Next_Elmt (Elmt);
11455       end loop;
11456
11457       return List_1;
11458    end Visible_Ancestors;
11459
11460    ----------------------
11461    -- Within_Init_Proc --
11462    ----------------------
11463
11464    function Within_Init_Proc return Boolean is
11465       S : Entity_Id;
11466
11467    begin
11468       S := Current_Scope;
11469       while not Is_Overloadable (S) loop
11470          if S = Standard_Standard then
11471             return False;
11472          else
11473             S := Scope (S);
11474          end if;
11475       end loop;
11476
11477       return Is_Init_Proc (S);
11478    end Within_Init_Proc;
11479
11480    ----------------
11481    -- Wrong_Type --
11482    ----------------
11483
11484    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
11485       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
11486       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
11487
11488       function Has_One_Matching_Field return Boolean;
11489       --  Determines if Expec_Type is a record type with a single component or
11490       --  discriminant whose type matches the found type or is one dimensional
11491       --  array whose component type matches the found type.
11492
11493       ----------------------------
11494       -- Has_One_Matching_Field --
11495       ----------------------------
11496
11497       function Has_One_Matching_Field return Boolean is
11498          E : Entity_Id;
11499
11500       begin
11501          if Is_Array_Type (Expec_Type)
11502            and then Number_Dimensions (Expec_Type) = 1
11503            and then
11504              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
11505          then
11506             return True;
11507
11508          elsif not Is_Record_Type (Expec_Type) then
11509             return False;
11510
11511          else
11512             E := First_Entity (Expec_Type);
11513             loop
11514                if No (E) then
11515                   return False;
11516
11517                elsif (Ekind (E) /= E_Discriminant
11518                        and then Ekind (E) /= E_Component)
11519                  or else (Chars (E) = Name_uTag
11520                            or else Chars (E) = Name_uParent)
11521                then
11522                   Next_Entity (E);
11523
11524                else
11525                   exit;
11526                end if;
11527             end loop;
11528
11529             if not Covers (Etype (E), Found_Type) then
11530                return False;
11531
11532             elsif Present (Next_Entity (E)) then
11533                return False;
11534
11535             else
11536                return True;
11537             end if;
11538          end if;
11539       end Has_One_Matching_Field;
11540
11541    --  Start of processing for Wrong_Type
11542
11543    begin
11544       --  Don't output message if either type is Any_Type, or if a message
11545       --  has already been posted for this node. We need to do the latter
11546       --  check explicitly (it is ordinarily done in Errout), because we
11547       --  are using ! to force the output of the error messages.
11548
11549       if Expec_Type = Any_Type
11550         or else Found_Type = Any_Type
11551         or else Error_Posted (Expr)
11552       then
11553          return;
11554
11555       --  In  an instance, there is an ongoing problem with completion of
11556       --  type derived from private types. Their structure is what Gigi
11557       --  expects, but the  Etype is the parent type rather than the
11558       --  derived private type itself. Do not flag error in this case. The
11559       --  private completion is an entity without a parent, like an Itype.
11560       --  Similarly, full and partial views may be incorrect in the instance.
11561       --  There is no simple way to insure that it is consistent ???
11562
11563       elsif In_Instance then
11564          if Etype (Etype (Expr)) = Etype (Expected_Type)
11565            and then
11566              (Has_Private_Declaration (Expected_Type)
11567                or else Has_Private_Declaration (Etype (Expr)))
11568            and then No (Parent (Expected_Type))
11569          then
11570             return;
11571          end if;
11572       end if;
11573
11574       --  An interesting special check. If the expression is parenthesized
11575       --  and its type corresponds to the type of the sole component of the
11576       --  expected record type, or to the component type of the expected one
11577       --  dimensional array type, then assume we have a bad aggregate attempt.
11578
11579       if Nkind (Expr) in N_Subexpr
11580         and then Paren_Count (Expr) /= 0
11581         and then Has_One_Matching_Field
11582       then
11583          Error_Msg_N ("positional aggregate cannot have one component", Expr);
11584
11585       --  Another special check, if we are looking for a pool-specific access
11586       --  type and we found an E_Access_Attribute_Type, then we have the case
11587       --  of an Access attribute being used in a context which needs a pool-
11588       --  specific type, which is never allowed. The one extra check we make
11589       --  is that the expected designated type covers the Found_Type.
11590
11591       elsif Is_Access_Type (Expec_Type)
11592         and then Ekind (Found_Type) = E_Access_Attribute_Type
11593         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
11594         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
11595         and then Covers
11596           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
11597       then
11598          Error_Msg_N -- CODEFIX
11599            ("result must be general access type!", Expr);
11600          Error_Msg_NE -- CODEFIX
11601            ("add ALL to }!", Expr, Expec_Type);
11602
11603       --  Another special check, if the expected type is an integer type,
11604       --  but the expression is of type System.Address, and the parent is
11605       --  an addition or subtraction operation whose left operand is the
11606       --  expression in question and whose right operand is of an integral
11607       --  type, then this is an attempt at address arithmetic, so give
11608       --  appropriate message.
11609
11610       elsif Is_Integer_Type (Expec_Type)
11611         and then Is_RTE (Found_Type, RE_Address)
11612         and then (Nkind (Parent (Expr)) = N_Op_Add
11613                     or else
11614                   Nkind (Parent (Expr)) = N_Op_Subtract)
11615         and then Expr = Left_Opnd (Parent (Expr))
11616         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
11617       then
11618          Error_Msg_N
11619            ("address arithmetic not predefined in package System",
11620             Parent (Expr));
11621          Error_Msg_N
11622            ("\possible missing with/use of System.Storage_Elements",
11623             Parent (Expr));
11624          return;
11625
11626       --  If the expected type is an anonymous access type, as for access
11627       --  parameters and discriminants, the error is on the designated types.
11628
11629       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
11630          if Comes_From_Source (Expec_Type) then
11631             Error_Msg_NE ("expected}!", Expr, Expec_Type);
11632          else
11633             Error_Msg_NE
11634               ("expected an access type with designated}",
11635                  Expr, Designated_Type (Expec_Type));
11636          end if;
11637
11638          if Is_Access_Type (Found_Type)
11639            and then not Comes_From_Source (Found_Type)
11640          then
11641             Error_Msg_NE
11642               ("\\found an access type with designated}!",
11643                 Expr, Designated_Type (Found_Type));
11644          else
11645             if From_With_Type (Found_Type) then
11646                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
11647                Error_Msg_Qual_Level := 99;
11648                Error_Msg_NE -- CODEFIX
11649                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
11650                Error_Msg_Qual_Level := 0;
11651             else
11652                Error_Msg_NE ("found}!", Expr, Found_Type);
11653             end if;
11654          end if;
11655
11656       --  Normal case of one type found, some other type expected
11657
11658       else
11659          --  If the names of the two types are the same, see if some number
11660          --  of levels of qualification will help. Don't try more than three
11661          --  levels, and if we get to standard, it's no use (and probably
11662          --  represents an error in the compiler) Also do not bother with
11663          --  internal scope names.
11664
11665          declare
11666             Expec_Scope : Entity_Id;
11667             Found_Scope : Entity_Id;
11668
11669          begin
11670             Expec_Scope := Expec_Type;
11671             Found_Scope := Found_Type;
11672
11673             for Levels in Int range 0 .. 3 loop
11674                if Chars (Expec_Scope) /= Chars (Found_Scope) then
11675                   Error_Msg_Qual_Level := Levels;
11676                   exit;
11677                end if;
11678
11679                Expec_Scope := Scope (Expec_Scope);
11680                Found_Scope := Scope (Found_Scope);
11681
11682                exit when Expec_Scope = Standard_Standard
11683                  or else Found_Scope = Standard_Standard
11684                  or else not Comes_From_Source (Expec_Scope)
11685                  or else not Comes_From_Source (Found_Scope);
11686             end loop;
11687          end;
11688
11689          if Is_Record_Type (Expec_Type)
11690            and then Present (Corresponding_Remote_Type (Expec_Type))
11691          then
11692             Error_Msg_NE ("expected}!", Expr,
11693                           Corresponding_Remote_Type (Expec_Type));
11694          else
11695             Error_Msg_NE ("expected}!", Expr, Expec_Type);
11696          end if;
11697
11698          if Is_Entity_Name (Expr)
11699            and then Is_Package_Or_Generic_Package (Entity (Expr))
11700          then
11701             Error_Msg_N ("\\found package name!", Expr);
11702
11703          elsif Is_Entity_Name (Expr)
11704            and then
11705              (Ekind (Entity (Expr)) = E_Procedure
11706                 or else
11707               Ekind (Entity (Expr)) = E_Generic_Procedure)
11708          then
11709             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
11710                Error_Msg_N
11711                  ("found procedure name, possibly missing Access attribute!",
11712                    Expr);
11713             else
11714                Error_Msg_N
11715                  ("\\found procedure name instead of function!", Expr);
11716             end if;
11717
11718          elsif Nkind (Expr) = N_Function_Call
11719            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
11720            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
11721            and then No (Parameter_Associations (Expr))
11722          then
11723             Error_Msg_N
11724               ("found function name, possibly missing Access attribute!",
11725                Expr);
11726
11727          --  Catch common error: a prefix or infix operator which is not
11728          --  directly visible because the type isn't.
11729
11730          elsif Nkind (Expr) in N_Op
11731             and then Is_Overloaded (Expr)
11732             and then not Is_Immediately_Visible (Expec_Type)
11733             and then not Is_Potentially_Use_Visible (Expec_Type)
11734             and then not In_Use (Expec_Type)
11735             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
11736          then
11737             Error_Msg_N
11738               ("operator of the type is not directly visible!", Expr);
11739
11740          elsif Ekind (Found_Type) = E_Void
11741            and then Present (Parent (Found_Type))
11742            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
11743          then
11744             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
11745
11746          else
11747             Error_Msg_NE ("\\found}!", Expr, Found_Type);
11748          end if;
11749
11750          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
11751          --  of the same modular type, and (M1 and M2) = 0 was intended.
11752
11753          if Expec_Type = Standard_Boolean
11754            and then Is_Modular_Integer_Type (Found_Type)
11755            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
11756            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
11757          then
11758             declare
11759                Op : constant Node_Id := Right_Opnd (Parent (Expr));
11760                L  : constant Node_Id := Left_Opnd (Op);
11761                R  : constant Node_Id := Right_Opnd (Op);
11762             begin
11763                --  The case for the message is when the left operand of the
11764                --  comparison is the same modular type, or when it is an
11765                --  integer literal (or other universal integer expression),
11766                --  which would have been typed as the modular type if the
11767                --  parens had been there.
11768
11769                if (Etype (L) = Found_Type
11770                      or else
11771                    Etype (L) = Universal_Integer)
11772                  and then Is_Integer_Type (Etype (R))
11773                then
11774                   Error_Msg_N
11775                     ("\\possible missing parens for modular operation", Expr);
11776                end if;
11777             end;
11778          end if;
11779
11780          --  Reset error message qualification indication
11781
11782          Error_Msg_Qual_Level := 0;
11783       end if;
11784    end Wrong_Type;
11785
11786 end Sem_Util;