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