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