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