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