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