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