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-2013, 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 Namet.Sp; use Namet.Sp;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Output;   use Output;
  43 with Opt;      use Opt;
  44 with Restrict; use Restrict;
  45 with Rident;   use Rident;
  46 with Rtsfind;  use Rtsfind;
  47 with Sem;      use Sem;
  48 with Sem_Aux;  use Sem_Aux;
  49 with Sem_Attr; use Sem_Attr;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Disp; use Sem_Disp;
  52 with Sem_Eval; use Sem_Eval;
  53 with Sem_Res;  use Sem_Res;
  54 with Sem_Type; use Sem_Type;
  55 with Sinfo;    use Sinfo;
  56 with Sinput;   use Sinput;
  57 with Stand;    use Stand;
  58 with Style;
  59 with Stringt;  use Stringt;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Ttypes;   use Ttypes;
  63 with Uname;    use Uname;
  64
  65 with GNAT.HTable; use GNAT.HTable;
  66
  67 package body Sem_Util is
  68
  69    ----------------------------------------
  70    -- Global_Variables for New_Copy_Tree --
  71    ----------------------------------------
  72
  73    --  These global variables are used by New_Copy_Tree. See description
  74    --  of the body of this subprogram for details. Global variables can be
  75    --  safely used by New_Copy_Tree, since there is no case of a recursive
  76    --  call from the processing inside New_Copy_Tree.
  77
  78    NCT_Hash_Threshold : constant := 20;
  79    --  If there are more than this number of pairs of entries in the
  80    --  map, then Hash_Tables_Used will be set, and the hash tables will
  81    --  be initialized and used for the searches.
  82
  83    NCT_Hash_Tables_Used : Boolean := False;
  84    --  Set to True if hash tables are in use
  85
  86    NCT_Table_Entries : Nat;
  87    --  Count entries in table to see if threshold is reached
  88
  89    NCT_Hash_Table_Setup : Boolean := False;
  90    --  Set to True if hash table contains data. We set this True if we
  91    --  setup the hash table with data, and leave it set permanently
  92    --  from then on, this is a signal that second and subsequent users
  93    --  of the hash table must clear the old entries before reuse.
  94
  95    subtype NCT_Header_Num is Int range 0 .. 511;
  96    --  Defines range of headers in hash tables (512 headers)
  97
  98    -----------------------
  99    -- Local Subprograms --
 100    -----------------------
 101
 102    function Build_Component_Subtype
 103      (C   : List_Id;
 104       Loc : Source_Ptr;
 105       T   : Entity_Id) return Node_Id;
 106    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
 107    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
 108    --  Loc is the source location, T is the original subtype.
 109
 110    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
 111    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
 112    --  with discriminants whose default values are static, examine only the
 113    --  components in the selected variant to determine whether all of them
 114    --  have a default.
 115
 116    function Has_Null_Extension (T : Entity_Id) return Boolean;
 117    --  T is a derived tagged type. Check whether the type extension is null.
 118    --  If the parent type is fully initialized, T can be treated as such.
 119
 120    ------------------------------
 121    --  Abstract_Interface_List --
 122    ------------------------------
 123
 124    function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
 125       Nod : Node_Id;
 126
 127    begin
 128       if Is_Concurrent_Type (Typ) then
 129
 130          --  If we are dealing with a synchronized subtype, go to the base
 131          --  type, whose declaration has the interface list.
 132
 133          --  Shouldn't this be Declaration_Node???
 134
 135          Nod := Parent (Base_Type (Typ));
 136
 137          if Nkind (Nod) = N_Full_Type_Declaration then
 138             return Empty_List;
 139          end if;
 140
 141       elsif Ekind (Typ) = E_Record_Type_With_Private then
 142          if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
 143             Nod := Type_Definition (Parent (Typ));
 144
 145          elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
 146             if Present (Full_View (Typ))
 147               and then Nkind (Parent (Full_View (Typ)))
 148                          = N_Full_Type_Declaration
 149             then
 150                Nod := Type_Definition (Parent (Full_View (Typ)));
 151
 152             --  If the full-view is not available we cannot do anything else
 153             --  here (the source has errors).
 154
 155             else
 156                return Empty_List;
 157             end if;
 158
 159          --  Support for generic formals with interfaces is still missing ???
 160
 161          elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 162             return Empty_List;
 163
 164          else
 165             pragma Assert
 166               (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
 167             Nod := Parent (Typ);
 168          end if;
 169
 170       elsif Ekind (Typ) = E_Record_Subtype then
 171          Nod := Type_Definition (Parent (Etype (Typ)));
 172
 173       elsif Ekind (Typ) = E_Record_Subtype_With_Private then
 174
 175          --  Recurse, because parent may still be a private extension. Also
 176          --  note that the full view of the subtype or the full view of its
 177          --  base type may (both) be unavailable.
 178
 179          return Abstract_Interface_List (Etype (Typ));
 180
 181       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
 182          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 183             Nod := Formal_Type_Definition (Parent (Typ));
 184          else
 185             Nod := Type_Definition (Parent (Typ));
 186          end if;
 187       end if;
 188
 189       return Interface_List (Nod);
 190    end Abstract_Interface_List;
 191
 192    --------------------------------
 193    -- Add_Access_Type_To_Process --
 194    --------------------------------
 195
 196    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
 197       L : Elist_Id;
 198
 199    begin
 200       Ensure_Freeze_Node (E);
 201       L := Access_Types_To_Process (Freeze_Node (E));
 202
 203       if No (L) then
 204          L := New_Elmt_List;
 205          Set_Access_Types_To_Process (Freeze_Node (E), L);
 206       end if;
 207
 208       Append_Elmt (A, L);
 209    end Add_Access_Type_To_Process;
 210
 211    ----------------------------
 212    -- Add_Global_Declaration --
 213    ----------------------------
 214
 215    procedure Add_Global_Declaration (N : Node_Id) is
 216       Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
 217
 218    begin
 219       if No (Declarations (Aux_Node)) then
 220          Set_Declarations (Aux_Node, New_List);
 221       end if;
 222
 223       Append_To (Declarations (Aux_Node), N);
 224       Analyze (N);
 225    end Add_Global_Declaration;
 226
 227    -----------------
 228    -- Addressable --
 229    -----------------
 230
 231    --  For now, just 8/16/32/64. but analyze later if AAMP is special???
 232
 233    function Addressable (V : Uint) return Boolean is
 234    begin
 235       return V = Uint_8  or else
 236              V = Uint_16 or else
 237              V = Uint_32 or else
 238              V = Uint_64;
 239    end Addressable;
 240
 241    function Addressable (V : Int) return Boolean is
 242    begin
 243       return V = 8  or else
 244              V = 16 or else
 245              V = 32 or else
 246              V = 64;
 247    end Addressable;
 248
 249    -----------------------
 250    -- Alignment_In_Bits --
 251    -----------------------
 252
 253    function Alignment_In_Bits (E : Entity_Id) return Uint is
 254    begin
 255       return Alignment (E) * System_Storage_Unit;
 256    end Alignment_In_Bits;
 257
 258    ---------------------------------
 259    -- Append_Inherited_Subprogram --
 260    ---------------------------------
 261
 262    procedure Append_Inherited_Subprogram (S : Entity_Id) is
 263       Par : constant Entity_Id := Alias (S);
 264       --  The parent subprogram
 265
 266       Scop : constant Entity_Id := Scope (Par);
 267       --  The scope of definition of the parent subprogram
 268
 269       Typ : constant Entity_Id := Defining_Entity (Parent (S));
 270       --  The derived type of which S is a primitive operation
 271
 272       Decl   : Node_Id;
 273       Next_E : Entity_Id;
 274
 275    begin
 276       if Ekind (Current_Scope) = E_Package
 277         and then In_Private_Part (Current_Scope)
 278         and then Has_Private_Declaration (Typ)
 279         and then Is_Tagged_Type (Typ)
 280         and then Scop = Current_Scope
 281       then
 282          --  The inherited operation is available at the earliest place after
 283          --  the derived type declaration ( RM 7.3.1 (6/1)). This is only
 284          --  relevant for type extensions. If the parent operation appears
 285          --  after the type extension, the operation is not visible.
 286
 287          Decl := First
 288                    (Visible_Declarations
 289                      (Specification (Unit_Declaration_Node (Current_Scope))));
 290          while Present (Decl) loop
 291             if Nkind (Decl) = N_Private_Extension_Declaration
 292               and then Defining_Entity (Decl) = Typ
 293             then
 294                if Sloc (Decl) > Sloc (Par) then
 295                   Next_E := Next_Entity (Par);
 296                   Set_Next_Entity (Par, S);
 297                   Set_Next_Entity (S, Next_E);
 298                   return;
 299
 300                else
 301                   exit;
 302                end if;
 303             end if;
 304
 305             Next (Decl);
 306          end loop;
 307       end if;
 308
 309       --  If partial view is not a type extension, or it appears before the
 310       --  subprogram declaration, insert normally at end of entity list.
 311
 312       Append_Entity (S, Current_Scope);
 313    end Append_Inherited_Subprogram;
 314
 315    -----------------------------------------
 316    -- Apply_Compile_Time_Constraint_Error --
 317    -----------------------------------------
 318
 319    procedure Apply_Compile_Time_Constraint_Error
 320      (N      : Node_Id;
 321       Msg    : String;
 322       Reason : RT_Exception_Code;
 323       Ent    : Entity_Id  := Empty;
 324       Typ    : Entity_Id  := Empty;
 325       Loc    : Source_Ptr := No_Location;
 326       Rep    : Boolean    := True;
 327       Warn   : Boolean    := False)
 328    is
 329       Stat   : constant Boolean := Is_Static_Expression (N);
 330       R_Stat : constant Node_Id :=
 331                  Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
 332       Rtyp   : Entity_Id;
 333
 334    begin
 335       if No (Typ) then
 336          Rtyp := Etype (N);
 337       else
 338          Rtyp := Typ;
 339       end if;
 340
 341       Discard_Node
 342         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 343
 344       if not Rep then
 345          return;
 346       end if;
 347
 348       --  Now we replace the node by an N_Raise_Constraint_Error node
 349       --  This does not need reanalyzing, so set it as analyzed now.
 350
 351       Rewrite (N, R_Stat);
 352       Set_Analyzed (N, True);
 353
 354       Set_Etype (N, Rtyp);
 355       Set_Raises_Constraint_Error (N);
 356
 357       --  Now deal with possible local raise handling
 358
 359       Possible_Local_Raise (N, Standard_Constraint_Error);
 360
 361       --  If the original expression was marked as static, the result is
 362       --  still marked as static, but the Raises_Constraint_Error flag is
 363       --  always set so that further static evaluation is not attempted.
 364
 365       if Stat then
 366          Set_Is_Static_Expression (N);
 367       end if;
 368    end Apply_Compile_Time_Constraint_Error;
 369
 370    --------------------------------------
 371    -- Available_Full_View_Of_Component --
 372    --------------------------------------
 373
 374    function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
 375       ST  : constant Entity_Id := Scope (T);
 376       SCT : constant Entity_Id := Scope (Component_Type (T));
 377    begin
 378       return In_Open_Scopes (ST)
 379         and then In_Open_Scopes (SCT)
 380         and then Scope_Depth (ST) >= Scope_Depth (SCT);
 381    end Available_Full_View_Of_Component;
 382
 383    -------------------
 384    -- Bad_Attribute --
 385    -------------------
 386
 387    procedure Bad_Attribute
 388      (N    : Node_Id;
 389       Nam  : Name_Id;
 390       Warn : Boolean := False)
 391    is
 392    begin
 393       Error_Msg_Warn := Warn;
 394       Error_Msg_N ("unrecognized attribute&<", N);
 395
 396       --  Check for possible misspelling
 397
 398       Error_Msg_Name_1 := First_Attribute_Name;
 399       while Error_Msg_Name_1 <= Last_Attribute_Name loop
 400          if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
 401             Error_Msg_N -- CODEFIX
 402               ("\possible misspelling of %<", N);
 403             exit;
 404          end if;
 405
 406          Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
 407       end loop;
 408    end Bad_Attribute;
 409
 410    --------------------------------
 411    -- Bad_Predicated_Subtype_Use --
 412    --------------------------------
 413
 414    procedure Bad_Predicated_Subtype_Use
 415      (Msg : String;
 416       N   : Node_Id;
 417       Typ : Entity_Id)
 418    is
 419    begin
 420       if Has_Predicates (Typ) then
 421          if Is_Generic_Actual_Type (Typ) then
 422             Error_Msg_FE (Msg & "??", N, Typ);
 423             Error_Msg_F ("\Program_Error will be raised at run time??", N);
 424             Insert_Action (N,
 425               Make_Raise_Program_Error (Sloc (N),
 426                 Reason => PE_Bad_Predicated_Generic_Type));
 427
 428          else
 429             Error_Msg_FE (Msg, N, Typ);
 430          end if;
 431       end if;
 432    end Bad_Predicated_Subtype_Use;
 433
 434    --------------------------
 435    -- Build_Actual_Subtype --
 436    --------------------------
 437
 438    function Build_Actual_Subtype
 439      (T : Entity_Id;
 440       N : Node_Or_Entity_Id) return Node_Id
 441    is
 442       Loc : Source_Ptr;
 443       --  Normally Sloc (N), but may point to corresponding body in some cases
 444
 445       Constraints : List_Id;
 446       Decl        : Node_Id;
 447       Discr       : Entity_Id;
 448       Hi          : Node_Id;
 449       Lo          : Node_Id;
 450       Subt        : Entity_Id;
 451       Disc_Type   : Entity_Id;
 452       Obj         : Node_Id;
 453
 454    begin
 455       Loc := Sloc (N);
 456
 457       if Nkind (N) = N_Defining_Identifier then
 458          Obj := New_Reference_To (N, Loc);
 459
 460          --  If this is a formal parameter of a subprogram declaration, and
 461          --  we are compiling the body, we want the declaration for the
 462          --  actual subtype to carry the source position of the body, to
 463          --  prevent anomalies in gdb when stepping through the code.
 464
 465          if Is_Formal (N) then
 466             declare
 467                Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
 468             begin
 469                if Nkind (Decl) = N_Subprogram_Declaration
 470                  and then Present (Corresponding_Body (Decl))
 471                then
 472                   Loc := Sloc (Corresponding_Body (Decl));
 473                end if;
 474             end;
 475          end if;
 476
 477       else
 478          Obj := N;
 479       end if;
 480
 481       if Is_Array_Type (T) then
 482          Constraints := New_List;
 483          for J in 1 .. Number_Dimensions (T) loop
 484
 485             --  Build an array subtype declaration with the nominal subtype and
 486             --  the bounds of the actual. Add the declaration in front of the
 487             --  local declarations for the subprogram, for analysis before any
 488             --  reference to the formal in the body.
 489
 490             Lo :=
 491               Make_Attribute_Reference (Loc,
 492                 Prefix         =>
 493                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 494                 Attribute_Name => Name_First,
 495                 Expressions    => New_List (
 496                   Make_Integer_Literal (Loc, J)));
 497
 498             Hi :=
 499               Make_Attribute_Reference (Loc,
 500                 Prefix         =>
 501                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 502                 Attribute_Name => Name_Last,
 503                 Expressions    => New_List (
 504                   Make_Integer_Literal (Loc, J)));
 505
 506             Append (Make_Range (Loc, Lo, Hi), Constraints);
 507          end loop;
 508
 509       --  If the type has unknown discriminants there is no constrained
 510       --  subtype to build. This is never called for a formal or for a
 511       --  lhs, so returning the type is ok ???
 512
 513       elsif Has_Unknown_Discriminants (T) then
 514          return T;
 515
 516       else
 517          Constraints := New_List;
 518
 519          --  Type T is a generic derived type, inherit the discriminants from
 520          --  the parent type.
 521
 522          if Is_Private_Type (T)
 523            and then No (Full_View (T))
 524
 525             --  T was flagged as an error if it was declared as a formal
 526             --  derived type with known discriminants. In this case there
 527             --  is no need to look at the parent type since T already carries
 528             --  its own discriminants.
 529
 530            and then not Error_Posted (T)
 531          then
 532             Disc_Type := Etype (Base_Type (T));
 533          else
 534             Disc_Type := T;
 535          end if;
 536
 537          Discr := First_Discriminant (Disc_Type);
 538          while Present (Discr) loop
 539             Append_To (Constraints,
 540               Make_Selected_Component (Loc,
 541                 Prefix =>
 542                   Duplicate_Subexpr_No_Checks (Obj),
 543                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 544             Next_Discriminant (Discr);
 545          end loop;
 546       end if;
 547
 548       Subt := Make_Temporary (Loc, 'S', Related_Node => N);
 549       Set_Is_Internal (Subt);
 550
 551       Decl :=
 552         Make_Subtype_Declaration (Loc,
 553           Defining_Identifier => Subt,
 554           Subtype_Indication =>
 555             Make_Subtype_Indication (Loc,
 556               Subtype_Mark => New_Reference_To (T,  Loc),
 557               Constraint  =>
 558                 Make_Index_Or_Discriminant_Constraint (Loc,
 559                   Constraints => Constraints)));
 560
 561       Mark_Rewrite_Insertion (Decl);
 562       return Decl;
 563    end Build_Actual_Subtype;
 564
 565    ---------------------------------------
 566    -- Build_Actual_Subtype_Of_Component --
 567    ---------------------------------------
 568
 569    function Build_Actual_Subtype_Of_Component
 570      (T : Entity_Id;
 571       N : Node_Id) return Node_Id
 572    is
 573       Loc       : constant Source_Ptr := Sloc (N);
 574       P         : constant Node_Id    := Prefix (N);
 575       D         : Elmt_Id;
 576       Id        : Node_Id;
 577       Index_Typ : Entity_Id;
 578
 579       Desig_Typ : Entity_Id;
 580       --  This is either a copy of T, or if T is an access type, then it is
 581       --  the directly designated type of this access type.
 582
 583       function Build_Actual_Array_Constraint return List_Id;
 584       --  If one or more of the bounds of the component depends on
 585       --  discriminants, build  actual constraint using the discriminants
 586       --  of the prefix.
 587
 588       function Build_Actual_Record_Constraint return List_Id;
 589       --  Similar to previous one, for discriminated components constrained
 590       --  by the discriminant of the enclosing object.
 591
 592       -----------------------------------
 593       -- Build_Actual_Array_Constraint --
 594       -----------------------------------
 595
 596       function Build_Actual_Array_Constraint return List_Id is
 597          Constraints : constant List_Id := New_List;
 598          Indx        : Node_Id;
 599          Hi          : Node_Id;
 600          Lo          : Node_Id;
 601          Old_Hi      : Node_Id;
 602          Old_Lo      : Node_Id;
 603
 604       begin
 605          Indx := First_Index (Desig_Typ);
 606          while Present (Indx) loop
 607             Old_Lo := Type_Low_Bound  (Etype (Indx));
 608             Old_Hi := Type_High_Bound (Etype (Indx));
 609
 610             if Denotes_Discriminant (Old_Lo) then
 611                Lo :=
 612                  Make_Selected_Component (Loc,
 613                    Prefix => New_Copy_Tree (P),
 614                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 615
 616             else
 617                Lo := New_Copy_Tree (Old_Lo);
 618
 619                --  The new bound will be reanalyzed in the enclosing
 620                --  declaration. For literal bounds that come from a type
 621                --  declaration, the type of the context must be imposed, so
 622                --  insure that analysis will take place. For non-universal
 623                --  types this is not strictly necessary.
 624
 625                Set_Analyzed (Lo, False);
 626             end if;
 627
 628             if Denotes_Discriminant (Old_Hi) then
 629                Hi :=
 630                  Make_Selected_Component (Loc,
 631                    Prefix => New_Copy_Tree (P),
 632                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 633
 634             else
 635                Hi := New_Copy_Tree (Old_Hi);
 636                Set_Analyzed (Hi, False);
 637             end if;
 638
 639             Append (Make_Range (Loc, Lo, Hi), Constraints);
 640             Next_Index (Indx);
 641          end loop;
 642
 643          return Constraints;
 644       end Build_Actual_Array_Constraint;
 645
 646       ------------------------------------
 647       -- Build_Actual_Record_Constraint --
 648       ------------------------------------
 649
 650       function Build_Actual_Record_Constraint return List_Id is
 651          Constraints : constant List_Id := New_List;
 652          D           : Elmt_Id;
 653          D_Val       : Node_Id;
 654
 655       begin
 656          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 657          while Present (D) loop
 658             if Denotes_Discriminant (Node (D)) then
 659                D_Val :=  Make_Selected_Component (Loc,
 660                  Prefix => New_Copy_Tree (P),
 661                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 662
 663             else
 664                D_Val := New_Copy_Tree (Node (D));
 665             end if;
 666
 667             Append (D_Val, Constraints);
 668             Next_Elmt (D);
 669          end loop;
 670
 671          return Constraints;
 672       end Build_Actual_Record_Constraint;
 673
 674    --  Start of processing for Build_Actual_Subtype_Of_Component
 675
 676    begin
 677       --  Why the test for Spec_Expression mode here???
 678
 679       if In_Spec_Expression then
 680          return Empty;
 681
 682       --  More comments for the rest of this body would be good ???
 683
 684       elsif Nkind (N) = N_Explicit_Dereference then
 685          if Is_Composite_Type (T)
 686            and then not Is_Constrained (T)
 687            and then not (Is_Class_Wide_Type (T)
 688                           and then Is_Constrained (Root_Type (T)))
 689            and then not Has_Unknown_Discriminants (T)
 690          then
 691             --  If the type of the dereference is already constrained, it is an
 692             --  actual subtype.
 693
 694             if Is_Array_Type (Etype (N))
 695               and then Is_Constrained (Etype (N))
 696             then
 697                return Empty;
 698             else
 699                Remove_Side_Effects (P);
 700                return Build_Actual_Subtype (T, N);
 701             end if;
 702          else
 703             return Empty;
 704          end if;
 705       end if;
 706
 707       if Ekind (T) = E_Access_Subtype then
 708          Desig_Typ := Designated_Type (T);
 709       else
 710          Desig_Typ := T;
 711       end if;
 712
 713       if Ekind (Desig_Typ) = E_Array_Subtype then
 714          Id := First_Index (Desig_Typ);
 715          while Present (Id) loop
 716             Index_Typ := Underlying_Type (Etype (Id));
 717
 718             if Denotes_Discriminant (Type_Low_Bound  (Index_Typ))
 719                  or else
 720                Denotes_Discriminant (Type_High_Bound (Index_Typ))
 721             then
 722                Remove_Side_Effects (P);
 723                return
 724                  Build_Component_Subtype
 725                    (Build_Actual_Array_Constraint, Loc, Base_Type (T));
 726             end if;
 727
 728             Next_Index (Id);
 729          end loop;
 730
 731       elsif Is_Composite_Type (Desig_Typ)
 732         and then Has_Discriminants (Desig_Typ)
 733         and then not Has_Unknown_Discriminants (Desig_Typ)
 734       then
 735          if Is_Private_Type (Desig_Typ)
 736            and then No (Discriminant_Constraint (Desig_Typ))
 737          then
 738             Desig_Typ := Full_View (Desig_Typ);
 739          end if;
 740
 741          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 742          while Present (D) loop
 743             if Denotes_Discriminant (Node (D)) then
 744                Remove_Side_Effects (P);
 745                return
 746                  Build_Component_Subtype (
 747                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
 748             end if;
 749
 750             Next_Elmt (D);
 751          end loop;
 752       end if;
 753
 754       --  If none of the above, the actual and nominal subtypes are the same
 755
 756       return Empty;
 757    end Build_Actual_Subtype_Of_Component;
 758
 759    -----------------------------
 760    -- Build_Component_Subtype --
 761    -----------------------------
 762
 763    function Build_Component_Subtype
 764      (C   : List_Id;
 765       Loc : Source_Ptr;
 766       T   : Entity_Id) return Node_Id
 767    is
 768       Subt : Entity_Id;
 769       Decl : Node_Id;
 770
 771    begin
 772       --  Unchecked_Union components do not require component subtypes
 773
 774       if Is_Unchecked_Union (T) then
 775          return Empty;
 776       end if;
 777
 778       Subt := Make_Temporary (Loc, 'S');
 779       Set_Is_Internal (Subt);
 780
 781       Decl :=
 782         Make_Subtype_Declaration (Loc,
 783           Defining_Identifier => Subt,
 784           Subtype_Indication =>
 785             Make_Subtype_Indication (Loc,
 786               Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
 787               Constraint  =>
 788                 Make_Index_Or_Discriminant_Constraint (Loc,
 789                   Constraints => C)));
 790
 791       Mark_Rewrite_Insertion (Decl);
 792       return Decl;
 793    end Build_Component_Subtype;
 794
 795    ---------------------------
 796    -- Build_Default_Subtype --
 797    ---------------------------
 798
 799    function Build_Default_Subtype
 800      (T : Entity_Id;
 801       N : Node_Id) return Entity_Id
 802    is
 803       Loc  : constant Source_Ptr := Sloc (N);
 804       Disc : Entity_Id;
 805
 806       Bas : Entity_Id;
 807       --  The base type that is to be constrained by the defaults
 808
 809    begin
 810       if not Has_Discriminants (T) or else Is_Constrained (T) then
 811          return T;
 812       end if;
 813
 814       Bas := Base_Type (T);
 815
 816       --  If T is non-private but its base type is private, this is the
 817       --  completion of a subtype declaration whose parent type is private
 818       --  (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
 819       --  are to be found in the full view of the base.
 820
 821       if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
 822          Bas := Full_View (Bas);
 823       end if;
 824
 825       Disc := First_Discriminant (T);
 826
 827       if No (Discriminant_Default_Value (Disc)) then
 828          return T;
 829       end if;
 830
 831       declare
 832          Act         : constant Entity_Id := Make_Temporary (Loc, 'S');
 833          Constraints : constant List_Id := New_List;
 834          Decl        : Node_Id;
 835
 836       begin
 837          while Present (Disc) loop
 838             Append_To (Constraints,
 839               New_Copy_Tree (Discriminant_Default_Value (Disc)));
 840             Next_Discriminant (Disc);
 841          end loop;
 842
 843          Decl :=
 844            Make_Subtype_Declaration (Loc,
 845              Defining_Identifier => Act,
 846              Subtype_Indication  =>
 847                Make_Subtype_Indication (Loc,
 848                  Subtype_Mark => New_Occurrence_Of (Bas, Loc),
 849                  Constraint   =>
 850                    Make_Index_Or_Discriminant_Constraint (Loc,
 851                      Constraints => Constraints)));
 852
 853          Insert_Action (N, Decl);
 854          Analyze (Decl);
 855          return Act;
 856       end;
 857    end Build_Default_Subtype;
 858
 859    --------------------------------------------
 860    -- Build_Discriminal_Subtype_Of_Component --
 861    --------------------------------------------
 862
 863    function Build_Discriminal_Subtype_Of_Component
 864      (T : Entity_Id) return Node_Id
 865    is
 866       Loc : constant Source_Ptr := Sloc (T);
 867       D   : Elmt_Id;
 868       Id  : Node_Id;
 869
 870       function Build_Discriminal_Array_Constraint return List_Id;
 871       --  If one or more of the bounds of the component depends on
 872       --  discriminants, build  actual constraint using the discriminants
 873       --  of the prefix.
 874
 875       function Build_Discriminal_Record_Constraint return List_Id;
 876       --  Similar to previous one, for discriminated components constrained by
 877       --  the discriminant of the enclosing object.
 878
 879       ----------------------------------------
 880       -- Build_Discriminal_Array_Constraint --
 881       ----------------------------------------
 882
 883       function Build_Discriminal_Array_Constraint return List_Id is
 884          Constraints : constant List_Id := New_List;
 885          Indx        : Node_Id;
 886          Hi          : Node_Id;
 887          Lo          : Node_Id;
 888          Old_Hi      : Node_Id;
 889          Old_Lo      : Node_Id;
 890
 891       begin
 892          Indx := First_Index (T);
 893          while Present (Indx) loop
 894             Old_Lo := Type_Low_Bound  (Etype (Indx));
 895             Old_Hi := Type_High_Bound (Etype (Indx));
 896
 897             if Denotes_Discriminant (Old_Lo) then
 898                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
 899
 900             else
 901                Lo := New_Copy_Tree (Old_Lo);
 902             end if;
 903
 904             if Denotes_Discriminant (Old_Hi) then
 905                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
 906
 907             else
 908                Hi := New_Copy_Tree (Old_Hi);
 909             end if;
 910
 911             Append (Make_Range (Loc, Lo, Hi), Constraints);
 912             Next_Index (Indx);
 913          end loop;
 914
 915          return Constraints;
 916       end Build_Discriminal_Array_Constraint;
 917
 918       -----------------------------------------
 919       -- Build_Discriminal_Record_Constraint --
 920       -----------------------------------------
 921
 922       function Build_Discriminal_Record_Constraint return List_Id is
 923          Constraints : constant List_Id := New_List;
 924          D           : Elmt_Id;
 925          D_Val       : Node_Id;
 926
 927       begin
 928          D := First_Elmt (Discriminant_Constraint (T));
 929          while Present (D) loop
 930             if Denotes_Discriminant (Node (D)) then
 931                D_Val :=
 932                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
 933
 934             else
 935                D_Val := New_Copy_Tree (Node (D));
 936             end if;
 937
 938             Append (D_Val, Constraints);
 939             Next_Elmt (D);
 940          end loop;
 941
 942          return Constraints;
 943       end Build_Discriminal_Record_Constraint;
 944
 945    --  Start of processing for Build_Discriminal_Subtype_Of_Component
 946
 947    begin
 948       if Ekind (T) = E_Array_Subtype then
 949          Id := First_Index (T);
 950          while Present (Id) loop
 951             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
 952                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
 953             then
 954                return Build_Component_Subtype
 955                  (Build_Discriminal_Array_Constraint, Loc, T);
 956             end if;
 957
 958             Next_Index (Id);
 959          end loop;
 960
 961       elsif Ekind (T) = E_Record_Subtype
 962         and then Has_Discriminants (T)
 963         and then not Has_Unknown_Discriminants (T)
 964       then
 965          D := First_Elmt (Discriminant_Constraint (T));
 966          while Present (D) loop
 967             if Denotes_Discriminant (Node (D)) then
 968                return Build_Component_Subtype
 969                  (Build_Discriminal_Record_Constraint, Loc, T);
 970             end if;
 971
 972             Next_Elmt (D);
 973          end loop;
 974       end if;
 975
 976       --  If none of the above, the actual and nominal subtypes are the same
 977
 978       return Empty;
 979    end Build_Discriminal_Subtype_Of_Component;
 980
 981    ------------------------------
 982    -- Build_Elaboration_Entity --
 983    ------------------------------
 984
 985    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
 986       Loc      : constant Source_Ptr := Sloc (N);
 987       Decl     : Node_Id;
 988       Elab_Ent : Entity_Id;
 989
 990       procedure Set_Package_Name (Ent : Entity_Id);
 991       --  Given an entity, sets the fully qualified name of the entity in
 992       --  Name_Buffer, with components separated by double underscores. This
 993       --  is a recursive routine that climbs the scope chain to Standard.
 994
 995       ----------------------
 996       -- Set_Package_Name --
 997       ----------------------
 998
 999       procedure Set_Package_Name (Ent : Entity_Id) is
1000       begin
1001          if Scope (Ent) /= Standard_Standard then
1002             Set_Package_Name (Scope (Ent));
1003
1004             declare
1005                Nam : constant String := Get_Name_String (Chars (Ent));
1006             begin
1007                Name_Buffer (Name_Len + 1) := '_';
1008                Name_Buffer (Name_Len + 2) := '_';
1009                Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1010                Name_Len := Name_Len + Nam'Length + 2;
1011             end;
1012
1013          else
1014             Get_Name_String (Chars (Ent));
1015          end if;
1016       end Set_Package_Name;
1017
1018    --  Start of processing for Build_Elaboration_Entity
1019
1020    begin
1021       --  Ignore if already constructed
1022
1023       if Present (Elaboration_Entity (Spec_Id)) then
1024          return;
1025       end if;
1026
1027       --  Construct name of elaboration entity as xxx_E, where xxx is the unit
1028       --  name with dots replaced by double underscore. We have to manually
1029       --  construct this name, since it will be elaborated in the outer scope,
1030       --  and thus will not have the unit name automatically prepended.
1031
1032       Set_Package_Name (Spec_Id);
1033       Add_Str_To_Name_Buffer ("_E");
1034
1035       --  Create elaboration counter
1036
1037       Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1038       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1039
1040       Decl :=
1041         Make_Object_Declaration (Loc,
1042           Defining_Identifier => Elab_Ent,
1043           Object_Definition   =>
1044             New_Occurrence_Of (Standard_Short_Integer, Loc),
1045           Expression          => Make_Integer_Literal (Loc, Uint_0));
1046
1047       Push_Scope (Standard_Standard);
1048       Add_Global_Declaration (Decl);
1049       Pop_Scope;
1050
1051       --  Reset True_Constant indication, since we will indeed assign a value
1052       --  to the variable in the binder main. We also kill the Current_Value
1053       --  and Last_Assignment fields for the same reason.
1054
1055       Set_Is_True_Constant (Elab_Ent, False);
1056       Set_Current_Value    (Elab_Ent, Empty);
1057       Set_Last_Assignment  (Elab_Ent, Empty);
1058
1059       --  We do not want any further qualification of the name (if we did not
1060       --  do this, we would pick up the name of the generic package in the case
1061       --  of a library level generic instantiation).
1062
1063       Set_Has_Qualified_Name       (Elab_Ent);
1064       Set_Has_Fully_Qualified_Name (Elab_Ent);
1065    end Build_Elaboration_Entity;
1066
1067    --------------------------------
1068    -- Build_Explicit_Dereference --
1069    --------------------------------
1070
1071    procedure Build_Explicit_Dereference
1072      (Expr : Node_Id;
1073       Disc : Entity_Id)
1074    is
1075       Loc : constant Source_Ptr := Sloc (Expr);
1076    begin
1077
1078       --  An entity of a type with a reference aspect is overloaded with
1079       --  both interpretations: with and without the dereference. Now that
1080       --  the dereference is made explicit, set the type of the node properly,
1081       --  to prevent anomalies in the backend. Same if the expression is an
1082       --  overloaded function call whose return type has a reference aspect.
1083
1084       if Is_Entity_Name (Expr) then
1085          Set_Etype (Expr, Etype (Entity (Expr)));
1086
1087       elsif Nkind (Expr) = N_Function_Call then
1088          Set_Etype (Expr, Etype (Name (Expr)));
1089       end if;
1090
1091       Set_Is_Overloaded (Expr, False);
1092       Rewrite (Expr,
1093         Make_Explicit_Dereference (Loc,
1094           Prefix =>
1095             Make_Selected_Component (Loc,
1096               Prefix        => Relocate_Node (Expr),
1097               Selector_Name => New_Occurrence_Of (Disc, Loc))));
1098       Set_Etype (Prefix (Expr), Etype (Disc));
1099       Set_Etype (Expr, Designated_Type (Etype (Disc)));
1100    end Build_Explicit_Dereference;
1101
1102    -----------------------------------
1103    -- Cannot_Raise_Constraint_Error --
1104    -----------------------------------
1105
1106    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1107    begin
1108       if Compile_Time_Known_Value (Expr) then
1109          return True;
1110
1111       elsif Do_Range_Check (Expr) then
1112          return False;
1113
1114       elsif Raises_Constraint_Error (Expr) then
1115          return False;
1116
1117       else
1118          case Nkind (Expr) is
1119             when N_Identifier =>
1120                return True;
1121
1122             when N_Expanded_Name =>
1123                return True;
1124
1125             when N_Selected_Component =>
1126                return not Do_Discriminant_Check (Expr);
1127
1128             when N_Attribute_Reference =>
1129                if Do_Overflow_Check (Expr) then
1130                   return False;
1131
1132                elsif No (Expressions (Expr)) then
1133                   return True;
1134
1135                else
1136                   declare
1137                      N : Node_Id;
1138
1139                   begin
1140                      N := First (Expressions (Expr));
1141                      while Present (N) loop
1142                         if Cannot_Raise_Constraint_Error (N) then
1143                            Next (N);
1144                         else
1145                            return False;
1146                         end if;
1147                      end loop;
1148
1149                      return True;
1150                   end;
1151                end if;
1152
1153             when N_Type_Conversion =>
1154                if Do_Overflow_Check (Expr)
1155                  or else Do_Length_Check (Expr)
1156                  or else Do_Tag_Check (Expr)
1157                then
1158                   return False;
1159                else
1160                   return Cannot_Raise_Constraint_Error (Expression (Expr));
1161                end if;
1162
1163             when N_Unchecked_Type_Conversion =>
1164                return Cannot_Raise_Constraint_Error (Expression (Expr));
1165
1166             when N_Unary_Op =>
1167                if Do_Overflow_Check (Expr) then
1168                   return False;
1169                else
1170                   return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1171                end if;
1172
1173             when N_Op_Divide |
1174                  N_Op_Mod    |
1175                  N_Op_Rem
1176             =>
1177                if Do_Division_Check (Expr)
1178                  or else Do_Overflow_Check (Expr)
1179                then
1180                   return False;
1181                else
1182                   return
1183                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1184                       and then
1185                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1186                end if;
1187
1188             when N_Op_Add                    |
1189                  N_Op_And                    |
1190                  N_Op_Concat                 |
1191                  N_Op_Eq                     |
1192                  N_Op_Expon                  |
1193                  N_Op_Ge                     |
1194                  N_Op_Gt                     |
1195                  N_Op_Le                     |
1196                  N_Op_Lt                     |
1197                  N_Op_Multiply               |
1198                  N_Op_Ne                     |
1199                  N_Op_Or                     |
1200                  N_Op_Rotate_Left            |
1201                  N_Op_Rotate_Right           |
1202                  N_Op_Shift_Left             |
1203                  N_Op_Shift_Right            |
1204                  N_Op_Shift_Right_Arithmetic |
1205                  N_Op_Subtract               |
1206                  N_Op_Xor
1207             =>
1208                if Do_Overflow_Check (Expr) then
1209                   return False;
1210                else
1211                   return
1212                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1213                       and then
1214                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1215                end if;
1216
1217             when others =>
1218                return False;
1219          end case;
1220       end if;
1221    end Cannot_Raise_Constraint_Error;
1222
1223    -------------------------------------
1224    -- Check_Function_Writable_Actuals --
1225    -------------------------------------
1226
1227    procedure Check_Function_Writable_Actuals (N : Node_Id) is
1228       Writable_Actuals_List : Elist_Id := No_Elist;
1229       Identifiers_List      : Elist_Id := No_Elist;
1230       Error_Node            : Node_Id  := Empty;
1231
1232       procedure Collect_Identifiers (N : Node_Id);
1233       --  In a single traversal of subtree N collect in Writable_Actuals_List
1234       --  all the actuals of functions with writable actuals, and in the list
1235       --  Identifiers_List collect all the identifiers that are not actuals of
1236       --  functions with writable actuals. If a writable actual is referenced
1237       --  twice as writable actual then Error_Node is set to reference its
1238       --  second occurrence, the error is reported, and the tree traversal
1239       --  is abandoned.
1240
1241       function Get_Function_Id (Call : Node_Id) return Entity_Id;
1242       --  Return the entity associated with the function call
1243
1244       procedure Preanalyze_Without_Errors (N : Node_Id);
1245       --  Preanalyze N without reporting errors. Very dubious, you can't just
1246       --  go analyzing things more than once???
1247
1248       -------------------------
1249       -- Collect_Identifiers --
1250       -------------------------
1251
1252       procedure Collect_Identifiers (N : Node_Id) is
1253
1254          function Check_Node (N : Node_Id) return Traverse_Result;
1255          --  Process a single node during the tree traversal to collect the
1256          --  writable actuals of functions and all the identifiers which are
1257          --  not writable actuals of functions.
1258
1259          function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1260          --  Returns True if List has a node whose Entity is Entity (N)
1261
1262          -------------------------
1263          -- Check_Function_Call --
1264          -------------------------
1265
1266          function Check_Node (N : Node_Id) return Traverse_Result is
1267             Is_Writable_Actual : Boolean := False;
1268
1269          begin
1270             if Nkind (N) = N_Identifier then
1271
1272                --  No analysis possible if the entity is not decorated
1273
1274                if No (Entity (N)) then
1275                   return Skip;
1276
1277                --  Don't collect identifiers of packages, called functions, etc
1278
1279                elsif Ekind_In (Entity (N), E_Package,
1280                                            E_Function,
1281                                            E_Procedure,
1282                                            E_Entry)
1283                then
1284                   return Skip;
1285
1286                --  Analyze if N is a writable actual of a function
1287
1288                elsif Nkind (Parent (N)) = N_Function_Call then
1289                   declare
1290                      Call   : constant Node_Id   := Parent (N);
1291                      Id     : constant Entity_Id := Get_Function_Id (Call);
1292                      Actual : Node_Id;
1293                      Formal : Node_Id;
1294
1295                   begin
1296                      Formal := First_Formal (Id);
1297                      Actual := First_Actual (Call);
1298                      while Present (Actual) and then Present (Formal) loop
1299                         if Actual = N then
1300                            if Ekind_In (Formal, E_Out_Parameter,
1301                                                 E_In_Out_Parameter)
1302                            then
1303                               Is_Writable_Actual := True;
1304                            end if;
1305
1306                            exit;
1307                         end if;
1308
1309                         Next_Formal (Formal);
1310                         Next_Actual (Actual);
1311                      end loop;
1312                   end;
1313                end if;
1314
1315                if Is_Writable_Actual then
1316                   if Contains (Writable_Actuals_List, N) then
1317                      Error_Msg_N
1318                        ("conflict of writable function parameter in "
1319                         & "construct with arbitrary order of evaluation", N);
1320                      Error_Node := N;
1321                      return Abandon;
1322                   end if;
1323
1324                   if Writable_Actuals_List = No_Elist then
1325                      Writable_Actuals_List := New_Elmt_List;
1326                   end if;
1327
1328                   Append_Elmt (N, Writable_Actuals_List);
1329                else
1330                   if Identifiers_List = No_Elist then
1331                      Identifiers_List := New_Elmt_List;
1332                   end if;
1333
1334                   Append_Unique_Elmt (N, Identifiers_List);
1335                end if;
1336             end if;
1337
1338             return OK;
1339          end Check_Node;
1340
1341          --------------
1342          -- Contains --
1343          --------------
1344
1345          function Contains
1346            (List : Elist_Id;
1347             N    : Node_Id) return Boolean
1348          is
1349             pragma Assert (Nkind (N) in N_Has_Entity);
1350
1351             Elmt : Elmt_Id;
1352
1353          begin
1354             if List = No_Elist then
1355                return False;
1356             end if;
1357
1358             Elmt := First_Elmt (List);
1359             while Present (Elmt) loop
1360                if Entity (Node (Elmt)) = Entity (N) then
1361                   return True;
1362                else
1363                   Next_Elmt (Elmt);
1364                end if;
1365             end loop;
1366
1367             return False;
1368          end Contains;
1369
1370          ------------------
1371          -- Do_Traversal --
1372          ------------------
1373
1374          procedure Do_Traversal is new Traverse_Proc (Check_Node);
1375          --  The traversal procedure
1376
1377       --  Start of processing for Collect_Identifiers
1378
1379       begin
1380          if Present (Error_Node) then
1381             return;
1382          end if;
1383
1384          if Nkind (N) in N_Subexpr
1385            and then Is_Static_Expression (N)
1386          then
1387             return;
1388          end if;
1389
1390          Do_Traversal (N);
1391       end Collect_Identifiers;
1392
1393       ---------------------
1394       -- Get_Function_Id --
1395       ---------------------
1396
1397       function Get_Function_Id (Call : Node_Id) return Entity_Id is
1398          Nam : constant Node_Id := Name (Call);
1399          Id  : Entity_Id;
1400
1401       begin
1402          if Nkind (Nam) = N_Explicit_Dereference then
1403             Id := Etype (Nam);
1404             pragma Assert (Ekind (Id) = E_Subprogram_Type);
1405
1406          elsif Nkind (Nam) = N_Selected_Component then
1407             Id := Entity (Selector_Name (Nam));
1408
1409          elsif Nkind (Nam) = N_Indexed_Component then
1410             Id := Entity (Selector_Name (Prefix (Nam)));
1411
1412          else
1413             Id := Entity (Nam);
1414          end if;
1415
1416          return Id;
1417       end Get_Function_Id;
1418
1419       ---------------------------
1420       -- Preanalyze_Expression --
1421       ---------------------------
1422
1423       procedure Preanalyze_Without_Errors (N : Node_Id) is
1424          Status : constant Boolean := Get_Ignore_Errors;
1425       begin
1426          Set_Ignore_Errors (True);
1427          Preanalyze (N);
1428          Set_Ignore_Errors (Status);
1429       end Preanalyze_Without_Errors;
1430
1431    --  Start of processing for Check_Function_Writable_Actuals
1432
1433    begin
1434       if Ada_Version < Ada_2012
1435         or else (not (Nkind (N) in N_Op)
1436                   and then not (Nkind (N) in N_Membership_Test)
1437                   and then not Nkind_In (N, N_Range,
1438                                             N_Aggregate,
1439                                             N_Extension_Aggregate,
1440                                             N_Full_Type_Declaration,
1441                                             N_Function_Call,
1442                                             N_Procedure_Call_Statement,
1443                                             N_Entry_Call_Statement))
1444         or else (Nkind (N) = N_Full_Type_Declaration
1445                    and then not Is_Record_Type (Defining_Identifier (N)))
1446       then
1447          return;
1448       end if;
1449
1450       --  If a construct C has two or more direct constituents that are names
1451       --  or expressions whose evaluation may occur in an arbitrary order, at
1452       --  least one of which contains a function call with an in out or out
1453       --  parameter, then the construct is legal only if: for each name N that
1454       --  is passed as a parameter of mode in out or out to some inner function
1455       --  call C2 (not including the construct C itself), there is no other
1456       --  name anywhere within a direct constituent of the construct C other
1457       --  than the one containing C2, that is known to refer to the same
1458       --  object (RM 6.4.1(6.17/3)).
1459
1460       case Nkind (N) is
1461          when N_Range =>
1462             Collect_Identifiers (Low_Bound (N));
1463             Collect_Identifiers (High_Bound (N));
1464
1465          when N_Op | N_Membership_Test =>
1466             declare
1467                Expr : Node_Id;
1468             begin
1469                Collect_Identifiers (Left_Opnd (N));
1470
1471                if Present (Right_Opnd (N)) then
1472                   Collect_Identifiers (Right_Opnd (N));
1473                end if;
1474
1475                if Nkind_In (N, N_In, N_Not_In)
1476                  and then Present (Alternatives (N))
1477                then
1478                   Expr := First (Alternatives (N));
1479                   while Present (Expr) loop
1480                      Collect_Identifiers (Expr);
1481
1482                      Next (Expr);
1483                   end loop;
1484                end if;
1485             end;
1486
1487          when N_Full_Type_Declaration =>
1488             declare
1489                function Get_Record_Part (N : Node_Id) return Node_Id;
1490                --  Return the record part of this record type definition
1491
1492                function Get_Record_Part (N : Node_Id) return Node_Id is
1493                   Type_Def : constant Node_Id := Type_Definition (N);
1494                begin
1495                   if Nkind (Type_Def) = N_Derived_Type_Definition then
1496                      return Record_Extension_Part (Type_Def);
1497                   else
1498                      return Type_Def;
1499                   end if;
1500                end Get_Record_Part;
1501
1502                Comp   : Node_Id;
1503                Def_Id : Entity_Id := Defining_Identifier (N);
1504                Rec    : Node_Id   := Get_Record_Part (N);
1505
1506             begin
1507                --  No need to perform any analysis if the record has no
1508                --  components
1509
1510                if No (Rec) or else No (Component_List (Rec)) then
1511                   return;
1512                end if;
1513
1514                --  Collect the identifiers starting from the deepest
1515                --  derivation. Done to report the error in the deepest
1516                --  derivation.
1517
1518                loop
1519                   if Present (Component_List (Rec)) then
1520                      Comp := First (Component_Items (Component_List (Rec)));
1521                      while Present (Comp) loop
1522                         if Nkind (Comp) = N_Component_Declaration
1523                           and then Present (Expression (Comp))
1524                         then
1525                            Collect_Identifiers (Expression (Comp));
1526                         end if;
1527
1528                         Next (Comp);
1529                      end loop;
1530                   end if;
1531
1532                   exit when No (Underlying_Type (Etype (Def_Id)))
1533                     or else Base_Type (Underlying_Type (Etype (Def_Id)))
1534                               = Def_Id;
1535
1536                   Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
1537                   Rec := Get_Record_Part (Parent (Def_Id));
1538                end loop;
1539             end;
1540
1541          when N_Subprogram_Call      |
1542               N_Entry_Call_Statement =>
1543             declare
1544                Id     : constant Entity_Id := Get_Function_Id (N);
1545                Formal : Node_Id;
1546                Actual : Node_Id;
1547
1548             begin
1549                Formal := First_Formal (Id);
1550                Actual := First_Actual (N);
1551                while Present (Actual) and then Present (Formal) loop
1552                   if Ekind_In (Formal, E_Out_Parameter,
1553                                        E_In_Out_Parameter)
1554                   then
1555                      Collect_Identifiers (Actual);
1556                   end if;
1557
1558                   Next_Formal (Formal);
1559                   Next_Actual (Actual);
1560                end loop;
1561             end;
1562
1563          when N_Aggregate           |
1564               N_Extension_Aggregate =>
1565             declare
1566                Assoc     : Node_Id;
1567                Choice    : Node_Id;
1568                Comp_Expr : Node_Id;
1569
1570             begin
1571                --  Handle the N_Others_Choice of array aggregates with static
1572                --  bounds. There is no need to perform this analysis in
1573                --  aggregates without static bounds since we cannot evaluate
1574                --  if the N_Others_Choice covers several elements. There is
1575                --  no need to handle the N_Others choice of record aggregates
1576                --  since at this stage it has been already expanded by
1577                --  Resolve_Record_Aggregate.
1578
1579                if Is_Array_Type (Etype (N))
1580                  and then Nkind (N) = N_Aggregate
1581                  and then Present (Aggregate_Bounds (N))
1582                  and then Compile_Time_Known_Bounds (Etype (N))
1583                  and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
1584                             > Expr_Value (Low_Bound (Aggregate_Bounds (N)))
1585                then
1586                   declare
1587                      Count_Components   : Uint := Uint_0;
1588                      Num_Components     : Uint;
1589                      Others_Assoc       : Node_Id;
1590                      Others_Choice      : Node_Id := Empty;
1591                      Others_Box_Present : Boolean := False;
1592
1593                   begin
1594                      --  Count positional associations
1595
1596                      if Present (Expressions (N)) then
1597                         Comp_Expr := First (Expressions (N));
1598                         while Present (Comp_Expr) loop
1599                            Count_Components := Count_Components + 1;
1600                            Next (Comp_Expr);
1601                         end loop;
1602                      end if;
1603
1604                      --  Count the rest of elements and locate the N_Others
1605                      --  choice (if any)
1606
1607                      Assoc := First (Component_Associations (N));
1608                      while Present (Assoc) loop
1609                         Choice := First (Choices (Assoc));
1610                         while Present (Choice) loop
1611                            if Nkind (Choice) = N_Others_Choice then
1612                               Others_Assoc       := Assoc;
1613                               Others_Choice      := Choice;
1614                               Others_Box_Present := Box_Present (Assoc);
1615
1616                            --  Count several components
1617
1618                            elsif Nkind_In (Choice, N_Range,
1619                                                    N_Subtype_Indication)
1620                              or else (Is_Entity_Name (Choice)
1621                                         and then Is_Type (Entity (Choice)))
1622                            then
1623                               declare
1624                                  L, H : Node_Id;
1625                               begin
1626                                  Get_Index_Bounds (Choice, L, H);
1627                                  pragma Assert
1628                                    (Compile_Time_Known_Value (L)
1629                                       and then Compile_Time_Known_Value (H));
1630                                  Count_Components :=
1631                                    Count_Components
1632                                      + Expr_Value (H) - Expr_Value (L) + 1;
1633                               end;
1634
1635                            --  Count single component. No other case available
1636                            --  since we are handling an aggregate with static
1637                            --  bounds.
1638
1639                            else
1640                               pragma Assert (Is_Static_Expression (Choice)
1641                                 or else Nkind (Choice) = N_Identifier
1642                                 or else Nkind (Choice) = N_Integer_Literal);
1643
1644                               Count_Components := Count_Components + 1;
1645                            end if;
1646
1647                            Next (Choice);
1648                         end loop;
1649
1650                         Next (Assoc);
1651                      end loop;
1652
1653                      Num_Components :=
1654                        Expr_Value (High_Bound (Aggregate_Bounds (N))) -
1655                          Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
1656
1657                      pragma Assert (Count_Components <= Num_Components);
1658
1659                      --  Handle the N_Others choice if it covers several
1660                      --  components
1661
1662                      if Present (Others_Choice)
1663                        and then (Num_Components - Count_Components) > 1
1664                      then
1665                         if not Others_Box_Present then
1666
1667                            --  At this stage, if expansion is active, the
1668                            --  expression of the others choice has not been
1669                            --  analyzed. Hence we generate a duplicate and
1670                            --  we analyze it silently to have available the
1671                            --  minimum decoration required to collect the
1672                            --  identifiers.
1673
1674                            if not Expander_Active then
1675                               Comp_Expr := Expression (Others_Assoc);
1676                            else
1677                               Comp_Expr :=
1678                                 New_Copy_Tree (Expression (Others_Assoc));
1679                               Preanalyze_Without_Errors (Comp_Expr);
1680                            end if;
1681
1682                            Collect_Identifiers (Comp_Expr);
1683
1684                            if Writable_Actuals_List /= No_Elist then
1685
1686                               --  As suggested by Robert, at current stage we
1687                               --  report occurrences of this case as warnings.
1688
1689                               Error_Msg_N
1690                                 ("conflict of writable function parameter in "
1691                                  & "construct with arbitrary order of "
1692                                  & "evaluation?",
1693                                  Node (First_Elmt (Writable_Actuals_List)));
1694                            end if;
1695                         end if;
1696                      end if;
1697                   end;
1698                end if;
1699
1700                --  Handle ancestor part of extension aggregates
1701
1702                if Nkind (N) = N_Extension_Aggregate then
1703                   Collect_Identifiers (Ancestor_Part (N));
1704                end if;
1705
1706                --  Handle positional associations
1707
1708                if Present (Expressions (N)) then
1709                   Comp_Expr := First (Expressions (N));
1710                   while Present (Comp_Expr) loop
1711                      if not Is_Static_Expression (Comp_Expr) then
1712                         Collect_Identifiers (Comp_Expr);
1713                      end if;
1714
1715                      Next (Comp_Expr);
1716                   end loop;
1717                end if;
1718
1719                --  Handle discrete associations
1720
1721                if Present (Component_Associations (N)) then
1722                   Assoc := First (Component_Associations (N));
1723                   while Present (Assoc) loop
1724
1725                      if not Box_Present (Assoc) then
1726                         Choice := First (Choices (Assoc));
1727                         while Present (Choice) loop
1728
1729                            --  For now we skip discriminants since it requires
1730                            --  performing the analysis in two phases: first one
1731                            --  analyzing discriminants and second one analyzing
1732                            --  the rest of components since discriminants are
1733                            --  evaluated prior to components: too much extra
1734                            --  work to detect a corner case???
1735
1736                            if Nkind (Choice) in N_Has_Entity
1737                              and then Present (Entity (Choice))
1738                              and then Ekind (Entity (Choice)) = E_Discriminant
1739                            then
1740                               null;
1741
1742                            elsif Box_Present (Assoc) then
1743                               null;
1744
1745                            else
1746                               if not Analyzed (Expression (Assoc)) then
1747                                  Comp_Expr :=
1748                                    New_Copy_Tree (Expression (Assoc));
1749                                  Set_Parent (Comp_Expr, Parent (N));
1750                                  Preanalyze_Without_Errors (Comp_Expr);
1751                               else
1752                                  Comp_Expr := Expression (Assoc);
1753                               end if;
1754
1755                               Collect_Identifiers (Comp_Expr);
1756                            end if;
1757
1758                            Next (Choice);
1759                         end loop;
1760                      end if;
1761
1762                      Next (Assoc);
1763                   end loop;
1764                end if;
1765             end;
1766
1767          when others =>
1768             return;
1769       end case;
1770
1771       --  No further action needed if we already reported an error
1772
1773       if Present (Error_Node) then
1774          return;
1775       end if;
1776
1777       --  Check if some writable argument of a function is referenced
1778
1779       if Writable_Actuals_List /= No_Elist
1780         and then Identifiers_List /= No_Elist
1781       then
1782          declare
1783             Elmt_1 : Elmt_Id;
1784             Elmt_2 : Elmt_Id;
1785
1786          begin
1787             Elmt_1 := First_Elmt (Writable_Actuals_List);
1788             while Present (Elmt_1) loop
1789                Elmt_2 := First_Elmt (Identifiers_List);
1790                while Present (Elmt_2) loop
1791                   if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
1792                      Error_Msg_N
1793                        ("conflict of writable function parameter in construct "
1794                         & "with arbitrary order of evaluation",
1795                         Node (Elmt_1));
1796                   end if;
1797
1798                   Next_Elmt (Elmt_2);
1799                end loop;
1800
1801                Next_Elmt (Elmt_1);
1802             end loop;
1803          end;
1804       end if;
1805    end Check_Function_Writable_Actuals;
1806
1807    --------------------------------
1808    -- Check_Implicit_Dereference --
1809    --------------------------------
1810
1811    procedure Check_Implicit_Dereference (Nam : Node_Id;  Typ : Entity_Id) is
1812       Disc  : Entity_Id;
1813       Desig : Entity_Id;
1814
1815    begin
1816       if Ada_Version < Ada_2012
1817         or else not Has_Implicit_Dereference (Base_Type (Typ))
1818       then
1819          return;
1820
1821       elsif not Comes_From_Source (Nam) then
1822          return;
1823
1824       elsif Is_Entity_Name (Nam)
1825         and then Is_Type (Entity (Nam))
1826       then
1827          null;
1828
1829       else
1830          Disc := First_Discriminant (Typ);
1831          while Present (Disc) loop
1832             if Has_Implicit_Dereference (Disc) then
1833                Desig := Designated_Type (Etype (Disc));
1834                Add_One_Interp (Nam, Disc, Desig);
1835                exit;
1836             end if;
1837
1838             Next_Discriminant (Disc);
1839          end loop;
1840       end if;
1841    end Check_Implicit_Dereference;
1842
1843    ----------------------------------
1844    -- Check_Internal_Protected_Use --
1845    ----------------------------------
1846
1847    procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
1848       S    : Entity_Id;
1849       Prot : Entity_Id;
1850
1851    begin
1852       S := Current_Scope;
1853       while Present (S) loop
1854          if S = Standard_Standard then
1855             return;
1856
1857          elsif Ekind (S) = E_Function
1858            and then Ekind (Scope (S)) = E_Protected_Type
1859          then
1860             Prot := Scope (S);
1861             exit;
1862          end if;
1863
1864          S := Scope (S);
1865       end loop;
1866
1867       if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
1868          if Nkind (N) = N_Subprogram_Renaming_Declaration then
1869             Error_Msg_N
1870               ("within protected function cannot use protected "
1871                & "procedure in renaming or as generic actual", N);
1872
1873          elsif Nkind (N) = N_Attribute_Reference then
1874             Error_Msg_N
1875               ("within protected function cannot take access of "
1876                & " protected procedure", N);
1877
1878          else
1879             Error_Msg_N
1880               ("within protected function, protected object is constant", N);
1881             Error_Msg_N
1882               ("\cannot call operation that may modify it", N);
1883          end if;
1884       end if;
1885    end Check_Internal_Protected_Use;
1886
1887    ---------------------------------------
1888    -- Check_Later_Vs_Basic_Declarations --
1889    ---------------------------------------
1890
1891    procedure Check_Later_Vs_Basic_Declarations
1892      (Decls          : List_Id;
1893       During_Parsing : Boolean)
1894    is
1895       Body_Sloc : Source_Ptr;
1896       Decl      : Node_Id;
1897
1898       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
1899       --  Return whether Decl is considered as a declarative item.
1900       --  When During_Parsing is True, the semantics of Ada 83 is followed.
1901       --  When During_Parsing is False, the semantics of SPARK is followed.
1902
1903       -------------------------------
1904       -- Is_Later_Declarative_Item --
1905       -------------------------------
1906
1907       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
1908       begin
1909          if Nkind (Decl) in N_Later_Decl_Item then
1910             return True;
1911
1912          elsif Nkind (Decl) = N_Pragma then
1913             return True;
1914
1915          elsif During_Parsing then
1916             return False;
1917
1918          --  In SPARK, a package declaration is not considered as a later
1919          --  declarative item.
1920
1921          elsif Nkind (Decl) = N_Package_Declaration then
1922             return False;
1923
1924          --  In SPARK, a renaming is considered as a later declarative item
1925
1926          elsif Nkind (Decl) in N_Renaming_Declaration then
1927             return True;
1928
1929          else
1930             return False;
1931          end if;
1932       end Is_Later_Declarative_Item;
1933
1934    --  Start of Check_Later_Vs_Basic_Declarations
1935
1936    begin
1937       Decl := First (Decls);
1938
1939       --  Loop through sequence of basic declarative items
1940
1941       Outer : while Present (Decl) loop
1942          if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
1943            and then Nkind (Decl) not in N_Body_Stub
1944          then
1945             Next (Decl);
1946
1947             --  Once a body is encountered, we only allow later declarative
1948             --  items. The inner loop checks the rest of the list.
1949
1950          else
1951             Body_Sloc := Sloc (Decl);
1952
1953             Inner : while Present (Decl) loop
1954                if not Is_Later_Declarative_Item (Decl) then
1955                   if During_Parsing then
1956                      if Ada_Version = Ada_83 then
1957                         Error_Msg_Sloc := Body_Sloc;
1958                         Error_Msg_N
1959                           ("(Ada 83) decl cannot appear after body#", Decl);
1960                      end if;
1961                   else
1962                      Error_Msg_Sloc := Body_Sloc;
1963                      Check_SPARK_Restriction
1964                        ("decl cannot appear after body#", Decl);
1965                   end if;
1966                end if;
1967
1968                Next (Decl);
1969             end loop Inner;
1970          end if;
1971       end loop Outer;
1972    end Check_Later_Vs_Basic_Declarations;
1973
1974    -----------------------------------------
1975    -- Check_Dynamically_Tagged_Expression --
1976    -----------------------------------------
1977
1978    procedure Check_Dynamically_Tagged_Expression
1979      (Expr        : Node_Id;
1980       Typ         : Entity_Id;
1981       Related_Nod : Node_Id)
1982    is
1983    begin
1984       pragma Assert (Is_Tagged_Type (Typ));
1985
1986       --  In order to avoid spurious errors when analyzing the expanded code,
1987       --  this check is done only for nodes that come from source and for
1988       --  actuals of generic instantiations.
1989
1990       if (Comes_From_Source (Related_Nod)
1991            or else In_Generic_Actual (Expr))
1992         and then (Is_Class_Wide_Type (Etype (Expr))
1993                    or else Is_Dynamically_Tagged (Expr))
1994         and then Is_Tagged_Type (Typ)
1995         and then not Is_Class_Wide_Type (Typ)
1996       then
1997          Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1998       end if;
1999    end Check_Dynamically_Tagged_Expression;
2000
2001    --------------------------
2002    -- Check_Fully_Declared --
2003    --------------------------
2004
2005    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
2006    begin
2007       if Ekind (T) = E_Incomplete_Type then
2008
2009          --  Ada 2005 (AI-50217): If the type is available through a limited
2010          --  with_clause, verify that its full view has been analyzed.
2011
2012          if From_With_Type (T)
2013            and then Present (Non_Limited_View (T))
2014            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
2015          then
2016             --  The non-limited view is fully declared
2017             null;
2018
2019          else
2020             Error_Msg_NE
2021               ("premature usage of incomplete}", N, First_Subtype (T));
2022          end if;
2023
2024       --  Need comments for these tests ???
2025
2026       elsif Has_Private_Component (T)
2027         and then not Is_Generic_Type (Root_Type (T))
2028         and then not In_Spec_Expression
2029       then
2030          --  Special case: if T is the anonymous type created for a single
2031          --  task or protected object, use the name of the source object.
2032
2033          if Is_Concurrent_Type (T)
2034            and then not Comes_From_Source (T)
2035            and then Nkind (N) = N_Object_Declaration
2036          then
2037             Error_Msg_NE ("type of& has incomplete component", N,
2038               Defining_Identifier (N));
2039
2040          else
2041             Error_Msg_NE
2042               ("premature usage of incomplete}", N, First_Subtype (T));
2043          end if;
2044       end if;
2045    end Check_Fully_Declared;
2046
2047    -------------------------
2048    -- Check_Nested_Access --
2049    -------------------------
2050
2051    procedure Check_Nested_Access (Ent : Entity_Id) is
2052       Scop         : constant Entity_Id := Current_Scope;
2053       Current_Subp : Entity_Id;
2054       Enclosing    : Entity_Id;
2055
2056    begin
2057       --  Currently only enabled for VM back-ends for efficiency, should we
2058       --  enable it more systematically ???
2059
2060       --  Check for Is_Imported needs commenting below ???
2061
2062       if VM_Target /= No_VM
2063         and then (Ekind (Ent) = E_Variable
2064                     or else
2065                   Ekind (Ent) = E_Constant
2066                     or else
2067                   Ekind (Ent) = E_Loop_Parameter)
2068         and then Scope (Ent) /= Empty
2069         and then not Is_Library_Level_Entity (Ent)
2070         and then not Is_Imported (Ent)
2071       then
2072          if Is_Subprogram (Scop)
2073            or else Is_Generic_Subprogram (Scop)
2074            or else Is_Entry (Scop)
2075          then
2076             Current_Subp := Scop;
2077          else
2078             Current_Subp := Current_Subprogram;
2079          end if;
2080
2081          Enclosing := Enclosing_Subprogram (Ent);
2082
2083          if Enclosing /= Empty
2084            and then Enclosing /= Current_Subp
2085          then
2086             Set_Has_Up_Level_Access (Ent, True);
2087          end if;
2088       end if;
2089    end Check_Nested_Access;
2090
2091    ------------------------------------------
2092    -- Check_Potentially_Blocking_Operation --
2093    ------------------------------------------
2094
2095    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
2096       S : Entity_Id;
2097
2098    begin
2099       --  N is one of the potentially blocking operations listed in 9.5.1(8).
2100       --  When pragma Detect_Blocking is active, the run time will raise
2101       --  Program_Error. Here we only issue a warning, since we generally
2102       --  support the use of potentially blocking operations in the absence
2103       --  of the pragma.
2104
2105       --  Indirect blocking through a subprogram call cannot be diagnosed
2106       --  statically without interprocedural analysis, so we do not attempt
2107       --  to do it here.
2108
2109       S := Scope (Current_Scope);
2110       while Present (S) and then S /= Standard_Standard loop
2111          if Is_Protected_Type (S) then
2112             Error_Msg_N
2113               ("potentially blocking operation in protected operation??", N);
2114             return;
2115          end if;
2116
2117          S := Scope (S);
2118       end loop;
2119    end Check_Potentially_Blocking_Operation;
2120
2121    ------------------------------
2122    -- Check_Unprotected_Access --
2123    ------------------------------
2124
2125    procedure Check_Unprotected_Access
2126      (Context : Node_Id;
2127       Expr    : Node_Id)
2128    is
2129       Cont_Encl_Typ : Entity_Id;
2130       Pref_Encl_Typ : Entity_Id;
2131
2132       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
2133       --  Check whether Obj is a private component of a protected object.
2134       --  Return the protected type where the component resides, Empty
2135       --  otherwise.
2136
2137       function Is_Public_Operation return Boolean;
2138       --  Verify that the enclosing operation is callable from outside the
2139       --  protected object, to minimize false positives.
2140
2141       ------------------------------
2142       -- Enclosing_Protected_Type --
2143       ------------------------------
2144
2145       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
2146       begin
2147          if Is_Entity_Name (Obj) then
2148             declare
2149                Ent : Entity_Id := Entity (Obj);
2150
2151             begin
2152                --  The object can be a renaming of a private component, use
2153                --  the original record component.
2154
2155                if Is_Prival (Ent) then
2156                   Ent := Prival_Link (Ent);
2157                end if;
2158
2159                if Is_Protected_Type (Scope (Ent)) then
2160                   return Scope (Ent);
2161                end if;
2162             end;
2163          end if;
2164
2165          --  For indexed and selected components, recursively check the prefix
2166
2167          if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
2168             return Enclosing_Protected_Type (Prefix (Obj));
2169
2170          --  The object does not denote a protected component
2171
2172          else
2173             return Empty;
2174          end if;
2175       end Enclosing_Protected_Type;
2176
2177       -------------------------
2178       -- Is_Public_Operation --
2179       -------------------------
2180
2181       function Is_Public_Operation return Boolean is
2182          S : Entity_Id;
2183          E : Entity_Id;
2184
2185       begin
2186          S := Current_Scope;
2187          while Present (S)
2188            and then S /= Pref_Encl_Typ
2189          loop
2190             if Scope (S) = Pref_Encl_Typ then
2191                E := First_Entity (Pref_Encl_Typ);
2192                while Present (E)
2193                  and then E /= First_Private_Entity (Pref_Encl_Typ)
2194                loop
2195                   if E = S then
2196                      return True;
2197                   end if;
2198                   Next_Entity (E);
2199                end loop;
2200             end if;
2201
2202             S := Scope (S);
2203          end loop;
2204
2205          return False;
2206       end Is_Public_Operation;
2207
2208    --  Start of processing for Check_Unprotected_Access
2209
2210    begin
2211       if Nkind (Expr) = N_Attribute_Reference
2212         and then Attribute_Name (Expr) = Name_Unchecked_Access
2213       then
2214          Cont_Encl_Typ := Enclosing_Protected_Type (Context);
2215          Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
2216
2217          --  Check whether we are trying to export a protected component to a
2218          --  context with an equal or lower access level.
2219
2220          if Present (Pref_Encl_Typ)
2221            and then No (Cont_Encl_Typ)
2222            and then Is_Public_Operation
2223            and then Scope_Depth (Pref_Encl_Typ) >=
2224                       Object_Access_Level (Context)
2225          then
2226             Error_Msg_N
2227               ("??possible unprotected access to protected data", Expr);
2228          end if;
2229       end if;
2230    end Check_Unprotected_Access;
2231
2232    ---------------
2233    -- Check_VMS --
2234    ---------------
2235
2236    procedure Check_VMS (Construct : Node_Id) is
2237    begin
2238       if not OpenVMS_On_Target then
2239          Error_Msg_N
2240            ("this construct is allowed only in Open'V'M'S", Construct);
2241       end if;
2242    end Check_VMS;
2243
2244    ------------------------
2245    -- Collect_Interfaces --
2246    ------------------------
2247
2248    procedure Collect_Interfaces
2249      (T               : Entity_Id;
2250       Ifaces_List     : out Elist_Id;
2251       Exclude_Parents : Boolean := False;
2252       Use_Full_View   : Boolean := True)
2253    is
2254       procedure Collect (Typ : Entity_Id);
2255       --  Subsidiary subprogram used to traverse the whole list
2256       --  of directly and indirectly implemented interfaces
2257
2258       -------------
2259       -- Collect --
2260       -------------
2261
2262       procedure Collect (Typ : Entity_Id) is
2263          Ancestor   : Entity_Id;
2264          Full_T     : Entity_Id;
2265          Id         : Node_Id;
2266          Iface      : Entity_Id;
2267
2268       begin
2269          Full_T := Typ;
2270
2271          --  Handle private types
2272
2273          if Use_Full_View
2274            and then Is_Private_Type (Typ)
2275            and then Present (Full_View (Typ))
2276          then
2277             Full_T := Full_View (Typ);
2278          end if;
2279
2280          --  Include the ancestor if we are generating the whole list of
2281          --  abstract interfaces.
2282
2283          if Etype (Full_T) /= Typ
2284
2285             --  Protect the frontend against wrong sources. For example:
2286
2287             --    package P is
2288             --      type A is tagged null record;
2289             --      type B is new A with private;
2290             --      type C is new A with private;
2291             --    private
2292             --      type B is new C with null record;
2293             --      type C is new B with null record;
2294             --    end P;
2295
2296            and then Etype (Full_T) /= T
2297          then
2298             Ancestor := Etype (Full_T);
2299             Collect (Ancestor);
2300
2301             if Is_Interface (Ancestor)
2302               and then not Exclude_Parents
2303             then
2304                Append_Unique_Elmt (Ancestor, Ifaces_List);
2305             end if;
2306          end if;
2307
2308          --  Traverse the graph of ancestor interfaces
2309
2310          if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
2311             Id := First (Abstract_Interface_List (Full_T));
2312             while Present (Id) loop
2313                Iface := Etype (Id);
2314
2315                --  Protect against wrong uses. For example:
2316                --    type I is interface;
2317                --    type O is tagged null record;
2318                --    type Wrong is new I and O with null record; -- ERROR
2319
2320                if Is_Interface (Iface) then
2321                   if Exclude_Parents
2322                     and then Etype (T) /= T
2323                     and then Interface_Present_In_Ancestor (Etype (T), Iface)
2324                   then
2325                      null;
2326                   else
2327                      Collect (Iface);
2328                      Append_Unique_Elmt (Iface, Ifaces_List);
2329                   end if;
2330                end if;
2331
2332                Next (Id);
2333             end loop;
2334          end if;
2335       end Collect;
2336
2337    --  Start of processing for Collect_Interfaces
2338
2339    begin
2340       pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
2341       Ifaces_List := New_Elmt_List;
2342       Collect (T);
2343    end Collect_Interfaces;
2344
2345    ----------------------------------
2346    -- Collect_Interface_Components --
2347    ----------------------------------
2348
2349    procedure Collect_Interface_Components
2350      (Tagged_Type     : Entity_Id;
2351       Components_List : out Elist_Id)
2352    is
2353       procedure Collect (Typ : Entity_Id);
2354       --  Subsidiary subprogram used to climb to the parents
2355
2356       -------------
2357       -- Collect --
2358       -------------
2359
2360       procedure Collect (Typ : Entity_Id) is
2361          Tag_Comp   : Entity_Id;
2362          Parent_Typ : Entity_Id;
2363
2364       begin
2365          --  Handle private types
2366
2367          if Present (Full_View (Etype (Typ))) then
2368             Parent_Typ := Full_View (Etype (Typ));
2369          else
2370             Parent_Typ := Etype (Typ);
2371          end if;
2372
2373          if Parent_Typ /= Typ
2374
2375             --  Protect the frontend against wrong sources. For example:
2376
2377             --    package P is
2378             --      type A is tagged null record;
2379             --      type B is new A with private;
2380             --      type C is new A with private;
2381             --    private
2382             --      type B is new C with null record;
2383             --      type C is new B with null record;
2384             --    end P;
2385
2386            and then Parent_Typ /= Tagged_Type
2387          then
2388             Collect (Parent_Typ);
2389          end if;
2390
2391          --  Collect the components containing tags of secondary dispatch
2392          --  tables.
2393
2394          Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
2395          while Present (Tag_Comp) loop
2396             pragma Assert (Present (Related_Type (Tag_Comp)));
2397             Append_Elmt (Tag_Comp, Components_List);
2398
2399             Tag_Comp := Next_Tag_Component (Tag_Comp);
2400          end loop;
2401       end Collect;
2402
2403    --  Start of processing for Collect_Interface_Components
2404
2405    begin
2406       pragma Assert (Ekind (Tagged_Type) = E_Record_Type
2407         and then Is_Tagged_Type (Tagged_Type));
2408
2409       Components_List := New_Elmt_List;
2410       Collect (Tagged_Type);
2411    end Collect_Interface_Components;
2412
2413    -----------------------------
2414    -- Collect_Interfaces_Info --
2415    -----------------------------
2416
2417    procedure Collect_Interfaces_Info
2418      (T               : Entity_Id;
2419       Ifaces_List     : out Elist_Id;
2420       Components_List : out Elist_Id;
2421       Tags_List       : out Elist_Id)
2422    is
2423       Comps_List : Elist_Id;
2424       Comp_Elmt  : Elmt_Id;
2425       Comp_Iface : Entity_Id;
2426       Iface_Elmt : Elmt_Id;
2427       Iface      : Entity_Id;
2428
2429       function Search_Tag (Iface : Entity_Id) return Entity_Id;
2430       --  Search for the secondary tag associated with the interface type
2431       --  Iface that is implemented by T.
2432
2433       ----------------
2434       -- Search_Tag --
2435       ----------------
2436
2437       function Search_Tag (Iface : Entity_Id) return Entity_Id is
2438          ADT : Elmt_Id;
2439       begin
2440          if not Is_CPP_Class (T) then
2441             ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
2442          else
2443             ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
2444          end if;
2445
2446          while Present (ADT)
2447             and then Is_Tag (Node (ADT))
2448             and then Related_Type (Node (ADT)) /= Iface
2449          loop
2450             --  Skip secondary dispatch table referencing thunks to user
2451             --  defined primitives covered by this interface.
2452
2453             pragma Assert (Has_Suffix (Node (ADT), 'P'));
2454             Next_Elmt (ADT);
2455
2456             --  Skip secondary dispatch tables of Ada types
2457
2458             if not Is_CPP_Class (T) then
2459
2460                --  Skip secondary dispatch table referencing thunks to
2461                --  predefined primitives.
2462
2463                pragma Assert (Has_Suffix (Node (ADT), 'Y'));
2464                Next_Elmt (ADT);
2465
2466                --  Skip secondary dispatch table referencing user-defined
2467                --  primitives covered by this interface.
2468
2469                pragma Assert (Has_Suffix (Node (ADT), 'D'));
2470                Next_Elmt (ADT);
2471
2472                --  Skip secondary dispatch table referencing predefined
2473                --  primitives.
2474
2475                pragma Assert (Has_Suffix (Node (ADT), 'Z'));
2476                Next_Elmt (ADT);
2477             end if;
2478          end loop;
2479
2480          pragma Assert (Is_Tag (Node (ADT)));
2481          return Node (ADT);
2482       end Search_Tag;
2483
2484    --  Start of processing for Collect_Interfaces_Info
2485
2486    begin
2487       Collect_Interfaces (T, Ifaces_List);
2488       Collect_Interface_Components (T, Comps_List);
2489
2490       --  Search for the record component and tag associated with each
2491       --  interface type of T.
2492
2493       Components_List := New_Elmt_List;
2494       Tags_List       := New_Elmt_List;
2495
2496       Iface_Elmt := First_Elmt (Ifaces_List);
2497       while Present (Iface_Elmt) loop
2498          Iface := Node (Iface_Elmt);
2499
2500          --  Associate the primary tag component and the primary dispatch table
2501          --  with all the interfaces that are parents of T
2502
2503          if Is_Ancestor (Iface, T, Use_Full_View => True) then
2504             Append_Elmt (First_Tag_Component (T), Components_List);
2505             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
2506
2507          --  Otherwise search for the tag component and secondary dispatch
2508          --  table of Iface
2509
2510          else
2511             Comp_Elmt := First_Elmt (Comps_List);
2512             while Present (Comp_Elmt) loop
2513                Comp_Iface := Related_Type (Node (Comp_Elmt));
2514
2515                if Comp_Iface = Iface
2516                  or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
2517                then
2518                   Append_Elmt (Node (Comp_Elmt), Components_List);
2519                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
2520                   exit;
2521                end if;
2522
2523                Next_Elmt (Comp_Elmt);
2524             end loop;
2525             pragma Assert (Present (Comp_Elmt));
2526          end if;
2527
2528          Next_Elmt (Iface_Elmt);
2529       end loop;
2530    end Collect_Interfaces_Info;
2531
2532    ---------------------
2533    -- Collect_Parents --
2534    ---------------------
2535
2536    procedure Collect_Parents
2537      (T             : Entity_Id;
2538       List          : out Elist_Id;
2539       Use_Full_View : Boolean := True)
2540    is
2541       Current_Typ : Entity_Id := T;
2542       Parent_Typ  : Entity_Id;
2543
2544    begin
2545       List := New_Elmt_List;
2546
2547       --  No action if the if the type has no parents
2548
2549       if T = Etype (T) then
2550          return;
2551       end if;
2552
2553       loop
2554          Parent_Typ := Etype (Current_Typ);
2555
2556          if Is_Private_Type (Parent_Typ)
2557            and then Present (Full_View (Parent_Typ))
2558            and then Use_Full_View
2559          then
2560             Parent_Typ := Full_View (Base_Type (Parent_Typ));
2561          end if;
2562
2563          Append_Elmt (Parent_Typ, List);
2564
2565          exit when Parent_Typ = Current_Typ;
2566          Current_Typ := Parent_Typ;
2567       end loop;
2568    end Collect_Parents;
2569
2570    ----------------------------------
2571    -- Collect_Primitive_Operations --
2572    ----------------------------------
2573
2574    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
2575       B_Type         : constant Entity_Id := Base_Type (T);
2576       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
2577       B_Scope        : Entity_Id          := Scope (B_Type);
2578       Op_List        : Elist_Id;
2579       Formal         : Entity_Id;
2580       Is_Prim        : Boolean;
2581       Is_Type_In_Pkg : Boolean;
2582       Formal_Derived : Boolean := False;
2583       Id             : Entity_Id;
2584
2585       function Match (E : Entity_Id) return Boolean;
2586       --  True if E's base type is B_Type, or E is of an anonymous access type
2587       --  and the base type of its designated type is B_Type.
2588
2589       -----------
2590       -- Match --
2591       -----------
2592
2593       function Match (E : Entity_Id) return Boolean is
2594          Etyp : Entity_Id := Etype (E);
2595
2596       begin
2597          if Ekind (Etyp) = E_Anonymous_Access_Type then
2598             Etyp := Designated_Type (Etyp);
2599          end if;
2600
2601          return Base_Type (Etyp) = B_Type;
2602       end Match;
2603
2604    --  Start of processing for Collect_Primitive_Operations
2605
2606    begin
2607       --  For tagged types, the primitive operations are collected as they
2608       --  are declared, and held in an explicit list which is simply returned.
2609
2610       if Is_Tagged_Type (B_Type) then
2611          return Primitive_Operations (B_Type);
2612
2613       --  An untagged generic type that is a derived type inherits the
2614       --  primitive operations of its parent type. Other formal types only
2615       --  have predefined operators, which are not explicitly represented.
2616
2617       elsif Is_Generic_Type (B_Type) then
2618          if Nkind (B_Decl) = N_Formal_Type_Declaration
2619            and then Nkind (Formal_Type_Definition (B_Decl))
2620              = N_Formal_Derived_Type_Definition
2621          then
2622             Formal_Derived := True;
2623          else
2624             return New_Elmt_List;
2625          end if;
2626       end if;
2627
2628       Op_List := New_Elmt_List;
2629
2630       if B_Scope = Standard_Standard then
2631          if B_Type = Standard_String then
2632             Append_Elmt (Standard_Op_Concat, Op_List);
2633
2634          elsif B_Type = Standard_Wide_String then
2635             Append_Elmt (Standard_Op_Concatw, Op_List);
2636
2637          else
2638             null;
2639          end if;
2640
2641       --  Locate the primitive subprograms of the type
2642
2643       else
2644          --  The primitive operations appear after the base type, except
2645          --  if the derivation happens within the private part of B_Scope
2646          --  and the type is a private type, in which case both the type
2647          --  and some primitive operations may appear before the base
2648          --  type, and the list of candidates starts after the type.
2649
2650          if In_Open_Scopes (B_Scope)
2651            and then Scope (T) = B_Scope
2652            and then In_Private_Part (B_Scope)
2653          then
2654             Id := Next_Entity (T);
2655          else
2656             Id := Next_Entity (B_Type);
2657          end if;
2658
2659          --  Set flag if this is a type in a package spec
2660
2661          Is_Type_In_Pkg :=
2662            Is_Package_Or_Generic_Package (B_Scope)
2663              and then
2664                Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
2665                                                            N_Package_Body;
2666
2667          while Present (Id) loop
2668
2669             --  Test whether the result type or any of the parameter types of
2670             --  each subprogram following the type match that type when the
2671             --  type is declared in a package spec, is a derived type, or the
2672             --  subprogram is marked as primitive. (The Is_Primitive test is
2673             --  needed to find primitives of nonderived types in declarative
2674             --  parts that happen to override the predefined "=" operator.)
2675
2676             --  Note that generic formal subprograms are not considered to be
2677             --  primitive operations and thus are never inherited.
2678
2679             if Is_Overloadable (Id)
2680               and then (Is_Type_In_Pkg
2681                          or else Is_Derived_Type (B_Type)
2682                          or else Is_Primitive (Id))
2683               and then Nkind (Parent (Parent (Id)))
2684                          not in N_Formal_Subprogram_Declaration
2685             then
2686                Is_Prim := False;
2687
2688                if Match (Id) then
2689                   Is_Prim := True;
2690
2691                else
2692                   Formal := First_Formal (Id);
2693                   while Present (Formal) loop
2694                      if Match (Formal) then
2695                         Is_Prim := True;
2696                         exit;
2697                      end if;
2698
2699                      Next_Formal (Formal);
2700                   end loop;
2701                end if;
2702
2703                --  For a formal derived type, the only primitives are the ones
2704                --  inherited from the parent type. Operations appearing in the
2705                --  package declaration are not primitive for it.
2706
2707                if Is_Prim
2708                  and then (not Formal_Derived
2709                             or else Present (Alias (Id)))
2710                then
2711                   --  In the special case of an equality operator aliased to
2712                   --  an overriding dispatching equality belonging to the same
2713                   --  type, we don't include it in the list of primitives.
2714                   --  This avoids inheriting multiple equality operators when
2715                   --  deriving from untagged private types whose full type is
2716                   --  tagged, which can otherwise cause ambiguities. Note that
2717                   --  this should only happen for this kind of untagged parent
2718                   --  type, since normally dispatching operations are inherited
2719                   --  using the type's Primitive_Operations list.
2720
2721                   if Chars (Id) = Name_Op_Eq
2722                     and then Is_Dispatching_Operation (Id)
2723                     and then Present (Alias (Id))
2724                     and then Present (Overridden_Operation (Alias (Id)))
2725                     and then Base_Type (Etype (First_Entity (Id))) =
2726                                Base_Type (Etype (First_Entity (Alias (Id))))
2727                   then
2728                      null;
2729
2730                   --  Include the subprogram in the list of primitives
2731
2732                   else
2733                      Append_Elmt (Id, Op_List);
2734                   end if;
2735                end if;
2736             end if;
2737
2738             Next_Entity (Id);
2739
2740             --  For a type declared in System, some of its operations may
2741             --  appear in the target-specific extension to System.
2742
2743             if No (Id)
2744               and then B_Scope = RTU_Entity (System)
2745               and then Present_System_Aux
2746             then
2747                B_Scope := System_Aux_Id;
2748                Id := First_Entity (System_Aux_Id);
2749             end if;
2750          end loop;
2751       end if;
2752
2753       return Op_List;
2754    end Collect_Primitive_Operations;
2755
2756    -----------------------------------
2757    -- Compile_Time_Constraint_Error --
2758    -----------------------------------
2759
2760    function Compile_Time_Constraint_Error
2761      (N    : Node_Id;
2762       Msg  : String;
2763       Ent  : Entity_Id  := Empty;
2764       Loc  : Source_Ptr := No_Location;
2765       Warn : Boolean    := False) return Node_Id
2766    is
2767       Msgc : String (1 .. Msg'Length + 3);
2768       --  Copy of message, with room for possible ?? and ! at end
2769
2770       Msgl : Natural;
2771       Wmsg : Boolean;
2772       P    : Node_Id;
2773       OldP : Node_Id;
2774       Msgs : Boolean;
2775       Eloc : Source_Ptr;
2776
2777    begin
2778       --  A static constraint error in an instance body is not a fatal error.
2779       --  we choose to inhibit the message altogether, because there is no
2780       --  obvious node (for now) on which to post it. On the other hand the
2781       --  offending node must be replaced with a constraint_error in any case.
2782
2783       --  No messages are generated if we already posted an error on this node
2784
2785       if not Error_Posted (N) then
2786          if Loc /= No_Location then
2787             Eloc := Loc;
2788          else
2789             Eloc := Sloc (N);
2790          end if;
2791
2792          Msgc (1 .. Msg'Length) := Msg;
2793          Msgl := Msg'Length;
2794
2795          --  Message is a warning, even in Ada 95 case
2796
2797          if Msg (Msg'Last) = '?' then
2798             Wmsg := True;
2799
2800          --  In Ada 83, all messages are warnings. In the private part and
2801          --  the body of an instance, constraint_checks are only warnings.
2802          --  We also make this a warning if the Warn parameter is set.
2803
2804          elsif Warn
2805            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
2806          then
2807             Msgl := Msgl + 1;
2808             Msgc (Msgl) := '?';
2809             Msgl := Msgl + 1;
2810             Msgc (Msgl) := '?';
2811             Wmsg := True;
2812
2813          elsif In_Instance_Not_Visible then
2814             Msgl := Msgl + 1;
2815             Msgc (Msgl) := '?';
2816             Msgl := Msgl + 1;
2817             Msgc (Msgl) := '?';
2818             Wmsg := True;
2819
2820          --  Otherwise we have a real error message (Ada 95 static case)
2821          --  and we make this an unconditional message. Note that in the
2822          --  warning case we do not make the message unconditional, it seems
2823          --  quite reasonable to delete messages like this (about exceptions
2824          --  that will be raised) in dead code.
2825
2826          else
2827             Wmsg := False;
2828             Msgl := Msgl + 1;
2829             Msgc (Msgl) := '!';
2830          end if;
2831
2832          --  Should we generate a warning? The answer is not quite yes. The
2833          --  very annoying exception occurs in the case of a short circuit
2834          --  operator where the left operand is static and decisive. Climb
2835          --  parents to see if that is the case we have here. Conditional
2836          --  expressions with decisive conditions are a similar situation.
2837
2838          Msgs := True;
2839          P := N;
2840          loop
2841             OldP := P;
2842             P := Parent (P);
2843
2844             --  And then with False as left operand
2845
2846             if Nkind (P) = N_And_Then
2847               and then Compile_Time_Known_Value (Left_Opnd (P))
2848               and then Is_False (Expr_Value (Left_Opnd (P)))
2849             then
2850                Msgs := False;
2851                exit;
2852
2853             --  OR ELSE with True as left operand
2854
2855             elsif Nkind (P) = N_Or_Else
2856               and then Compile_Time_Known_Value (Left_Opnd (P))
2857               and then Is_True (Expr_Value (Left_Opnd (P)))
2858             then
2859                Msgs := False;
2860                exit;
2861
2862             --  If expression
2863
2864             elsif Nkind (P) = N_If_Expression then
2865                declare
2866                   Cond : constant Node_Id := First (Expressions (P));
2867                   Texp : constant Node_Id := Next (Cond);
2868                   Fexp : constant Node_Id := Next (Texp);
2869
2870                begin
2871                   if Compile_Time_Known_Value (Cond) then
2872
2873                      --  Condition is True and we are in the right operand
2874
2875                      if Is_True (Expr_Value (Cond))
2876                        and then OldP = Fexp
2877                      then
2878                         Msgs := False;
2879                         exit;
2880
2881                      --  Condition is False and we are in the left operand
2882
2883                      elsif Is_False (Expr_Value (Cond))
2884                        and then OldP = Texp
2885                      then
2886                         Msgs := False;
2887                         exit;
2888                      end if;
2889                   end if;
2890                end;
2891
2892             --  Special case for component association in aggregates, where
2893             --  we want to keep climbing up to the parent aggregate.
2894
2895             elsif Nkind (P) = N_Component_Association
2896               and then Nkind (Parent (P)) = N_Aggregate
2897             then
2898                null;
2899
2900             --  Keep going if within subexpression
2901
2902             else
2903                exit when Nkind (P) not in N_Subexpr;
2904             end if;
2905          end loop;
2906
2907          if Msgs then
2908             if Present (Ent) then
2909                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
2910             else
2911                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
2912             end if;
2913
2914             if Wmsg then
2915
2916                --  Check whether the context is an Init_Proc
2917
2918                if Inside_Init_Proc then
2919                   declare
2920                      Conc_Typ : constant Entity_Id :=
2921                                   Corresponding_Concurrent_Type
2922                                     (Entity (Parameter_Type (First
2923                                       (Parameter_Specifications
2924                                         (Parent (Current_Scope))))));
2925
2926                   begin
2927                      --  Don't complain if the corresponding concurrent type
2928                      --  doesn't come from source (i.e. a single task/protected
2929                      --  object).
2930
2931                      if Present (Conc_Typ)
2932                        and then not Comes_From_Source (Conc_Typ)
2933                      then
2934                         Error_Msg_NEL
2935                           ("\??& will be raised at run time",
2936                            N, Standard_Constraint_Error, Eloc);
2937
2938                      else
2939                         Error_Msg_NEL
2940                           ("\??& will be raised for objects of this type",
2941                            N, Standard_Constraint_Error, Eloc);
2942                      end if;
2943                   end;
2944
2945                else
2946                   Error_Msg_NEL
2947                     ("\??& will be raised at run time",
2948                      N, Standard_Constraint_Error, Eloc);
2949                end if;
2950
2951             else
2952                Error_Msg
2953                  ("\static expression fails Constraint_Check", Eloc);
2954                Set_Error_Posted (N);
2955             end if;
2956          end if;
2957       end if;
2958
2959       return N;
2960    end Compile_Time_Constraint_Error;
2961
2962    -----------------------
2963    -- Conditional_Delay --
2964    -----------------------
2965
2966    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
2967    begin
2968       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
2969          Set_Has_Delayed_Freeze (New_Ent);
2970       end if;
2971    end Conditional_Delay;
2972
2973    -------------------------
2974    -- Copy_Component_List --
2975    -------------------------
2976
2977    function Copy_Component_List
2978      (R_Typ : Entity_Id;
2979       Loc   : Source_Ptr) return List_Id
2980    is
2981       Comp  : Node_Id;
2982       Comps : constant List_Id := New_List;
2983
2984    begin
2985       Comp := First_Component (Underlying_Type (R_Typ));
2986       while Present (Comp) loop
2987          if Comes_From_Source (Comp) then
2988             declare
2989                Comp_Decl : constant Node_Id := Declaration_Node (Comp);
2990             begin
2991                Append_To (Comps,
2992                  Make_Component_Declaration (Loc,
2993                    Defining_Identifier =>
2994                      Make_Defining_Identifier (Loc, Chars (Comp)),
2995                    Component_Definition =>
2996                      New_Copy_Tree
2997                        (Component_Definition (Comp_Decl), New_Sloc => Loc)));
2998             end;
2999          end if;
3000
3001          Next_Component (Comp);
3002       end loop;
3003
3004       return Comps;
3005    end Copy_Component_List;
3006
3007    -------------------------
3008    -- Copy_Parameter_List --
3009    -------------------------
3010
3011    function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
3012       Loc    : constant Source_Ptr := Sloc (Subp_Id);
3013       Plist  : List_Id;
3014       Formal : Entity_Id;
3015
3016    begin
3017       if No (First_Formal (Subp_Id)) then
3018          return No_List;
3019       else
3020          Plist := New_List;
3021          Formal := First_Formal (Subp_Id);
3022          while Present (Formal) loop
3023             Append
3024               (Make_Parameter_Specification (Loc,
3025                 Defining_Identifier =>
3026                   Make_Defining_Identifier (Sloc (Formal),
3027                     Chars => Chars (Formal)),
3028                 In_Present  => In_Present (Parent (Formal)),
3029                 Out_Present => Out_Present (Parent (Formal)),
3030              Parameter_Type =>
3031                   New_Reference_To (Etype (Formal), Loc),
3032                 Expression =>
3033                   New_Copy_Tree (Expression (Parent (Formal)))),
3034               Plist);
3035
3036             Next_Formal (Formal);
3037          end loop;
3038       end if;
3039
3040       return Plist;
3041    end Copy_Parameter_List;
3042
3043    --------------------------------
3044    -- Corresponding_Generic_Type --
3045    --------------------------------
3046
3047    function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
3048       Inst : Entity_Id;
3049       Gen  : Entity_Id;
3050       Typ  : Entity_Id;
3051
3052    begin
3053       if not Is_Generic_Actual_Type (T) then
3054          return Any_Type;
3055
3056       --  If the actual is the actual of an enclosing instance, resolution
3057       --  was correct in the generic.
3058
3059       elsif Nkind (Parent (T)) = N_Subtype_Declaration
3060         and then Is_Entity_Name (Subtype_Indication (Parent (T)))
3061         and then
3062           Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
3063       then
3064          return Any_Type;
3065
3066       else
3067          Inst := Scope (T);
3068
3069          if Is_Wrapper_Package (Inst) then
3070             Inst := Related_Instance (Inst);
3071          end if;
3072
3073          Gen  :=
3074            Generic_Parent
3075              (Specification (Unit_Declaration_Node (Inst)));
3076
3077          --  Generic actual has the same name as the corresponding formal
3078
3079          Typ := First_Entity (Gen);
3080          while Present (Typ) loop
3081             if Chars (Typ) = Chars (T) then
3082                return Typ;
3083             end if;
3084
3085             Next_Entity (Typ);
3086          end loop;
3087
3088          return Any_Type;
3089       end if;
3090    end Corresponding_Generic_Type;
3091
3092    --------------------
3093    -- Current_Entity --
3094    --------------------
3095
3096    --  The currently visible definition for a given identifier is the
3097    --  one most chained at the start of the visibility chain, i.e. the
3098    --  one that is referenced by the Node_Id value of the name of the
3099    --  given identifier.
3100
3101    function Current_Entity (N : Node_Id) return Entity_Id is
3102    begin
3103       return Get_Name_Entity_Id (Chars (N));
3104    end Current_Entity;
3105
3106    -----------------------------
3107    -- Current_Entity_In_Scope --
3108    -----------------------------
3109
3110    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
3111       E  : Entity_Id;
3112       CS : constant Entity_Id := Current_Scope;
3113
3114       Transient_Case : constant Boolean := Scope_Is_Transient;
3115
3116    begin
3117       E := Get_Name_Entity_Id (Chars (N));
3118       while Present (E)
3119         and then Scope (E) /= CS
3120         and then (not Transient_Case or else Scope (E) /= Scope (CS))
3121       loop
3122          E := Homonym (E);
3123       end loop;
3124
3125       return E;
3126    end Current_Entity_In_Scope;
3127
3128    -------------------
3129    -- Current_Scope --
3130    -------------------
3131
3132    function Current_Scope return Entity_Id is
3133    begin
3134       if Scope_Stack.Last = -1 then
3135          return Standard_Standard;
3136       else
3137          declare
3138             C : constant Entity_Id :=
3139                   Scope_Stack.Table (Scope_Stack.Last).Entity;
3140          begin
3141             if Present (C) then
3142                return C;
3143             else
3144                return Standard_Standard;
3145             end if;
3146          end;
3147       end if;
3148    end Current_Scope;
3149
3150    ------------------------
3151    -- Current_Subprogram --
3152    ------------------------
3153
3154    function Current_Subprogram return Entity_Id is
3155       Scop : constant Entity_Id := Current_Scope;
3156    begin
3157       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
3158          return Scop;
3159       else
3160          return Enclosing_Subprogram (Scop);
3161       end if;
3162    end Current_Subprogram;
3163
3164    ----------------------------------
3165    -- Deepest_Type_Access_Level --
3166    ----------------------------------
3167
3168    function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
3169    begin
3170       if Ekind (Typ) = E_Anonymous_Access_Type
3171         and then not Is_Local_Anonymous_Access (Typ)
3172         and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
3173       then
3174          --  Typ is the type of an Ada 2012 stand-alone object of an anonymous
3175          --  access type.
3176
3177          return
3178            Scope_Depth (Enclosing_Dynamic_Scope
3179                          (Defining_Identifier
3180                            (Associated_Node_For_Itype (Typ))));
3181
3182       --  For generic formal type, return Int'Last (infinite).
3183       --  See comment preceding Is_Generic_Type call in Type_Access_Level.
3184
3185       elsif Is_Generic_Type (Root_Type (Typ)) then
3186          return UI_From_Int (Int'Last);
3187
3188       else
3189          return Type_Access_Level (Typ);
3190       end if;
3191    end Deepest_Type_Access_Level;
3192
3193    ---------------------
3194    -- Defining_Entity --
3195    ---------------------
3196
3197    function Defining_Entity (N : Node_Id) return Entity_Id is
3198       K   : constant Node_Kind := Nkind (N);
3199       Err : Entity_Id := Empty;
3200
3201    begin
3202       case K is
3203          when
3204            N_Subprogram_Declaration                 |
3205            N_Abstract_Subprogram_Declaration        |
3206            N_Subprogram_Body                        |
3207            N_Package_Declaration                    |
3208            N_Subprogram_Renaming_Declaration        |
3209            N_Subprogram_Body_Stub                   |
3210            N_Generic_Subprogram_Declaration         |
3211            N_Generic_Package_Declaration            |
3212            N_Formal_Subprogram_Declaration          |
3213            N_Expression_Function
3214          =>
3215             return Defining_Entity (Specification (N));
3216
3217          when
3218            N_Component_Declaration                  |
3219            N_Defining_Program_Unit_Name             |
3220            N_Discriminant_Specification             |
3221            N_Entry_Body                             |
3222            N_Entry_Declaration                      |
3223            N_Entry_Index_Specification              |
3224            N_Exception_Declaration                  |
3225            N_Exception_Renaming_Declaration         |
3226            N_Formal_Object_Declaration              |
3227            N_Formal_Package_Declaration             |
3228            N_Formal_Type_Declaration                |
3229            N_Full_Type_Declaration                  |
3230            N_Implicit_Label_Declaration             |
3231            N_Incomplete_Type_Declaration            |
3232            N_Loop_Parameter_Specification           |
3233            N_Number_Declaration                     |
3234            N_Object_Declaration                     |
3235            N_Object_Renaming_Declaration            |
3236            N_Package_Body_Stub                      |
3237            N_Parameter_Specification                |
3238            N_Private_Extension_Declaration          |
3239            N_Private_Type_Declaration               |
3240            N_Protected_Body                         |
3241            N_Protected_Body_Stub                    |
3242            N_Protected_Type_Declaration             |
3243            N_Single_Protected_Declaration           |
3244            N_Single_Task_Declaration                |
3245            N_Subtype_Declaration                    |
3246            N_Task_Body                              |
3247            N_Task_Body_Stub                         |
3248            N_Task_Type_Declaration
3249          =>
3250             return Defining_Identifier (N);
3251
3252          when N_Subunit =>
3253             return Defining_Entity (Proper_Body (N));
3254
3255          when
3256            N_Function_Instantiation                 |
3257            N_Function_Specification                 |
3258            N_Generic_Function_Renaming_Declaration  |
3259            N_Generic_Package_Renaming_Declaration   |
3260            N_Generic_Procedure_Renaming_Declaration |
3261            N_Package_Body                           |
3262            N_Package_Instantiation                  |
3263            N_Package_Renaming_Declaration           |
3264            N_Package_Specification                  |
3265            N_Procedure_Instantiation                |
3266            N_Procedure_Specification
3267          =>
3268             declare
3269                Nam : constant Node_Id := Defining_Unit_Name (N);
3270
3271             begin
3272                if Nkind (Nam) in N_Entity then
3273                   return Nam;
3274
3275                --  For Error, make up a name and attach to declaration
3276                --  so we can continue semantic analysis
3277
3278                elsif Nam = Error then
3279                   Err := Make_Temporary (Sloc (N), 'T');
3280                   Set_Defining_Unit_Name (N, Err);
3281
3282                   return Err;
3283                --  If not an entity, get defining identifier
3284
3285                else
3286                   return Defining_Identifier (Nam);
3287                end if;
3288             end;
3289
3290          when N_Block_Statement =>
3291             return Entity (Identifier (N));
3292
3293          when others =>
3294             raise Program_Error;
3295
3296       end case;
3297    end Defining_Entity;
3298
3299    --------------------------
3300    -- Denotes_Discriminant --
3301    --------------------------
3302
3303    function Denotes_Discriminant
3304      (N                : Node_Id;
3305       Check_Concurrent : Boolean := False) return Boolean
3306    is
3307       E : Entity_Id;
3308    begin
3309       if not Is_Entity_Name (N)
3310         or else No (Entity (N))
3311       then
3312          return False;
3313       else
3314          E := Entity (N);
3315       end if;
3316
3317       --  If we are checking for a protected type, the discriminant may have
3318       --  been rewritten as the corresponding discriminal of the original type
3319       --  or of the corresponding concurrent record, depending on whether we
3320       --  are in the spec or body of the protected type.
3321
3322       return Ekind (E) = E_Discriminant
3323         or else
3324           (Check_Concurrent
3325             and then Ekind (E) = E_In_Parameter
3326             and then Present (Discriminal_Link (E))
3327             and then
3328               (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
3329                 or else
3330                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
3331
3332    end Denotes_Discriminant;
3333
3334    -------------------------
3335    -- Denotes_Same_Object --
3336    -------------------------
3337
3338    function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
3339       Obj1 : Node_Id := A1;
3340       Obj2 : Node_Id := A2;
3341
3342       function Has_Prefix (N : Node_Id) return Boolean;
3343       --  Return True if N has attribute Prefix
3344
3345       function Is_Renaming (N : Node_Id) return Boolean;
3346       --  Return true if N names a renaming entity
3347
3348       function Is_Valid_Renaming (N : Node_Id) return Boolean;
3349       --  For renamings, return False if the prefix of any dereference within
3350       --  the renamed object_name is a variable, or any expression within the
3351       --  renamed object_name contains references to variables or calls on
3352       --  nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
3353
3354       ----------------
3355       -- Has_Prefix --
3356       ----------------
3357
3358       function Has_Prefix (N : Node_Id) return Boolean is
3359       begin
3360          return
3361            Nkind_In (N,
3362              N_Attribute_Reference,
3363              N_Expanded_Name,
3364              N_Explicit_Dereference,
3365              N_Indexed_Component,
3366              N_Reference,
3367              N_Selected_Component,
3368              N_Slice);
3369       end Has_Prefix;
3370
3371       -----------------
3372       -- Is_Renaming --
3373       -----------------
3374
3375       function Is_Renaming (N : Node_Id) return Boolean is
3376       begin
3377          return Is_Entity_Name (N)
3378            and then Present (Renamed_Entity (Entity (N)));
3379       end Is_Renaming;
3380
3381       -----------------------
3382       -- Is_Valid_Renaming --
3383       -----------------------
3384
3385       function Is_Valid_Renaming (N : Node_Id) return Boolean is
3386
3387          function Check_Renaming (N : Node_Id) return Boolean;
3388          --  Recursive function used to traverse all the prefixes of N
3389
3390          function Check_Renaming (N : Node_Id) return Boolean is
3391          begin
3392             if Is_Renaming (N)
3393               and then not Check_Renaming (Renamed_Entity (Entity (N)))
3394             then
3395                return False;
3396             end if;
3397
3398             if Nkind (N) = N_Indexed_Component then
3399                declare
3400                   Indx : Node_Id;
3401
3402                begin
3403                   Indx := First (Expressions (N));
3404                   while Present (Indx) loop
3405                      if not Is_OK_Static_Expression (Indx) then
3406                         return False;
3407                      end if;
3408
3409                      Next_Index (Indx);
3410                   end loop;
3411                end;
3412             end if;
3413
3414             if Has_Prefix (N) then
3415                declare
3416                   P : constant Node_Id := Prefix (N);
3417
3418                begin
3419                   if Nkind (N) = N_Explicit_Dereference
3420                     and then Is_Variable (P)
3421                   then
3422                      return False;
3423
3424                   elsif Is_Entity_Name (P)
3425                     and then Ekind (Entity (P)) = E_Function
3426                   then
3427                      return False;
3428
3429                   elsif Nkind (P) = N_Function_Call then
3430                      return False;
3431                   end if;
3432
3433                   --  Recursion to continue traversing the prefix of the
3434                   --  renaming expression
3435
3436                   return Check_Renaming (P);
3437                end;
3438             end if;
3439
3440             return True;
3441          end Check_Renaming;
3442
3443       --  Start of processing for Is_Valid_Renaming
3444
3445       begin
3446          return Check_Renaming (N);
3447       end Is_Valid_Renaming;
3448
3449    --  Start of processing for Denotes_Same_Object
3450
3451    begin
3452       --  Both names statically denote the same stand-alone object or parameter
3453       --  (RM 6.4.1(6.5/3))
3454
3455       if Is_Entity_Name (Obj1)
3456         and then Is_Entity_Name (Obj2)
3457         and then Entity (Obj1) = Entity (Obj2)
3458       then
3459          return True;
3460       end if;
3461
3462       --  For renamings, the prefix of any dereference within the renamed
3463       --  object_name is not a variable, and any expression within the
3464       --  renamed object_name contains no references to variables nor
3465       --  calls on nonstatic functions (RM 6.4.1(6.10/3)).
3466
3467       if Is_Renaming (Obj1) then
3468          if Is_Valid_Renaming (Obj1) then
3469             Obj1 := Renamed_Entity (Entity (Obj1));
3470          else
3471             return False;
3472          end if;
3473       end if;
3474
3475       if Is_Renaming (Obj2) then
3476          if Is_Valid_Renaming (Obj2) then
3477             Obj2 := Renamed_Entity (Entity (Obj2));
3478          else
3479             return False;
3480          end if;
3481       end if;
3482
3483       --  No match if not same node kind (such cases are handled by
3484       --  Denotes_Same_Prefix)
3485
3486       if Nkind (Obj1) /= Nkind (Obj2) then
3487          return False;
3488
3489       --  After handling valid renamings, one of the two names statically
3490       --  denoted a renaming declaration whose renamed object_name is known
3491       --  to denote the same object as the other (RM 6.4.1(6.10/3))
3492
3493       elsif Is_Entity_Name (Obj1) then
3494          if Is_Entity_Name (Obj2) then
3495             return Entity (Obj1) = Entity (Obj2);
3496          else
3497             return False;
3498          end if;
3499
3500       --  Both names are selected_components, their prefixes are known to
3501       --  denote the same object, and their selector_names denote the same
3502       --  component (RM 6.4.1(6.6/3)
3503
3504       elsif Nkind (Obj1) = N_Selected_Component then
3505          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3506            and then
3507          Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
3508
3509       --  Both names are dereferences and the dereferenced names are known to
3510       --  denote the same object (RM 6.4.1(6.7/3))
3511
3512       elsif Nkind (Obj1) = N_Explicit_Dereference then
3513          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
3514
3515       --  Both names are indexed_components, their prefixes are known to denote
3516       --  the same object, and each of the pairs of corresponding index values
3517       --  are either both static expressions with the same static value or both
3518       --  names that are known to denote the same object (RM 6.4.1(6.8/3))
3519
3520       elsif Nkind (Obj1) = N_Indexed_Component then
3521          if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
3522             return False;
3523          else
3524             declare
3525                Indx1 : Node_Id;
3526                Indx2 : Node_Id;
3527
3528             begin
3529                Indx1 := First (Expressions (Obj1));
3530                Indx2 := First (Expressions (Obj2));
3531                while Present (Indx1) loop
3532
3533                   --  Indexes must denote the same static value or same object
3534
3535                   if Is_OK_Static_Expression (Indx1) then
3536                      if not Is_OK_Static_Expression (Indx2) then
3537                         return False;
3538
3539                      elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
3540                         return False;
3541                      end if;
3542
3543                   elsif not Denotes_Same_Object (Indx1, Indx2) then
3544                      return False;
3545                   end if;
3546
3547                   Next (Indx1);
3548                   Next (Indx2);
3549                end loop;
3550
3551                return True;
3552             end;
3553          end if;
3554
3555       --  Both names are slices, their prefixes are known to denote the same
3556       --  object, and the two slices have statically matching index constraints
3557       --  (RM 6.4.1(6.9/3))
3558
3559       elsif Nkind (Obj1) = N_Slice
3560         and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
3561       then
3562          declare
3563             Lo1, Lo2, Hi1, Hi2 : Node_Id;
3564
3565          begin
3566             Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
3567             Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
3568
3569             --  Check whether bounds are statically identical. There is no
3570             --  attempt to detect partial overlap of slices.
3571
3572             return Denotes_Same_Object (Lo1, Lo2)
3573               and then Denotes_Same_Object (Hi1, Hi2);
3574          end;
3575
3576       --  In the recursion, literals appear as indexes.
3577
3578       elsif Nkind (Obj1) = N_Integer_Literal
3579         and then Nkind (Obj2) = N_Integer_Literal
3580       then
3581          return Intval (Obj1) = Intval (Obj2);
3582
3583       else
3584          return False;
3585       end if;
3586    end Denotes_Same_Object;
3587
3588    -------------------------
3589    -- Denotes_Same_Prefix --
3590    -------------------------
3591
3592    function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
3593
3594    begin
3595       if Is_Entity_Name (A1) then
3596          if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
3597            and then not Is_Access_Type (Etype (A1))
3598          then
3599             return Denotes_Same_Object (A1, Prefix (A2))
3600               or else Denotes_Same_Prefix (A1, Prefix (A2));
3601          else
3602             return False;
3603          end if;
3604
3605       elsif Is_Entity_Name (A2) then
3606          return Denotes_Same_Prefix (A1 => A2, A2 => A1);
3607
3608       elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
3609               and then
3610             Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
3611       then
3612          declare
3613             Root1, Root2 : Node_Id;
3614             Depth1, Depth2 : Int := 0;
3615
3616          begin
3617             Root1 := Prefix (A1);
3618             while not Is_Entity_Name (Root1) loop
3619                if not Nkind_In
3620                  (Root1, N_Selected_Component, N_Indexed_Component)
3621                then
3622                   return False;
3623                else
3624                   Root1 := Prefix (Root1);
3625                end if;
3626
3627                Depth1 := Depth1 + 1;
3628             end loop;
3629
3630             Root2 := Prefix (A2);
3631             while not Is_Entity_Name (Root2) loop
3632                if not Nkind_In
3633                  (Root2, N_Selected_Component, N_Indexed_Component)
3634                then
3635                   return False;
3636                else
3637                   Root2 := Prefix (Root2);
3638                end if;
3639
3640                Depth2 := Depth2 + 1;
3641             end loop;
3642
3643             --  If both have the same depth and they do not denote the same
3644             --  object, they are disjoint and no warning is needed.
3645
3646             if Depth1 = Depth2 then
3647                return False;
3648
3649             elsif Depth1 > Depth2 then
3650                Root1 := Prefix (A1);
3651                for I in 1 .. Depth1 - Depth2 - 1 loop
3652                   Root1 := Prefix (Root1);
3653                end loop;
3654
3655                return Denotes_Same_Object (Root1, A2);
3656
3657             else
3658                Root2 := Prefix (A2);
3659                for I in 1 .. Depth2 - Depth1 - 1 loop
3660                   Root2 := Prefix (Root2);
3661                end loop;
3662
3663                return Denotes_Same_Object (A1, Root2);
3664             end if;
3665          end;
3666
3667       else
3668          return False;
3669       end if;
3670    end Denotes_Same_Prefix;
3671
3672    ----------------------
3673    -- Denotes_Variable --
3674    ----------------------
3675
3676    function Denotes_Variable (N : Node_Id) return Boolean is
3677    begin
3678       return Is_Variable (N) and then Paren_Count (N) = 0;
3679    end Denotes_Variable;
3680
3681    -----------------------------
3682    -- Depends_On_Discriminant --
3683    -----------------------------
3684
3685    function Depends_On_Discriminant (N : Node_Id) return Boolean is
3686       L : Node_Id;
3687       H : Node_Id;
3688
3689    begin
3690       Get_Index_Bounds (N, L, H);
3691       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
3692    end Depends_On_Discriminant;
3693
3694    -------------------------
3695    -- Designate_Same_Unit --
3696    -------------------------
3697
3698    function Designate_Same_Unit
3699      (Name1 : Node_Id;
3700       Name2 : Node_Id) return Boolean
3701    is
3702       K1 : constant Node_Kind := Nkind (Name1);
3703       K2 : constant Node_Kind := Nkind (Name2);
3704
3705       function Prefix_Node (N : Node_Id) return Node_Id;
3706       --  Returns the parent unit name node of a defining program unit name
3707       --  or the prefix if N is a selected component or an expanded name.
3708
3709       function Select_Node (N : Node_Id) return Node_Id;
3710       --  Returns the defining identifier node of a defining program unit
3711       --  name or  the selector node if N is a selected component or an
3712       --  expanded name.
3713
3714       -----------------
3715       -- Prefix_Node --
3716       -----------------
3717
3718       function Prefix_Node (N : Node_Id) return Node_Id is
3719       begin
3720          if Nkind (N) = N_Defining_Program_Unit_Name then
3721             return Name (N);
3722
3723          else
3724             return Prefix (N);
3725          end if;
3726       end Prefix_Node;
3727
3728       -----------------
3729       -- Select_Node --
3730       -----------------
3731
3732       function Select_Node (N : Node_Id) return Node_Id is
3733       begin
3734          if Nkind (N) = N_Defining_Program_Unit_Name then
3735             return Defining_Identifier (N);
3736
3737          else
3738             return Selector_Name (N);
3739          end if;
3740       end Select_Node;
3741
3742    --  Start of processing for Designate_Next_Unit
3743
3744    begin
3745       if (K1 = N_Identifier or else
3746           K1 = N_Defining_Identifier)
3747         and then
3748          (K2 = N_Identifier or else
3749           K2 = N_Defining_Identifier)
3750       then
3751          return Chars (Name1) = Chars (Name2);
3752
3753       elsif
3754          (K1 = N_Expanded_Name      or else
3755           K1 = N_Selected_Component or else
3756           K1 = N_Defining_Program_Unit_Name)
3757         and then
3758          (K2 = N_Expanded_Name      or else
3759           K2 = N_Selected_Component or else
3760           K2 = N_Defining_Program_Unit_Name)
3761       then
3762          return
3763            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
3764              and then
3765                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
3766
3767       else
3768          return False;
3769       end if;
3770    end Designate_Same_Unit;
3771
3772    ------------------------------------------
3773    -- function Dynamic_Accessibility_Level --
3774    ------------------------------------------
3775
3776    function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
3777       E : Entity_Id;
3778       Loc : constant Source_Ptr := Sloc (Expr);
3779
3780       function Make_Level_Literal (Level : Uint) return Node_Id;
3781       --  Construct an integer literal representing an accessibility level
3782       --  with its type set to Natural.
3783
3784       ------------------------
3785       -- Make_Level_Literal --
3786       ------------------------
3787
3788       function Make_Level_Literal (Level : Uint) return Node_Id is
3789          Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
3790       begin
3791          Set_Etype (Result, Standard_Natural);
3792          return Result;
3793       end Make_Level_Literal;
3794
3795    --  Start of processing for Dynamic_Accessibility_Level
3796
3797    begin
3798       if Is_Entity_Name (Expr) then
3799          E := Entity (Expr);
3800
3801          if Present (Renamed_Object (E)) then
3802             return Dynamic_Accessibility_Level (Renamed_Object (E));
3803          end if;
3804
3805          if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
3806             if Present (Extra_Accessibility (E)) then
3807                return New_Occurrence_Of (Extra_Accessibility (E), Loc);
3808             end if;
3809          end if;
3810       end if;
3811
3812       --  Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
3813
3814       case Nkind (Expr) is
3815
3816          --  For access discriminant, the level of the enclosing object
3817
3818          when N_Selected_Component =>
3819             if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
3820               and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
3821                                             E_Anonymous_Access_Type
3822             then
3823                return Make_Level_Literal (Object_Access_Level (Expr));
3824             end if;
3825
3826          when N_Attribute_Reference =>
3827             case Get_Attribute_Id (Attribute_Name (Expr)) is
3828
3829                --  For X'Access, the level of the prefix X
3830
3831                when Attribute_Access =>
3832                   return Make_Level_Literal
3833                            (Object_Access_Level (Prefix (Expr)));
3834
3835                --  Treat the unchecked attributes as library-level
3836
3837                when Attribute_Unchecked_Access    |
3838                     Attribute_Unrestricted_Access =>
3839                   return Make_Level_Literal (Scope_Depth (Standard_Standard));
3840
3841                --  No other access-valued attributes
3842
3843                when others =>
3844                   raise Program_Error;
3845             end case;
3846
3847          when N_Allocator =>
3848
3849             --  Unimplemented: depends on context. As an actual parameter where
3850             --  formal type is anonymous, use
3851             --    Scope_Depth (Current_Scope) + 1.
3852             --  For other cases, see 3.10.2(14/3) and following. ???
3853
3854             null;
3855
3856          when N_Type_Conversion =>
3857             if not Is_Local_Anonymous_Access (Etype (Expr)) then
3858
3859                --  Handle type conversions introduced for a rename of an
3860                --  Ada 2012 stand-alone object of an anonymous access type.
3861
3862                return Dynamic_Accessibility_Level (Expression (Expr));
3863             end if;
3864
3865          when others =>
3866             null;
3867       end case;
3868
3869       return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
3870    end Dynamic_Accessibility_Level;
3871
3872    -----------------------------------
3873    -- Effective_Extra_Accessibility --
3874    -----------------------------------
3875
3876    function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
3877    begin
3878       if Present (Renamed_Object (Id))
3879         and then Is_Entity_Name (Renamed_Object (Id))
3880       then
3881          return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
3882       else
3883          return Extra_Accessibility (Id);
3884       end if;
3885    end Effective_Extra_Accessibility;
3886
3887    ------------------------------
3888    -- Enclosing_Comp_Unit_Node --
3889    ------------------------------
3890
3891    function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
3892       Current_Node : Node_Id;
3893
3894    begin
3895       Current_Node := N;
3896       while Present (Current_Node)
3897         and then Nkind (Current_Node) /= N_Compilation_Unit
3898       loop
3899          Current_Node := Parent (Current_Node);
3900       end loop;
3901
3902       if Nkind (Current_Node) /= N_Compilation_Unit then
3903          return Empty;
3904       else
3905          return Current_Node;
3906       end if;
3907    end Enclosing_Comp_Unit_Node;
3908
3909    --------------------------
3910    -- Enclosing_CPP_Parent --
3911    --------------------------
3912
3913    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
3914       Parent_Typ : Entity_Id := Typ;
3915
3916    begin
3917       while not Is_CPP_Class (Parent_Typ)
3918          and then Etype (Parent_Typ) /= Parent_Typ
3919       loop
3920          Parent_Typ := Etype (Parent_Typ);
3921
3922          if Is_Private_Type (Parent_Typ) then
3923             Parent_Typ := Full_View (Base_Type (Parent_Typ));
3924          end if;
3925       end loop;
3926
3927       pragma Assert (Is_CPP_Class (Parent_Typ));
3928       return Parent_Typ;
3929    end Enclosing_CPP_Parent;
3930
3931    ----------------------------
3932    -- Enclosing_Generic_Body --
3933    ----------------------------
3934
3935    function Enclosing_Generic_Body
3936      (N : Node_Id) return Node_Id
3937    is
3938       P    : Node_Id;
3939       Decl : Node_Id;
3940       Spec : Node_Id;
3941
3942    begin
3943       P := Parent (N);
3944       while Present (P) loop
3945          if Nkind (P) = N_Package_Body
3946            or else Nkind (P) = N_Subprogram_Body
3947          then
3948             Spec := Corresponding_Spec (P);
3949
3950             if Present (Spec) then
3951                Decl := Unit_Declaration_Node (Spec);
3952
3953                if Nkind (Decl) = N_Generic_Package_Declaration
3954                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
3955                then
3956                   return P;
3957                end if;
3958             end if;
3959          end if;
3960
3961          P := Parent (P);
3962       end loop;
3963
3964       return Empty;
3965    end Enclosing_Generic_Body;
3966
3967    ----------------------------
3968    -- Enclosing_Generic_Unit --
3969    ----------------------------
3970
3971    function Enclosing_Generic_Unit
3972      (N : Node_Id) return Node_Id
3973    is
3974       P    : Node_Id;
3975       Decl : Node_Id;
3976       Spec : Node_Id;
3977
3978    begin
3979       P := Parent (N);
3980       while Present (P) loop
3981          if Nkind (P) = N_Generic_Package_Declaration
3982            or else Nkind (P) = N_Generic_Subprogram_Declaration
3983          then
3984             return P;
3985
3986          elsif Nkind (P) = N_Package_Body
3987            or else Nkind (P) = N_Subprogram_Body
3988          then
3989             Spec := Corresponding_Spec (P);
3990
3991             if Present (Spec) then
3992                Decl := Unit_Declaration_Node (Spec);
3993
3994                if Nkind (Decl) = N_Generic_Package_Declaration
3995                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
3996                then
3997                   return Decl;
3998                end if;
3999             end if;
4000          end if;
4001
4002          P := Parent (P);
4003       end loop;
4004
4005       return Empty;
4006    end Enclosing_Generic_Unit;
4007
4008    -------------------------------
4009    -- Enclosing_Lib_Unit_Entity --
4010    -------------------------------
4011
4012    function Enclosing_Lib_Unit_Entity
4013       (E : Entity_Id := Current_Scope) return Entity_Id
4014    is
4015       Unit_Entity : Entity_Id;
4016
4017    begin
4018       --  Look for enclosing library unit entity by following scope links.
4019       --  Equivalent to, but faster than indexing through the scope stack.
4020
4021       Unit_Entity := E;
4022       while (Present (Scope (Unit_Entity))
4023         and then Scope (Unit_Entity) /= Standard_Standard)
4024         and not Is_Child_Unit (Unit_Entity)
4025       loop
4026          Unit_Entity := Scope (Unit_Entity);
4027       end loop;
4028
4029       return Unit_Entity;
4030    end Enclosing_Lib_Unit_Entity;
4031
4032    -----------------------
4033    -- Enclosing_Package --
4034    -----------------------
4035
4036    function Enclosing_Package (E : Entity_Id) return Entity_Id is
4037       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4038
4039    begin
4040       if Dynamic_Scope = Standard_Standard then
4041          return Standard_Standard;
4042
4043       elsif Dynamic_Scope = Empty then
4044          return Empty;
4045
4046       elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
4047                       E_Generic_Package)
4048       then
4049          return Dynamic_Scope;
4050
4051       else
4052          return Enclosing_Package (Dynamic_Scope);
4053       end if;
4054    end Enclosing_Package;
4055
4056    --------------------------
4057    -- Enclosing_Subprogram --
4058    --------------------------
4059
4060    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
4061       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
4062
4063    begin
4064       if Dynamic_Scope = Standard_Standard then
4065          return Empty;
4066
4067       elsif Dynamic_Scope = Empty then
4068          return Empty;
4069
4070       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
4071          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
4072
4073       elsif Ekind (Dynamic_Scope) = E_Block
4074         or else Ekind (Dynamic_Scope) = E_Return_Statement
4075       then
4076          return Enclosing_Subprogram (Dynamic_Scope);
4077
4078       elsif Ekind (Dynamic_Scope) = E_Task_Type then
4079          return Get_Task_Body_Procedure (Dynamic_Scope);
4080
4081       elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
4082         and then Present (Full_View (Dynamic_Scope))
4083         and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
4084       then
4085          return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
4086
4087       --  No body is generated if the protected operation is eliminated
4088
4089       elsif Convention (Dynamic_Scope) = Convention_Protected
4090         and then not Is_Eliminated (Dynamic_Scope)
4091         and then Present (Protected_Body_Subprogram (Dynamic_Scope))
4092       then
4093          return Protected_Body_Subprogram (Dynamic_Scope);
4094
4095       else
4096          return Dynamic_Scope;
4097       end if;
4098    end Enclosing_Subprogram;
4099
4100    ------------------------
4101    -- Ensure_Freeze_Node --
4102    ------------------------
4103
4104    procedure Ensure_Freeze_Node (E : Entity_Id) is
4105       FN : Node_Id;
4106
4107    begin
4108       if No (Freeze_Node (E)) then
4109          FN := Make_Freeze_Entity (Sloc (E));
4110          Set_Has_Delayed_Freeze (E);
4111          Set_Freeze_Node (E, FN);
4112          Set_Access_Types_To_Process (FN, No_Elist);
4113          Set_TSS_Elist (FN, No_Elist);
4114          Set_Entity (FN, E);
4115       end if;
4116    end Ensure_Freeze_Node;
4117
4118    ----------------
4119    -- Enter_Name --
4120    ----------------
4121
4122    procedure Enter_Name (Def_Id : Entity_Id) is
4123       C : constant Entity_Id := Current_Entity (Def_Id);
4124       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
4125       S : constant Entity_Id := Current_Scope;
4126
4127    begin
4128       Generate_Definition (Def_Id);
4129
4130       --  Add new name to current scope declarations. Check for duplicate
4131       --  declaration, which may or may not be a genuine error.
4132
4133       if Present (E) then
4134
4135          --  Case of previous entity entered because of a missing declaration
4136          --  or else a bad subtype indication. Best is to use the new entity,
4137          --  and make the previous one invisible.
4138
4139          if Etype (E) = Any_Type then
4140             Set_Is_Immediately_Visible (E, False);
4141
4142          --  Case of renaming declaration constructed for package instances.
4143          --  if there is an explicit declaration with the same identifier,
4144          --  the renaming is not immediately visible any longer, but remains
4145          --  visible through selected component notation.
4146
4147          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
4148            and then not Comes_From_Source (E)
4149          then
4150             Set_Is_Immediately_Visible (E, False);
4151
4152          --  The new entity may be the package renaming, which has the same
4153          --  same name as a generic formal which has been seen already.
4154
4155          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
4156             and then not Comes_From_Source (Def_Id)
4157          then
4158             Set_Is_Immediately_Visible (E, False);
4159
4160          --  For a fat pointer corresponding to a remote access to subprogram,
4161          --  we use the same identifier as the RAS type, so that the proper
4162          --  name appears in the stub. This type is only retrieved through
4163          --  the RAS type and never by visibility, and is not added to the
4164          --  visibility list (see below).
4165
4166          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
4167            and then Present (Corresponding_Remote_Type (Def_Id))
4168          then
4169             null;
4170
4171          --  Case of an implicit operation or derived literal. The new entity
4172          --  hides the implicit one,  which is removed from all visibility,
4173          --  i.e. the entity list of its scope, and homonym chain of its name.
4174
4175          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
4176            or else Is_Internal (E)
4177          then
4178             declare
4179                Prev     : Entity_Id;
4180                Prev_Vis : Entity_Id;
4181                Decl     : constant Node_Id := Parent (E);
4182
4183             begin
4184                --  If E is an implicit declaration, it cannot be the first
4185                --  entity in the scope.
4186
4187                Prev := First_Entity (Current_Scope);
4188                while Present (Prev)
4189                  and then Next_Entity (Prev) /= E
4190                loop
4191                   Next_Entity (Prev);
4192                end loop;
4193
4194                if No (Prev) then
4195
4196                   --  If E is not on the entity chain of the current scope,
4197                   --  it is an implicit declaration in the generic formal
4198                   --  part of a generic subprogram. When analyzing the body,
4199                   --  the generic formals are visible but not on the entity
4200                   --  chain of the subprogram. The new entity will become
4201                   --  the visible one in the body.
4202
4203                   pragma Assert
4204                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
4205                   null;
4206
4207                else
4208                   Set_Next_Entity (Prev, Next_Entity (E));
4209
4210                   if No (Next_Entity (Prev)) then
4211                      Set_Last_Entity (Current_Scope, Prev);
4212                   end if;
4213
4214                   if E = Current_Entity (E) then
4215                      Prev_Vis := Empty;
4216
4217                   else
4218                      Prev_Vis := Current_Entity (E);
4219                      while Homonym (Prev_Vis) /= E loop
4220                         Prev_Vis := Homonym (Prev_Vis);
4221                      end loop;
4222                   end if;
4223
4224                   if Present (Prev_Vis)  then
4225
4226                      --  Skip E in the visibility chain
4227
4228                      Set_Homonym (Prev_Vis, Homonym (E));
4229
4230                   else
4231                      Set_Name_Entity_Id (Chars (E), Homonym (E));
4232                   end if;
4233                end if;
4234             end;
4235
4236          --  This section of code could use a comment ???
4237
4238          elsif Present (Etype (E))
4239            and then Is_Concurrent_Type (Etype (E))
4240            and then E = Def_Id
4241          then
4242             return;
4243
4244          --  If the homograph is a protected component renaming, it should not
4245          --  be hiding the current entity. Such renamings are treated as weak
4246          --  declarations.
4247
4248          elsif Is_Prival (E) then
4249             Set_Is_Immediately_Visible (E, False);
4250
4251          --  In this case the current entity is a protected component renaming.
4252          --  Perform minimal decoration by setting the scope and return since
4253          --  the prival should not be hiding other visible entities.
4254
4255          elsif Is_Prival (Def_Id) then
4256             Set_Scope (Def_Id, Current_Scope);
4257             return;
4258
4259          --  Analogous to privals, the discriminal generated for an entry index
4260          --  parameter acts as a weak declaration. Perform minimal decoration
4261          --  to avoid bogus errors.
4262
4263          elsif Is_Discriminal (Def_Id)
4264            and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
4265          then
4266             Set_Scope (Def_Id, Current_Scope);
4267             return;
4268
4269          --  In the body or private part of an instance, a type extension may
4270          --  introduce a component with the same name as that of an actual. The
4271          --  legality rule is not enforced, but the semantics of the full type
4272          --  with two components of same name are not clear at this point???
4273
4274          elsif In_Instance_Not_Visible then
4275             null;
4276
4277          --  When compiling a package body, some child units may have become
4278          --  visible. They cannot conflict with local entities that hide them.
4279
4280          elsif Is_Child_Unit (E)
4281            and then In_Open_Scopes (Scope (E))
4282            and then not Is_Immediately_Visible (E)
4283          then
4284             null;
4285
4286          --  Conversely, with front-end inlining we may compile the parent body
4287          --  first, and a child unit subsequently. The context is now the
4288          --  parent spec, and body entities are not visible.
4289
4290          elsif Is_Child_Unit (Def_Id)
4291            and then Is_Package_Body_Entity (E)
4292            and then not In_Package_Body (Current_Scope)
4293          then
4294             null;
4295
4296          --  Case of genuine duplicate declaration
4297
4298          else
4299             Error_Msg_Sloc := Sloc (E);
4300
4301             --  If the previous declaration is an incomplete type declaration
4302             --  this may be an attempt to complete it with a private type. The
4303             --  following avoids confusing cascaded errors.
4304
4305             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
4306               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
4307             then
4308                Error_Msg_N
4309                  ("incomplete type cannot be completed with a private " &
4310                   "declaration", Parent (Def_Id));
4311                Set_Is_Immediately_Visible (E, False);
4312                Set_Full_View (E, Def_Id);
4313
4314             --  An inherited component of a record conflicts with a new
4315             --  discriminant. The discriminant is inserted first in the scope,
4316             --  but the error should be posted on it, not on the component.
4317
4318             elsif Ekind (E) = E_Discriminant
4319               and then Present (Scope (Def_Id))
4320               and then Scope (Def_Id) /= Current_Scope
4321             then
4322                Error_Msg_Sloc := Sloc (Def_Id);
4323                Error_Msg_N ("& conflicts with declaration#", E);
4324                return;
4325
4326             --  If the name of the unit appears in its own context clause, a
4327             --  dummy package with the name has already been created, and the
4328             --  error emitted. Try to continue quietly.
4329
4330             elsif Error_Posted (E)
4331               and then Sloc (E) = No_Location
4332               and then Nkind (Parent (E)) = N_Package_Specification
4333               and then Current_Scope = Standard_Standard
4334             then
4335                Set_Scope (Def_Id, Current_Scope);
4336                return;
4337
4338             else
4339                Error_Msg_N ("& conflicts with declaration#", Def_Id);
4340
4341                --  Avoid cascaded messages with duplicate components in
4342                --  derived types.
4343
4344                if Ekind_In (E, E_Component, E_Discriminant) then
4345                   return;
4346                end if;
4347             end if;
4348
4349             if Nkind (Parent (Parent (Def_Id))) =
4350                 N_Generic_Subprogram_Declaration
4351               and then Def_Id =
4352                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
4353             then
4354                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
4355             end if;
4356
4357             --  If entity is in standard, then we are in trouble, because it
4358             --  means that we have a library package with a duplicated name.
4359             --  That's hard to recover from, so abort!
4360
4361             if S = Standard_Standard then
4362                raise Unrecoverable_Error;
4363
4364             --  Otherwise we continue with the declaration. Having two
4365             --  identical declarations should not cause us too much trouble!
4366
4367             else
4368                null;
4369             end if;
4370          end if;
4371       end if;
4372
4373       --  If we fall through, declaration is OK, at least OK enough to continue
4374
4375       --  If Def_Id is a discriminant or a record component we are in the midst
4376       --  of inheriting components in a derived record definition. Preserve
4377       --  their Ekind and Etype.
4378
4379       if Ekind_In (Def_Id, E_Discriminant, E_Component) then
4380          null;
4381
4382       --  If a type is already set, leave it alone (happens when a type
4383       --  declaration is reanalyzed following a call to the optimizer).
4384
4385       elsif Present (Etype (Def_Id)) then
4386          null;
4387
4388       --  Otherwise, the kind E_Void insures that premature uses of the entity
4389       --  will be detected. Any_Type insures that no cascaded errors will occur
4390
4391       else
4392          Set_Ekind (Def_Id, E_Void);
4393          Set_Etype (Def_Id, Any_Type);
4394       end if;
4395
4396       --  Inherited discriminants and components in derived record types are
4397       --  immediately visible. Itypes are not.
4398
4399       if Ekind_In (Def_Id, E_Discriminant, E_Component)
4400         or else (No (Corresponding_Remote_Type (Def_Id))
4401                  and then not Is_Itype (Def_Id))
4402       then
4403          Set_Is_Immediately_Visible (Def_Id);
4404          Set_Current_Entity         (Def_Id);
4405       end if;
4406
4407       Set_Homonym       (Def_Id, C);
4408       Append_Entity     (Def_Id, S);
4409       Set_Public_Status (Def_Id);
4410
4411       --  Declaring a homonym is not allowed in SPARK ...
4412
4413       if Present (C)
4414         and then Restriction_Check_Required (SPARK)
4415       then
4416          declare
4417             Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
4418             Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
4419             Other_Scope    : constant Node_Id := Enclosing_Dynamic_Scope (C);
4420
4421          begin
4422             --  ... unless the new declaration is in a subprogram, and the
4423             --  visible declaration is a variable declaration or a parameter
4424             --  specification outside that subprogram.
4425
4426             if Present (Enclosing_Subp)
4427               and then Nkind_In (Parent (C), N_Object_Declaration,
4428                                              N_Parameter_Specification)
4429               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
4430             then
4431                null;
4432
4433             --  ... or the new declaration is in a package, and the visible
4434             --  declaration occurs outside that package.
4435
4436             elsif Present (Enclosing_Pack)
4437               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
4438             then
4439                null;
4440
4441             --  ... or the new declaration is a component declaration in a
4442             --  record type definition.
4443
4444             elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
4445                null;
4446
4447             --  Don't issue error for non-source entities
4448
4449             elsif Comes_From_Source (Def_Id)
4450               and then Comes_From_Source (C)
4451             then
4452                Error_Msg_Sloc := Sloc (C);
4453                Check_SPARK_Restriction
4454                  ("redeclaration of identifier &#", Def_Id);
4455             end if;
4456          end;
4457       end if;
4458
4459       --  Warn if new entity hides an old one
4460
4461       if Warn_On_Hiding and then Present (C)
4462
4463          --  Don't warn for record components since they always have a well
4464          --  defined scope which does not confuse other uses. Note that in
4465          --  some cases, Ekind has not been set yet.
4466
4467          and then Ekind (C) /= E_Component
4468          and then Ekind (C) /= E_Discriminant
4469          and then Nkind (Parent (C)) /= N_Component_Declaration
4470          and then Ekind (Def_Id) /= E_Component
4471          and then Ekind (Def_Id) /= E_Discriminant
4472          and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
4473
4474          --  Don't warn for one character variables. It is too common to use
4475          --  such variables as locals and will just cause too many false hits.
4476
4477          and then Length_Of_Name (Chars (C)) /= 1
4478
4479          --  Don't warn for non-source entities
4480
4481          and then Comes_From_Source (C)
4482          and then Comes_From_Source (Def_Id)
4483
4484          --  Don't warn unless entity in question is in extended main source
4485
4486          and then In_Extended_Main_Source_Unit (Def_Id)
4487
4488          --  Finally, the hidden entity must be either immediately visible or
4489          --  use visible (i.e. from a used package).
4490
4491          and then
4492            (Is_Immediately_Visible (C)
4493               or else
4494             Is_Potentially_Use_Visible (C))
4495       then
4496          Error_Msg_Sloc := Sloc (C);
4497          Error_Msg_N ("declaration hides &#?h?", Def_Id);
4498       end if;
4499    end Enter_Name;
4500
4501    --------------------------
4502    -- Explain_Limited_Type --
4503    --------------------------
4504
4505    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
4506       C : Entity_Id;
4507
4508    begin
4509       --  For array, component type must be limited
4510
4511       if Is_Array_Type (T) then
4512          Error_Msg_Node_2 := T;
4513          Error_Msg_NE
4514            ("\component type& of type& is limited", N, Component_Type (T));
4515          Explain_Limited_Type (Component_Type (T), N);
4516
4517       elsif Is_Record_Type (T) then
4518
4519          --  No need for extra messages if explicit limited record
4520
4521          if Is_Limited_Record (Base_Type (T)) then
4522             return;
4523          end if;
4524
4525          --  Otherwise find a limited component. Check only components that
4526          --  come from source, or inherited components that appear in the
4527          --  source of the ancestor.
4528
4529          C := First_Component (T);
4530          while Present (C) loop
4531             if Is_Limited_Type (Etype (C))
4532               and then
4533                 (Comes_From_Source (C)
4534                    or else
4535                      (Present (Original_Record_Component (C))
4536                        and then
4537                          Comes_From_Source (Original_Record_Component (C))))
4538             then
4539                Error_Msg_Node_2 := T;
4540                Error_Msg_NE ("\component& of type& has limited type", N, C);
4541                Explain_Limited_Type (Etype (C), N);
4542                return;
4543             end if;
4544
4545             Next_Component (C);
4546          end loop;
4547
4548          --  The type may be declared explicitly limited, even if no component
4549          --  of it is limited, in which case we fall out of the loop.
4550          return;
4551       end if;
4552    end Explain_Limited_Type;
4553
4554    -----------------
4555    -- Find_Actual --
4556    -----------------
4557
4558    procedure Find_Actual
4559      (N        : Node_Id;
4560       Formal   : out Entity_Id;
4561       Call     : out Node_Id)
4562    is
4563       Parnt  : constant Node_Id := Parent (N);
4564       Actual : Node_Id;
4565
4566    begin
4567       if (Nkind (Parnt) = N_Indexed_Component
4568             or else
4569           Nkind (Parnt) = N_Selected_Component)
4570         and then N = Prefix (Parnt)
4571       then
4572          Find_Actual (Parnt, Formal, Call);
4573          return;
4574
4575       elsif Nkind (Parnt) = N_Parameter_Association
4576         and then N = Explicit_Actual_Parameter (Parnt)
4577       then
4578          Call := Parent (Parnt);
4579
4580       elsif Nkind (Parnt) in N_Subprogram_Call then
4581          Call := Parnt;
4582
4583       else
4584          Formal := Empty;
4585          Call   := Empty;
4586          return;
4587       end if;
4588
4589       --  If we have a call to a subprogram look for the parameter. Note that
4590       --  we exclude overloaded calls, since we don't know enough to be sure
4591       --  of giving the right answer in this case.
4592
4593       if Is_Entity_Name (Name (Call))
4594         and then Present (Entity (Name (Call)))
4595         and then Is_Overloadable (Entity (Name (Call)))
4596         and then not Is_Overloaded (Name (Call))
4597       then
4598          --  Fall here if we are definitely a parameter
4599
4600          Actual := First_Actual (Call);
4601          Formal := First_Formal (Entity (Name (Call)));
4602          while Present (Formal) and then Present (Actual) loop
4603             if Actual = N then
4604                return;
4605             else
4606                Actual := Next_Actual (Actual);
4607                Formal := Next_Formal (Formal);
4608             end if;
4609          end loop;
4610       end if;
4611
4612       --  Fall through here if we did not find matching actual
4613
4614       Formal := Empty;
4615       Call   := Empty;
4616    end Find_Actual;
4617
4618    ---------------------------
4619    -- Find_Body_Discriminal --
4620    ---------------------------
4621
4622    function Find_Body_Discriminal
4623      (Spec_Discriminant : Entity_Id) return Entity_Id
4624    is
4625       Tsk  : Entity_Id;
4626       Disc : Entity_Id;
4627
4628    begin
4629       --  If expansion is suppressed, then the scope can be the concurrent type
4630       --  itself rather than a corresponding concurrent record type.
4631
4632       if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
4633          Tsk := Scope (Spec_Discriminant);
4634
4635       else
4636          pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
4637
4638          Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
4639       end if;
4640
4641       --  Find discriminant of original concurrent type, and use its current
4642       --  discriminal, which is the renaming within the task/protected body.
4643
4644       Disc := First_Discriminant (Tsk);
4645       while Present (Disc) loop
4646          if Chars (Disc) = Chars (Spec_Discriminant) then
4647             return Discriminal (Disc);
4648          end if;
4649
4650          Next_Discriminant (Disc);
4651       end loop;
4652
4653       --  That loop should always succeed in finding a matching entry and
4654       --  returning. Fatal error if not.
4655
4656       raise Program_Error;
4657    end Find_Body_Discriminal;
4658
4659    -------------------------------------
4660    -- Find_Corresponding_Discriminant --
4661    -------------------------------------
4662
4663    function Find_Corresponding_Discriminant
4664      (Id  : Node_Id;
4665       Typ : Entity_Id) return Entity_Id
4666    is
4667       Par_Disc : Entity_Id;
4668       Old_Disc : Entity_Id;
4669       New_Disc : Entity_Id;
4670
4671    begin
4672       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
4673
4674       --  The original type may currently be private, and the discriminant
4675       --  only appear on its full view.
4676
4677       if Is_Private_Type (Scope (Par_Disc))
4678         and then not Has_Discriminants (Scope (Par_Disc))
4679         and then Present (Full_View (Scope (Par_Disc)))
4680       then
4681          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
4682       else
4683          Old_Disc := First_Discriminant (Scope (Par_Disc));
4684       end if;
4685
4686       if Is_Class_Wide_Type (Typ) then
4687          New_Disc := First_Discriminant (Root_Type (Typ));
4688       else
4689          New_Disc := First_Discriminant (Typ);
4690       end if;
4691
4692       while Present (Old_Disc) and then Present (New_Disc) loop
4693          if Old_Disc = Par_Disc  then
4694             return New_Disc;
4695          else
4696             Next_Discriminant (Old_Disc);
4697             Next_Discriminant (New_Disc);
4698          end if;
4699       end loop;
4700
4701       --  Should always find it
4702
4703       raise Program_Error;
4704    end Find_Corresponding_Discriminant;
4705
4706    --------------------------
4707    -- Find_Overlaid_Entity --
4708    --------------------------
4709
4710    procedure Find_Overlaid_Entity
4711      (N   : Node_Id;
4712       Ent : out Entity_Id;
4713       Off : out Boolean)
4714    is
4715       Expr : Node_Id;
4716
4717    begin
4718       --  We are looking for one of the two following forms:
4719
4720       --    for X'Address use Y'Address
4721
4722       --  or
4723
4724       --    Const : constant Address := expr;
4725       --    ...
4726       --    for X'Address use Const;
4727
4728       --  In the second case, the expr is either Y'Address, or recursively a
4729       --  constant that eventually references Y'Address.
4730
4731       Ent := Empty;
4732       Off := False;
4733
4734       if Nkind (N) = N_Attribute_Definition_Clause
4735         and then Chars (N) = Name_Address
4736       then
4737          Expr := Expression (N);
4738
4739          --  This loop checks the form of the expression for Y'Address,
4740          --  using recursion to deal with intermediate constants.
4741
4742          loop
4743             --  Check for Y'Address
4744
4745             if Nkind (Expr) = N_Attribute_Reference
4746               and then Attribute_Name (Expr) = Name_Address
4747             then
4748                Expr := Prefix (Expr);
4749                exit;
4750
4751                --  Check for Const where Const is a constant entity
4752
4753             elsif Is_Entity_Name (Expr)
4754               and then Ekind (Entity (Expr)) = E_Constant
4755             then
4756                Expr := Constant_Value (Entity (Expr));
4757
4758             --  Anything else does not need checking
4759
4760             else
4761                return;
4762             end if;
4763          end loop;
4764
4765          --  This loop checks the form of the prefix for an entity, using
4766          --  recursion to deal with intermediate components.
4767
4768          loop
4769             --  Check for Y where Y is an entity
4770
4771             if Is_Entity_Name (Expr) then
4772                Ent := Entity (Expr);
4773                return;
4774
4775             --  Check for components
4776
4777             elsif
4778               Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
4779             then
4780                Expr := Prefix (Expr);
4781                Off := True;
4782
4783             --  Anything else does not need checking
4784
4785             else
4786                return;
4787             end if;
4788          end loop;
4789       end if;
4790    end Find_Overlaid_Entity;
4791
4792    -------------------------
4793    -- Find_Parameter_Type --
4794    -------------------------
4795
4796    function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
4797    begin
4798       if Nkind (Param) /= N_Parameter_Specification then
4799          return Empty;
4800
4801       --  For an access parameter, obtain the type from the formal entity
4802       --  itself, because access to subprogram nodes do not carry a type.
4803       --  Shouldn't we always use the formal entity ???
4804
4805       elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
4806          return Etype (Defining_Identifier (Param));
4807
4808       else
4809          return Etype (Parameter_Type (Param));
4810       end if;
4811    end Find_Parameter_Type;
4812
4813    -----------------------------
4814    -- Find_Static_Alternative --
4815    -----------------------------
4816
4817    function Find_Static_Alternative (N : Node_Id) return Node_Id is
4818       Expr   : constant Node_Id := Expression (N);
4819       Val    : constant Uint    := Expr_Value (Expr);
4820       Alt    : Node_Id;
4821       Choice : Node_Id;
4822
4823    begin
4824       Alt := First (Alternatives (N));
4825
4826       Search : loop
4827          if Nkind (Alt) /= N_Pragma then
4828             Choice := First (Discrete_Choices (Alt));
4829             while Present (Choice) loop
4830
4831                --  Others choice, always matches
4832
4833                if Nkind (Choice) = N_Others_Choice then
4834                   exit Search;
4835
4836                --  Range, check if value is in the range
4837
4838                elsif Nkind (Choice) = N_Range then
4839                   exit Search when
4840                     Val >= Expr_Value (Low_Bound (Choice))
4841                       and then
4842                     Val <= Expr_Value (High_Bound (Choice));
4843
4844                --  Choice is a subtype name. Note that we know it must
4845                --  be a static subtype, since otherwise it would have
4846                --  been diagnosed as illegal.
4847
4848                elsif Is_Entity_Name (Choice)
4849                  and then Is_Type (Entity (Choice))
4850                then
4851                   exit Search when Is_In_Range (Expr, Etype (Choice),
4852                                                 Assume_Valid => False);
4853
4854                --  Choice is a subtype indication
4855
4856                elsif Nkind (Choice) = N_Subtype_Indication then
4857                   declare
4858                      C : constant Node_Id := Constraint (Choice);
4859                      R : constant Node_Id := Range_Expression (C);
4860
4861                   begin
4862                      exit Search when
4863                        Val >= Expr_Value (Low_Bound (R))
4864                          and then
4865                        Val <= Expr_Value (High_Bound (R));
4866                   end;
4867
4868                --  Choice is a simple expression
4869
4870                else
4871                   exit Search when Val = Expr_Value (Choice);
4872                end if;
4873
4874                Next (Choice);
4875             end loop;
4876          end if;
4877
4878          Next (Alt);
4879          pragma Assert (Present (Alt));
4880       end loop Search;
4881
4882       --  The above loop *must* terminate by finding a match, since
4883       --  we know the case statement is valid, and the value of the
4884       --  expression is known at compile time. When we fall out of
4885       --  the loop, Alt points to the alternative that we know will
4886       --  be selected at run time.
4887
4888       return Alt;
4889    end Find_Static_Alternative;
4890
4891    ------------------
4892    -- First_Actual --
4893    ------------------
4894
4895    function First_Actual (Node : Node_Id) return Node_Id is
4896       N : Node_Id;
4897
4898    begin
4899       if No (Parameter_Associations (Node)) then
4900          return Empty;
4901       end if;
4902
4903       N := First (Parameter_Associations (Node));
4904
4905       if Nkind (N) = N_Parameter_Association then
4906          return First_Named_Actual (Node);
4907       else
4908          return N;
4909       end if;
4910    end First_Actual;
4911
4912    -----------------------
4913    -- Gather_Components --
4914    -----------------------
4915
4916    procedure Gather_Components
4917      (Typ           : Entity_Id;
4918       Comp_List     : Node_Id;
4919       Governed_By   : List_Id;
4920       Into          : Elist_Id;
4921       Report_Errors : out Boolean)
4922    is
4923       Assoc           : Node_Id;
4924       Variant         : Node_Id;
4925       Discrete_Choice : Node_Id;
4926       Comp_Item       : Node_Id;
4927
4928       Discrim       : Entity_Id;
4929       Discrim_Name  : Node_Id;
4930       Discrim_Value : Node_Id;
4931
4932    begin
4933       Report_Errors := False;
4934
4935       if No (Comp_List) or else Null_Present (Comp_List) then
4936          return;
4937
4938       elsif Present (Component_Items (Comp_List)) then
4939          Comp_Item := First (Component_Items (Comp_List));
4940
4941       else
4942          Comp_Item := Empty;
4943       end if;
4944
4945       while Present (Comp_Item) loop
4946
4947          --  Skip the tag of a tagged record, the interface tags, as well
4948          --  as all items that are not user components (anonymous types,
4949          --  rep clauses, Parent field, controller field).
4950
4951          if Nkind (Comp_Item) = N_Component_Declaration then
4952             declare
4953                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
4954             begin
4955                if not Is_Tag (Comp)
4956                  and then Chars (Comp) /= Name_uParent
4957                then
4958                   Append_Elmt (Comp, Into);
4959                end if;
4960             end;
4961          end if;
4962
4963          Next (Comp_Item);
4964       end loop;
4965
4966       if No (Variant_Part (Comp_List)) then
4967          return;
4968       else
4969          Discrim_Name := Name (Variant_Part (Comp_List));
4970          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
4971       end if;
4972
4973       --  Look for the discriminant that governs this variant part.
4974       --  The discriminant *must* be in the Governed_By List
4975
4976       Assoc := First (Governed_By);
4977       Find_Constraint : loop
4978          Discrim := First (Choices (Assoc));
4979          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
4980            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
4981                       and then
4982                     Chars (Corresponding_Discriminant (Entity (Discrim)))
4983                          = Chars  (Discrim_Name))
4984            or else Chars (Original_Record_Component (Entity (Discrim)))
4985                          = Chars (Discrim_Name);
4986
4987          if No (Next (Assoc)) then
4988             if not Is_Constrained (Typ)
4989               and then Is_Derived_Type (Typ)
4990               and then Present (Stored_Constraint (Typ))
4991             then
4992                --  If the type is a tagged type with inherited discriminants,
4993                --  use the stored constraint on the parent in order to find
4994                --  the values of discriminants that are otherwise hidden by an
4995                --  explicit constraint. Renamed discriminants are handled in
4996                --  the code above.
4997
4998                --  If several parent discriminants are renamed by a single
4999                --  discriminant of the derived type, the call to obtain the
5000                --  Corresponding_Discriminant field only retrieves the last
5001                --  of them. We recover the constraint on the others from the
5002                --  Stored_Constraint as well.
5003
5004                declare
5005                   D : Entity_Id;
5006                   C : Elmt_Id;
5007
5008                begin
5009                   D := First_Discriminant (Etype (Typ));
5010                   C := First_Elmt (Stored_Constraint (Typ));
5011                   while Present (D) and then Present (C) loop
5012                      if Chars (Discrim_Name) = Chars (D) then
5013                         if Is_Entity_Name (Node (C))
5014                           and then Entity (Node (C)) = Entity (Discrim)
5015                         then
5016                            --  D is renamed by Discrim, whose value is given in
5017                            --  Assoc.
5018
5019                            null;
5020
5021                         else
5022                            Assoc :=
5023                              Make_Component_Association (Sloc (Typ),
5024                                New_List
5025                                  (New_Occurrence_Of (D, Sloc (Typ))),
5026                                   Duplicate_Subexpr_No_Checks (Node (C)));
5027                         end if;
5028                         exit Find_Constraint;
5029                      end if;
5030
5031                      Next_Discriminant (D);
5032                      Next_Elmt (C);
5033                   end loop;
5034                end;
5035             end if;
5036          end if;
5037
5038          if No (Next (Assoc)) then
5039             Error_Msg_NE (" missing value for discriminant&",
5040               First (Governed_By), Discrim_Name);
5041             Report_Errors := True;
5042             return;
5043          end if;
5044
5045          Next (Assoc);
5046       end loop Find_Constraint;
5047
5048       Discrim_Value := Expression (Assoc);
5049
5050       if not Is_OK_Static_Expression (Discrim_Value) then
5051          Error_Msg_FE
5052            ("value for discriminant & must be static!",
5053             Discrim_Value, Discrim);
5054          Why_Not_Static (Discrim_Value);
5055          Report_Errors := True;
5056          return;
5057       end if;
5058
5059       Search_For_Discriminant_Value : declare
5060          Low  : Node_Id;
5061          High : Node_Id;
5062
5063          UI_High          : Uint;
5064          UI_Low           : Uint;
5065          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
5066
5067       begin
5068          Find_Discrete_Value : while Present (Variant) loop
5069             Discrete_Choice := First (Discrete_Choices (Variant));
5070             while Present (Discrete_Choice) loop
5071
5072                exit Find_Discrete_Value when
5073                  Nkind (Discrete_Choice) = N_Others_Choice;
5074
5075                Get_Index_Bounds (Discrete_Choice, Low, High);
5076
5077                UI_Low  := Expr_Value (Low);
5078                UI_High := Expr_Value (High);
5079
5080                exit Find_Discrete_Value when
5081                  UI_Low <= UI_Discrim_Value
5082                    and then
5083                  UI_High >= UI_Discrim_Value;
5084
5085                Next (Discrete_Choice);
5086             end loop;
5087
5088             Next_Non_Pragma (Variant);
5089          end loop Find_Discrete_Value;
5090       end Search_For_Discriminant_Value;
5091
5092       if No (Variant) then
5093          Error_Msg_NE
5094            ("value of discriminant & is out of range", Discrim_Value, Discrim);
5095          Report_Errors := True;
5096          return;
5097       end  if;
5098
5099       --  If we have found the corresponding choice, recursively add its
5100       --  components to the Into list.
5101
5102       Gather_Components (Empty,
5103         Component_List (Variant), Governed_By, Into, Report_Errors);
5104    end Gather_Components;
5105
5106    ------------------------
5107    -- Get_Actual_Subtype --
5108    ------------------------
5109
5110    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
5111       Typ  : constant Entity_Id := Etype (N);
5112       Utyp : Entity_Id := Underlying_Type (Typ);
5113       Decl : Node_Id;
5114       Atyp : Entity_Id;
5115
5116    begin
5117       if No (Utyp) then
5118          Utyp := Typ;
5119       end if;
5120
5121       --  If what we have is an identifier that references a subprogram
5122       --  formal, or a variable or constant object, then we get the actual
5123       --  subtype from the referenced entity if one has been built.
5124
5125       if Nkind (N) = N_Identifier
5126         and then
5127           (Is_Formal (Entity (N))
5128             or else Ekind (Entity (N)) = E_Constant
5129             or else Ekind (Entity (N)) = E_Variable)
5130         and then Present (Actual_Subtype (Entity (N)))
5131       then
5132          return Actual_Subtype (Entity (N));
5133
5134       --  Actual subtype of unchecked union is always itself. We never need
5135       --  the "real" actual subtype. If we did, we couldn't get it anyway
5136       --  because the discriminant is not available. The restrictions on
5137       --  Unchecked_Union are designed to make sure that this is OK.
5138
5139       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
5140          return Typ;
5141
5142       --  Here for the unconstrained case, we must find actual subtype
5143       --  No actual subtype is available, so we must build it on the fly.
5144
5145       --  Checking the type, not the underlying type, for constrainedness
5146       --  seems to be necessary. Maybe all the tests should be on the type???
5147
5148       elsif (not Is_Constrained (Typ))
5149            and then (Is_Array_Type (Utyp)
5150                       or else (Is_Record_Type (Utyp)
5151                                 and then Has_Discriminants (Utyp)))
5152            and then not Has_Unknown_Discriminants (Utyp)
5153            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
5154       then
5155          --  Nothing to do if in spec expression (why not???)
5156
5157          if In_Spec_Expression then
5158             return Typ;
5159
5160          elsif Is_Private_Type (Typ)
5161            and then not Has_Discriminants (Typ)
5162          then
5163             --  If the type has no discriminants, there is no subtype to
5164             --  build, even if the underlying type is discriminated.
5165
5166             return Typ;
5167
5168          --  Else build the actual subtype
5169
5170          else
5171             Decl := Build_Actual_Subtype (Typ, N);
5172             Atyp := Defining_Identifier (Decl);
5173
5174             --  If Build_Actual_Subtype generated a new declaration then use it
5175
5176             if Atyp /= Typ then
5177
5178                --  The actual subtype is an Itype, so analyze the declaration,
5179                --  but do not attach it to the tree, to get the type defined.
5180
5181                Set_Parent (Decl, N);
5182                Set_Is_Itype (Atyp);
5183                Analyze (Decl, Suppress => All_Checks);
5184                Set_Associated_Node_For_Itype (Atyp, N);
5185                Set_Has_Delayed_Freeze (Atyp, False);
5186
5187                --  We need to freeze the actual subtype immediately. This is
5188                --  needed, because otherwise this Itype will not get frozen
5189                --  at all, and it is always safe to freeze on creation because
5190                --  any associated types must be frozen at this point.
5191
5192                Freeze_Itype (Atyp, N);
5193                return Atyp;
5194
5195             --  Otherwise we did not build a declaration, so return original
5196
5197             else
5198                return Typ;
5199             end if;
5200          end if;
5201
5202       --  For all remaining cases, the actual subtype is the same as
5203       --  the nominal type.
5204
5205       else
5206          return Typ;
5207       end if;
5208    end Get_Actual_Subtype;
5209
5210    -------------------------------------
5211    -- Get_Actual_Subtype_If_Available --
5212    -------------------------------------
5213
5214    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
5215       Typ  : constant Entity_Id := Etype (N);
5216
5217    begin
5218       --  If what we have is an identifier that references a subprogram
5219       --  formal, or a variable or constant object, then we get the actual
5220       --  subtype from the referenced entity if one has been built.
5221
5222       if Nkind (N) = N_Identifier
5223         and then
5224           (Is_Formal (Entity (N))
5225             or else Ekind (Entity (N)) = E_Constant
5226             or else Ekind (Entity (N)) = E_Variable)
5227         and then Present (Actual_Subtype (Entity (N)))
5228       then
5229          return Actual_Subtype (Entity (N));
5230
5231       --  Otherwise the Etype of N is returned unchanged
5232
5233       else
5234          return Typ;
5235       end if;
5236    end Get_Actual_Subtype_If_Available;
5237
5238    ------------------------
5239    -- Get_Body_From_Stub --
5240    ------------------------
5241
5242    function Get_Body_From_Stub (N : Node_Id) return Node_Id is
5243    begin
5244       return Proper_Body (Unit (Library_Unit (N)));
5245    end Get_Body_From_Stub;
5246
5247    -------------------------------
5248    -- Get_Default_External_Name --
5249    -------------------------------
5250
5251    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
5252    begin
5253       Get_Decoded_Name_String (Chars (E));
5254
5255       if Opt.External_Name_Imp_Casing = Uppercase then
5256          Set_Casing (All_Upper_Case);
5257       else
5258          Set_Casing (All_Lower_Case);
5259       end if;
5260
5261       return
5262         Make_String_Literal (Sloc (E),
5263           Strval => String_From_Name_Buffer);
5264    end Get_Default_External_Name;
5265
5266    --------------------------
5267    -- Get_Enclosing_Object --
5268    --------------------------
5269
5270    function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
5271    begin
5272       if Is_Entity_Name (N) then
5273          return Entity (N);
5274       else
5275          case Nkind (N) is
5276             when N_Indexed_Component  |
5277                  N_Slice              |
5278                  N_Selected_Component =>
5279
5280                --  If not generating code, a dereference may be left implicit.
5281                --  In thoses cases, return Empty.
5282
5283                if Is_Access_Type (Etype (Prefix (N))) then
5284                   return Empty;
5285                else
5286                   return Get_Enclosing_Object (Prefix (N));
5287                end if;
5288
5289             when N_Type_Conversion =>
5290                return Get_Enclosing_Object (Expression (N));
5291
5292             when others =>
5293                return Empty;
5294          end case;
5295       end if;
5296    end Get_Enclosing_Object;
5297
5298    ---------------------------
5299    -- Get_Enum_Lit_From_Pos --
5300    ---------------------------
5301
5302    function Get_Enum_Lit_From_Pos
5303      (T   : Entity_Id;
5304       Pos : Uint;
5305       Loc : Source_Ptr) return Node_Id
5306    is
5307       Btyp : Entity_Id := Base_Type (T);
5308       Lit  : Node_Id;
5309
5310    begin
5311       --  In the case where the literal is of type Character, Wide_Character
5312       --  or Wide_Wide_Character or of a type derived from them, there needs
5313       --  to be some special handling since there is no explicit chain of
5314       --  literals to search. Instead, an N_Character_Literal node is created
5315       --  with the appropriate Char_Code and Chars fields.
5316
5317       if Is_Standard_Character_Type (T) then
5318          Set_Character_Literal_Name (UI_To_CC (Pos));
5319          return
5320            Make_Character_Literal (Loc,
5321              Chars              => Name_Find,
5322              Char_Literal_Value => Pos);
5323
5324       --  For all other cases, we have a complete table of literals, and
5325       --  we simply iterate through the chain of literal until the one
5326       --  with the desired position value is found.
5327       --
5328
5329       else
5330          if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
5331             Btyp := Full_View (Btyp);
5332          end if;
5333
5334          Lit := First_Literal (Btyp);
5335          for J in 1 .. UI_To_Int (Pos) loop
5336             Next_Literal (Lit);
5337          end loop;
5338
5339          return New_Occurrence_Of (Lit, Loc);
5340       end if;
5341    end Get_Enum_Lit_From_Pos;
5342
5343    ---------------------------------
5344    -- Get_Ensures_From_CTC_Pragma --
5345    ---------------------------------
5346
5347    function Get_Ensures_From_CTC_Pragma (N : Node_Id) return Node_Id is
5348       Args : constant List_Id := Pragma_Argument_Associations (N);
5349       Res  : Node_Id;
5350
5351    begin
5352       if List_Length (Args) = 4 then
5353          Res := Pick (Args, 4);
5354
5355       elsif List_Length (Args) = 3 then
5356          Res := Pick (Args, 3);
5357
5358          if Chars (Res) /= Name_Ensures then
5359             Res := Empty;
5360          end if;
5361
5362       else
5363          Res := Empty;
5364       end if;
5365
5366       return Res;
5367    end Get_Ensures_From_CTC_Pragma;
5368
5369    ------------------------
5370    -- Get_Generic_Entity --
5371    ------------------------
5372
5373    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
5374       Ent : constant Entity_Id := Entity (Name (N));
5375    begin
5376       if Present (Renamed_Object (Ent)) then
5377          return Renamed_Object (Ent);
5378       else
5379          return Ent;
5380       end if;
5381    end Get_Generic_Entity;
5382
5383    ----------------------
5384    -- Get_Index_Bounds --
5385    ----------------------
5386
5387    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
5388       Kind : constant Node_Kind := Nkind (N);
5389       R    : Node_Id;
5390
5391    begin
5392       if Kind = N_Range then
5393          L := Low_Bound (N);
5394          H := High_Bound (N);
5395
5396       elsif Kind = N_Subtype_Indication then
5397          R := Range_Expression (Constraint (N));
5398
5399          if R = Error then
5400             L := Error;
5401             H := Error;
5402             return;
5403
5404          else
5405             L := Low_Bound  (Range_Expression (Constraint (N)));
5406             H := High_Bound (Range_Expression (Constraint (N)));
5407          end if;
5408
5409       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
5410          if Error_Posted (Scalar_Range (Entity (N))) then
5411             L := Error;
5412             H := Error;
5413
5414          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
5415             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
5416
5417          else
5418             L := Low_Bound  (Scalar_Range (Entity (N)));
5419             H := High_Bound (Scalar_Range (Entity (N)));
5420          end if;
5421
5422       else
5423          --  N is an expression, indicating a range with one value
5424
5425          L := N;
5426          H := N;
5427       end if;
5428    end Get_Index_Bounds;
5429
5430    ----------------------------------
5431    -- Get_Library_Unit_Name_string --
5432    ----------------------------------
5433
5434    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
5435       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
5436
5437    begin
5438       Get_Unit_Name_String (Unit_Name_Id);
5439
5440       --  Remove seven last character (" (spec)" or " (body)")
5441
5442       Name_Len := Name_Len - 7;
5443       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
5444    end Get_Library_Unit_Name_String;
5445
5446    ------------------------
5447    -- Get_Name_Entity_Id --
5448    ------------------------
5449
5450    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
5451    begin
5452       return Entity_Id (Get_Name_Table_Info (Id));
5453    end Get_Name_Entity_Id;
5454
5455    ------------------------------
5456    -- Get_Name_From_CTC_Pragma --
5457    ------------------------------
5458
5459    function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
5460       Arg : constant Node_Id :=
5461               Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
5462    begin
5463       return Strval (Expr_Value_S (Arg));
5464    end Get_Name_From_CTC_Pragma;
5465
5466    -------------------
5467    -- Get_Pragma_Id --
5468    -------------------
5469
5470    function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
5471    begin
5472       return Get_Pragma_Id (Pragma_Name (N));
5473    end Get_Pragma_Id;
5474
5475    ---------------------------
5476    -- Get_Referenced_Object --
5477    ---------------------------
5478
5479    function Get_Referenced_Object (N : Node_Id) return Node_Id is
5480       R : Node_Id;
5481
5482    begin
5483       R := N;
5484       while Is_Entity_Name (R)
5485         and then Present (Renamed_Object (Entity (R)))
5486       loop
5487          R := Renamed_Object (Entity (R));
5488       end loop;
5489
5490       return R;
5491    end Get_Referenced_Object;
5492
5493    ------------------------
5494    -- Get_Renamed_Entity --
5495    ------------------------
5496
5497    function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
5498       R : Entity_Id;
5499
5500    begin
5501       R := E;
5502       while Present (Renamed_Entity (R)) loop
5503          R := Renamed_Entity (R);
5504       end loop;
5505
5506       return R;
5507    end Get_Renamed_Entity;
5508
5509    ----------------------------------
5510    -- Get_Requires_From_CTC_Pragma --
5511    ----------------------------------
5512
5513    function Get_Requires_From_CTC_Pragma (N : Node_Id) return Node_Id is
5514       Args : constant List_Id := Pragma_Argument_Associations (N);
5515       Res  : Node_Id;
5516
5517    begin
5518       if List_Length (Args) >= 3 then
5519          Res := Pick (Args, 3);
5520
5521          if Chars (Res) /= Name_Requires then
5522             Res := Empty;
5523          end if;
5524
5525       else
5526          Res := Empty;
5527       end if;
5528
5529       return Res;
5530    end Get_Requires_From_CTC_Pragma;
5531
5532    -------------------------
5533    -- Get_Subprogram_Body --
5534    -------------------------
5535
5536    function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
5537       Decl : Node_Id;
5538
5539    begin
5540       Decl := Unit_Declaration_Node (E);
5541
5542       if Nkind (Decl) = N_Subprogram_Body then
5543          return Decl;
5544
5545       --  The below comment is bad, because it is possible for
5546       --  Nkind (Decl) to be an N_Subprogram_Body_Stub ???
5547
5548       else           --  Nkind (Decl) = N_Subprogram_Declaration
5549
5550          if Present (Corresponding_Body (Decl)) then
5551             return Unit_Declaration_Node (Corresponding_Body (Decl));
5552
5553          --  Imported subprogram case
5554
5555          else
5556             return Empty;
5557          end if;
5558       end if;
5559    end Get_Subprogram_Body;
5560
5561    ---------------------------
5562    -- Get_Subprogram_Entity --
5563    ---------------------------
5564
5565    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
5566       Nam  : Node_Id;
5567       Proc : Entity_Id;
5568
5569    begin
5570       if Nkind (Nod) = N_Accept_Statement then
5571          Nam := Entry_Direct_Name (Nod);
5572
5573       --  For an entry call, the prefix of the call is a selected component.
5574       --  Need additional code for internal calls ???
5575
5576       elsif Nkind (Nod) = N_Entry_Call_Statement then
5577          if Nkind (Name (Nod)) = N_Selected_Component then
5578             Nam := Entity (Selector_Name (Name (Nod)));
5579          else
5580             Nam := Empty;
5581          end if;
5582
5583       else
5584          Nam := Name (Nod);
5585       end if;
5586
5587       if Nkind (Nam) = N_Explicit_Dereference then
5588          Proc := Etype (Prefix (Nam));
5589       elsif Is_Entity_Name (Nam) then
5590          Proc := Entity (Nam);
5591       else
5592          return Empty;
5593       end if;
5594
5595       if Is_Object (Proc) then
5596          Proc := Etype (Proc);
5597       end if;
5598
5599       if Ekind (Proc) = E_Access_Subprogram_Type then
5600          Proc := Directly_Designated_Type (Proc);
5601       end if;
5602
5603       if not Is_Subprogram (Proc)
5604         and then Ekind (Proc) /= E_Subprogram_Type
5605       then
5606          return Empty;
5607       else
5608          return Proc;
5609       end if;
5610    end Get_Subprogram_Entity;
5611
5612    -----------------------------
5613    -- Get_Task_Body_Procedure --
5614    -----------------------------
5615
5616    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
5617    begin
5618       --  Note: A task type may be the completion of a private type with
5619       --  discriminants. When performing elaboration checks on a task
5620       --  declaration, the current view of the type may be the private one,
5621       --  and the procedure that holds the body of the task is held in its
5622       --  underlying type.
5623
5624       --  This is an odd function, why not have Task_Body_Procedure do
5625       --  the following digging???
5626
5627       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
5628    end Get_Task_Body_Procedure;
5629
5630    -----------------------
5631    -- Has_Access_Values --
5632    -----------------------
5633
5634    function Has_Access_Values (T : Entity_Id) return Boolean is
5635       Typ : constant Entity_Id := Underlying_Type (T);
5636
5637    begin
5638       --  Case of a private type which is not completed yet. This can only
5639       --  happen in the case of a generic format type appearing directly, or
5640       --  as a component of the type to which this function is being applied
5641       --  at the top level. Return False in this case, since we certainly do
5642       --  not know that the type contains access types.
5643
5644       if No (Typ) then
5645          return False;
5646
5647       elsif Is_Access_Type (Typ) then
5648          return True;
5649
5650       elsif Is_Array_Type (Typ) then
5651          return Has_Access_Values (Component_Type (Typ));
5652
5653       elsif Is_Record_Type (Typ) then
5654          declare
5655             Comp : Entity_Id;
5656
5657          begin
5658             --  Loop to Check components
5659
5660             Comp := First_Component_Or_Discriminant (Typ);
5661             while Present (Comp) loop
5662
5663                --  Check for access component, tag field does not count, even
5664                --  though it is implemented internally using an access type.
5665
5666                if Has_Access_Values (Etype (Comp))
5667                  and then Chars (Comp) /= Name_uTag
5668                then
5669                   return True;
5670                end if;
5671
5672                Next_Component_Or_Discriminant (Comp);
5673             end loop;
5674          end;
5675
5676          return False;
5677
5678       else
5679          return False;
5680       end if;
5681    end Has_Access_Values;
5682
5683    ------------------------------
5684    -- Has_Compatible_Alignment --
5685    ------------------------------
5686
5687    function Has_Compatible_Alignment
5688      (Obj  : Entity_Id;
5689       Expr : Node_Id) return Alignment_Result
5690    is
5691       function Has_Compatible_Alignment_Internal
5692         (Obj     : Entity_Id;
5693          Expr    : Node_Id;
5694          Default : Alignment_Result) return Alignment_Result;
5695       --  This is the internal recursive function that actually does the work.
5696       --  There is one additional parameter, which says what the result should
5697       --  be if no alignment information is found, and there is no definite
5698       --  indication of compatible alignments. At the outer level, this is set
5699       --  to Unknown, but for internal recursive calls in the case where types
5700       --  are known to be correct, it is set to Known_Compatible.
5701
5702       ---------------------------------------
5703       -- Has_Compatible_Alignment_Internal --
5704       ---------------------------------------
5705
5706       function Has_Compatible_Alignment_Internal
5707         (Obj     : Entity_Id;
5708          Expr    : Node_Id;
5709          Default : Alignment_Result) return Alignment_Result
5710       is
5711          Result : Alignment_Result := Known_Compatible;
5712          --  Holds the current status of the result. Note that once a value of
5713          --  Known_Incompatible is set, it is sticky and does not get changed
5714          --  to Unknown (the value in Result only gets worse as we go along,
5715          --  never better).
5716
5717          Offs : Uint := No_Uint;
5718          --  Set to a factor of the offset from the base object when Expr is a
5719          --  selected or indexed component, based on Component_Bit_Offset and
5720          --  Component_Size respectively. A negative value is used to represent
5721          --  a value which is not known at compile time.
5722
5723          procedure Check_Prefix;
5724          --  Checks the prefix recursively in the case where the expression
5725          --  is an indexed or selected component.
5726
5727          procedure Set_Result (R : Alignment_Result);
5728          --  If R represents a worse outcome (unknown instead of known
5729          --  compatible, or known incompatible), then set Result to R.
5730
5731          ------------------
5732          -- Check_Prefix --
5733          ------------------
5734
5735          procedure Check_Prefix is
5736          begin
5737             --  The subtlety here is that in doing a recursive call to check
5738             --  the prefix, we have to decide what to do in the case where we
5739             --  don't find any specific indication of an alignment problem.
5740
5741             --  At the outer level, we normally set Unknown as the result in
5742             --  this case, since we can only set Known_Compatible if we really
5743             --  know that the alignment value is OK, but for the recursive
5744             --  call, in the case where the types match, and we have not
5745             --  specified a peculiar alignment for the object, we are only
5746             --  concerned about suspicious rep clauses, the default case does
5747             --  not affect us, since the compiler will, in the absence of such
5748             --  rep clauses, ensure that the alignment is correct.
5749
5750             if Default = Known_Compatible
5751               or else
5752                 (Etype (Obj) = Etype (Expr)
5753                   and then (Unknown_Alignment (Obj)
5754                              or else
5755                                Alignment (Obj) = Alignment (Etype (Obj))))
5756             then
5757                Set_Result
5758                  (Has_Compatible_Alignment_Internal
5759                     (Obj, Prefix (Expr), Known_Compatible));
5760
5761             --  In all other cases, we need a full check on the prefix
5762
5763             else
5764                Set_Result
5765                  (Has_Compatible_Alignment_Internal
5766                     (Obj, Prefix (Expr), Unknown));
5767             end if;
5768          end Check_Prefix;
5769
5770          ----------------
5771          -- Set_Result --
5772          ----------------
5773
5774          procedure Set_Result (R : Alignment_Result) is
5775          begin
5776             if R > Result then
5777                Result := R;
5778             end if;
5779          end Set_Result;
5780
5781       --  Start of processing for Has_Compatible_Alignment_Internal
5782
5783       begin
5784          --  If Expr is a selected component, we must make sure there is no
5785          --  potentially troublesome component clause, and that the record is
5786          --  not packed.
5787
5788          if Nkind (Expr) = N_Selected_Component then
5789
5790             --  Packed record always generate unknown alignment
5791
5792             if Is_Packed (Etype (Prefix (Expr))) then
5793                Set_Result (Unknown);
5794             end if;
5795
5796             --  Check prefix and component offset
5797
5798             Check_Prefix;
5799             Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
5800
5801          --  If Expr is an indexed component, we must make sure there is no
5802          --  potentially troublesome Component_Size clause and that the array
5803          --  is not bit-packed.
5804
5805          elsif Nkind (Expr) = N_Indexed_Component then
5806             declare
5807                Typ : constant Entity_Id := Etype (Prefix (Expr));
5808                Ind : constant Node_Id   := First_Index (Typ);
5809
5810             begin
5811                --  Bit packed array always generates unknown alignment
5812
5813                if Is_Bit_Packed_Array (Typ) then
5814                   Set_Result (Unknown);
5815                end if;
5816
5817                --  Check prefix and component offset
5818
5819                Check_Prefix;
5820                Offs := Component_Size (Typ);
5821
5822                --  Small optimization: compute the full offset when possible
5823
5824                if Offs /= No_Uint
5825                  and then Offs > Uint_0
5826                  and then Present (Ind)
5827                  and then Nkind (Ind) = N_Range
5828                  and then Compile_Time_Known_Value (Low_Bound (Ind))
5829                  and then Compile_Time_Known_Value (First (Expressions (Expr)))
5830                then
5831                   Offs := Offs * (Expr_Value (First (Expressions (Expr)))
5832                                     - Expr_Value (Low_Bound ((Ind))));
5833                end if;
5834             end;
5835          end if;
5836
5837          --  If we have a null offset, the result is entirely determined by
5838          --  the base object and has already been computed recursively.
5839
5840          if Offs = Uint_0 then
5841             null;
5842
5843          --  Case where we know the alignment of the object
5844
5845          elsif Known_Alignment (Obj) then
5846             declare
5847                ObjA : constant Uint := Alignment (Obj);
5848                ExpA : Uint          := No_Uint;
5849                SizA : Uint          := No_Uint;
5850
5851             begin
5852                --  If alignment of Obj is 1, then we are always OK
5853
5854                if ObjA = 1 then
5855                   Set_Result (Known_Compatible);
5856
5857                --  Alignment of Obj is greater than 1, so we need to check
5858
5859                else
5860                   --  If we have an offset, see if it is compatible
5861
5862                   if Offs /= No_Uint and Offs > Uint_0 then
5863                      if Offs mod (System_Storage_Unit * ObjA) /= 0 then
5864                         Set_Result (Known_Incompatible);
5865                      end if;
5866
5867                      --  See if Expr is an object with known alignment
5868
5869                   elsif Is_Entity_Name (Expr)
5870                     and then Known_Alignment (Entity (Expr))
5871                   then
5872                      ExpA := Alignment (Entity (Expr));
5873
5874                      --  Otherwise, we can use the alignment of the type of
5875                      --  Expr given that we already checked for
5876                      --  discombobulating rep clauses for the cases of indexed
5877                      --  and selected components above.
5878
5879                   elsif Known_Alignment (Etype (Expr)) then
5880                      ExpA := Alignment (Etype (Expr));
5881
5882                      --  Otherwise the alignment is unknown
5883
5884                   else
5885                      Set_Result (Default);
5886                   end if;
5887
5888                   --  If we got an alignment, see if it is acceptable
5889
5890                   if ExpA /= No_Uint and then ExpA < ObjA then
5891                      Set_Result (Known_Incompatible);
5892                   end if;
5893
5894                   --  If Expr is not a piece of a larger object, see if size
5895                   --  is given. If so, check that it is not too small for the
5896                   --  required alignment.
5897
5898                   if Offs /= No_Uint then
5899                      null;
5900
5901                      --  See if Expr is an object with known size
5902
5903                   elsif Is_Entity_Name (Expr)
5904                     and then Known_Static_Esize (Entity (Expr))
5905                   then
5906                      SizA := Esize (Entity (Expr));
5907
5908                      --  Otherwise, we check the object size of the Expr type
5909
5910                   elsif Known_Static_Esize (Etype (Expr)) then
5911                      SizA := Esize (Etype (Expr));
5912                   end if;
5913
5914                   --  If we got a size, see if it is a multiple of the Obj
5915                   --  alignment, if not, then the alignment cannot be
5916                   --  acceptable, since the size is always a multiple of the
5917                   --  alignment.
5918
5919                   if SizA /= No_Uint then
5920                      if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
5921                         Set_Result (Known_Incompatible);
5922                      end if;
5923                   end if;
5924                end if;
5925             end;
5926
5927          --  If we do not know required alignment, any non-zero offset is a
5928          --  potential problem (but certainly may be OK, so result is unknown).
5929
5930          elsif Offs /= No_Uint then
5931             Set_Result (Unknown);
5932
5933          --  If we can't find the result by direct comparison of alignment
5934          --  values, then there is still one case that we can determine known
5935          --  result, and that is when we can determine that the types are the
5936          --  same, and no alignments are specified. Then we known that the
5937          --  alignments are compatible, even if we don't know the alignment
5938          --  value in the front end.
5939
5940          elsif Etype (Obj) = Etype (Expr) then
5941
5942             --  Types are the same, but we have to check for possible size
5943             --  and alignments on the Expr object that may make the alignment
5944             --  different, even though the types are the same.
5945
5946             if Is_Entity_Name (Expr) then
5947
5948                --  First check alignment of the Expr object. Any alignment less
5949                --  than Maximum_Alignment is worrisome since this is the case
5950                --  where we do not know the alignment of Obj.
5951
5952                if Known_Alignment (Entity (Expr))
5953                  and then
5954                    UI_To_Int (Alignment (Entity (Expr))) <
5955                                                     Ttypes.Maximum_Alignment
5956                then
5957                   Set_Result (Unknown);
5958
5959                   --  Now check size of Expr object. Any size that is not an
5960                   --  even multiple of Maximum_Alignment is also worrisome
5961                   --  since it may cause the alignment of the object to be less
5962                   --  than the alignment of the type.
5963
5964                elsif Known_Static_Esize (Entity (Expr))
5965                  and then
5966                    (UI_To_Int (Esize (Entity (Expr))) mod
5967                      (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
5968                                                                         /= 0
5969                then
5970                   Set_Result (Unknown);
5971
5972                   --  Otherwise same type is decisive
5973
5974                else
5975                   Set_Result (Known_Compatible);
5976                end if;
5977             end if;
5978
5979          --  Another case to deal with is when there is an explicit size or
5980          --  alignment clause when the types are not the same. If so, then the
5981          --  result is Unknown. We don't need to do this test if the Default is
5982          --  Unknown, since that result will be set in any case.
5983
5984          elsif Default /= Unknown
5985            and then (Has_Size_Clause      (Etype (Expr))
5986                       or else
5987                      Has_Alignment_Clause (Etype (Expr)))
5988          then
5989             Set_Result (Unknown);
5990
5991          --  If no indication found, set default
5992
5993          else
5994             Set_Result (Default);
5995          end if;
5996
5997          --  Return worst result found
5998
5999          return Result;
6000       end Has_Compatible_Alignment_Internal;
6001
6002    --  Start of processing for Has_Compatible_Alignment
6003
6004    begin
6005       --  If Obj has no specified alignment, then set alignment from the type
6006       --  alignment. Perhaps we should always do this, but for sure we should
6007       --  do it when there is an address clause since we can do more if the
6008       --  alignment is known.
6009
6010       if Unknown_Alignment (Obj) then
6011          Set_Alignment (Obj, Alignment (Etype (Obj)));
6012       end if;
6013
6014       --  Now do the internal call that does all the work
6015
6016       return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
6017    end Has_Compatible_Alignment;
6018
6019    ----------------------
6020    -- Has_Declarations --
6021    ----------------------
6022
6023    function Has_Declarations (N : Node_Id) return Boolean is
6024    begin
6025       return Nkind_In (Nkind (N), N_Accept_Statement,
6026                                   N_Block_Statement,
6027                                   N_Compilation_Unit_Aux,
6028                                   N_Entry_Body,
6029                                   N_Package_Body,
6030                                   N_Protected_Body,
6031                                   N_Subprogram_Body,
6032                                   N_Task_Body,
6033                                   N_Package_Specification);
6034    end Has_Declarations;
6035
6036    -------------------
6037    -- Has_Denormals --
6038    -------------------
6039
6040    function Has_Denormals (E : Entity_Id) return Boolean is
6041    begin
6042       return Is_Floating_Point_Type (E)
6043         and then Denorm_On_Target
6044         and then not Vax_Float (E);
6045    end Has_Denormals;
6046
6047    -------------------------------------------
6048    -- Has_Discriminant_Dependent_Constraint --
6049    -------------------------------------------
6050
6051    function Has_Discriminant_Dependent_Constraint
6052      (Comp : Entity_Id) return Boolean
6053    is
6054       Comp_Decl  : constant Node_Id := Parent (Comp);
6055       Subt_Indic : constant Node_Id :=
6056                      Subtype_Indication (Component_Definition (Comp_Decl));
6057       Constr     : Node_Id;
6058       Assn       : Node_Id;
6059
6060    begin
6061       if Nkind (Subt_Indic) = N_Subtype_Indication then
6062          Constr := Constraint (Subt_Indic);
6063
6064          if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
6065             Assn := First (Constraints (Constr));
6066             while Present (Assn) loop
6067                case Nkind (Assn) is
6068                   when N_Subtype_Indication |
6069                        N_Range              |
6070                        N_Identifier
6071                   =>
6072                      if Depends_On_Discriminant (Assn) then
6073                         return True;
6074                      end if;
6075
6076                   when N_Discriminant_Association =>
6077                      if Depends_On_Discriminant (Expression (Assn)) then
6078                         return True;
6079                      end if;
6080
6081                   when others =>
6082                      null;
6083
6084                end case;
6085
6086                Next (Assn);
6087             end loop;
6088          end if;
6089       end if;
6090
6091       return False;
6092    end Has_Discriminant_Dependent_Constraint;
6093
6094    --------------------
6095    -- Has_Infinities --
6096    --------------------
6097
6098    function Has_Infinities (E : Entity_Id) return Boolean is
6099    begin
6100       return
6101         Is_Floating_Point_Type (E)
6102           and then Nkind (Scalar_Range (E)) = N_Range
6103           and then Includes_Infinities (Scalar_Range (E));
6104    end Has_Infinities;
6105
6106    --------------------
6107    -- Has_Interfaces --
6108    --------------------
6109
6110    function Has_Interfaces
6111      (T             : Entity_Id;
6112       Use_Full_View : Boolean := True) return Boolean
6113    is
6114       Typ : Entity_Id := Base_Type (T);
6115
6116    begin
6117       --  Handle concurrent types
6118
6119       if Is_Concurrent_Type (Typ) then
6120          Typ := Corresponding_Record_Type (Typ);
6121       end if;
6122
6123       if not Present (Typ)
6124         or else not Is_Record_Type (Typ)
6125         or else not Is_Tagged_Type (Typ)
6126       then
6127          return False;
6128       end if;
6129
6130       --  Handle private types
6131
6132       if Use_Full_View
6133         and then Present (Full_View (Typ))
6134       then
6135          Typ := Full_View (Typ);
6136       end if;
6137
6138       --  Handle concurrent record types
6139
6140       if Is_Concurrent_Record_Type (Typ)
6141         and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
6142       then
6143          return True;
6144       end if;
6145
6146       loop
6147          if Is_Interface (Typ)
6148            or else
6149              (Is_Record_Type (Typ)
6150                and then Present (Interfaces (Typ))
6151                and then not Is_Empty_Elmt_List (Interfaces (Typ)))
6152          then
6153             return True;
6154          end if;
6155
6156          exit when Etype (Typ) = Typ
6157
6158             --  Handle private types
6159
6160             or else (Present (Full_View (Etype (Typ)))
6161                        and then Full_View (Etype (Typ)) = Typ)
6162
6163             --  Protect the frontend against wrong source with cyclic
6164             --  derivations
6165
6166             or else Etype (Typ) = T;
6167
6168          --  Climb to the ancestor type handling private types
6169
6170          if Present (Full_View (Etype (Typ))) then
6171             Typ := Full_View (Etype (Typ));
6172          else
6173             Typ := Etype (Typ);
6174          end if;
6175       end loop;
6176
6177       return False;
6178    end Has_Interfaces;
6179
6180    ------------------------
6181    -- Has_Null_Exclusion --
6182    ------------------------
6183
6184    function Has_Null_Exclusion (N : Node_Id) return Boolean is
6185    begin
6186       case Nkind (N) is
6187          when N_Access_Definition               |
6188               N_Access_Function_Definition      |
6189               N_Access_Procedure_Definition     |
6190               N_Access_To_Object_Definition     |
6191               N_Allocator                       |
6192               N_Derived_Type_Definition         |
6193               N_Function_Specification          |
6194               N_Subtype_Declaration             =>
6195             return Null_Exclusion_Present (N);
6196
6197          when N_Component_Definition            |
6198               N_Formal_Object_Declaration       |
6199               N_Object_Renaming_Declaration     =>
6200             if Present (Subtype_Mark (N)) then
6201                return Null_Exclusion_Present (N);
6202             else pragma Assert (Present (Access_Definition (N)));
6203                return Null_Exclusion_Present (Access_Definition (N));
6204             end if;
6205
6206          when N_Discriminant_Specification =>
6207             if Nkind (Discriminant_Type (N)) = N_Access_Definition then
6208                return Null_Exclusion_Present (Discriminant_Type (N));
6209             else
6210                return Null_Exclusion_Present (N);
6211             end if;
6212
6213          when N_Object_Declaration =>
6214             if Nkind (Object_Definition (N)) = N_Access_Definition then
6215                return Null_Exclusion_Present (Object_Definition (N));
6216             else
6217                return Null_Exclusion_Present (N);
6218             end if;
6219
6220          when N_Parameter_Specification =>
6221             if Nkind (Parameter_Type (N)) = N_Access_Definition then
6222                return Null_Exclusion_Present (Parameter_Type (N));
6223             else
6224                return Null_Exclusion_Present (N);
6225             end if;
6226
6227          when others =>
6228             return False;
6229
6230       end case;
6231    end Has_Null_Exclusion;
6232
6233    ------------------------
6234    -- Has_Null_Extension --
6235    ------------------------
6236
6237    function Has_Null_Extension (T : Entity_Id) return Boolean is
6238       B     : constant Entity_Id := Base_Type (T);
6239       Comps : Node_Id;
6240       Ext   : Node_Id;
6241
6242    begin
6243       if Nkind (Parent (B)) = N_Full_Type_Declaration
6244         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
6245       then
6246          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
6247
6248          if Present (Ext) then
6249             if Null_Present (Ext) then
6250                return True;
6251             else
6252                Comps := Component_List (Ext);
6253
6254                --  The null component list is rewritten during analysis to
6255                --  include the parent component. Any other component indicates
6256                --  that the extension was not originally null.
6257
6258                return Null_Present (Comps)
6259                  or else No (Next (First (Component_Items (Comps))));
6260             end if;
6261          else
6262             return False;
6263          end if;
6264
6265       else
6266          return False;
6267       end if;
6268    end Has_Null_Extension;
6269
6270    -------------------------------
6271    -- Has_Overriding_Initialize --
6272    -------------------------------
6273
6274    function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
6275       BT   : constant Entity_Id := Base_Type (T);
6276       P    : Elmt_Id;
6277
6278    begin
6279       if Is_Controlled (BT) then
6280          if Is_RTU (Scope (BT), Ada_Finalization) then
6281             return False;
6282
6283          elsif Present (Primitive_Operations (BT)) then
6284             P := First_Elmt (Primitive_Operations (BT));
6285             while Present (P) loop
6286                declare
6287                   Init : constant Entity_Id := Node (P);
6288                   Formal : constant Entity_Id := First_Formal (Init);
6289                begin
6290                   if Ekind (Init) = E_Procedure
6291                        and then Chars (Init) = Name_Initialize
6292                        and then Comes_From_Source (Init)
6293                        and then Present (Formal)
6294                        and then Etype (Formal) = BT
6295                        and then No (Next_Formal (Formal))
6296                        and then (Ada_Version < Ada_2012
6297                                    or else not Null_Present (Parent (Init)))
6298                   then
6299                      return True;
6300                   end if;
6301                end;
6302
6303                Next_Elmt (P);
6304             end loop;
6305          end if;
6306
6307          --  Here if type itself does not have a non-null Initialize operation:
6308          --  check immediate ancestor.
6309
6310          if Is_Derived_Type (BT)
6311            and then Has_Overriding_Initialize (Etype (BT))
6312          then
6313             return True;
6314          end if;
6315       end if;
6316
6317       return False;
6318    end Has_Overriding_Initialize;
6319
6320    --------------------------------------
6321    -- Has_Preelaborable_Initialization --
6322    --------------------------------------
6323
6324    function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
6325       Has_PE : Boolean;
6326
6327       procedure Check_Components (E : Entity_Id);
6328       --  Check component/discriminant chain, sets Has_PE False if a component
6329       --  or discriminant does not meet the preelaborable initialization rules.
6330
6331       ----------------------
6332       -- Check_Components --
6333       ----------------------
6334
6335       procedure Check_Components (E : Entity_Id) is
6336          Ent : Entity_Id;
6337          Exp : Node_Id;
6338
6339          function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
6340          --  Returns True if and only if the expression denoted by N does not
6341          --  violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
6342
6343          ---------------------------------
6344          -- Is_Preelaborable_Expression --
6345          ---------------------------------
6346
6347          function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
6348             Exp           : Node_Id;
6349             Assn          : Node_Id;
6350             Choice        : Node_Id;
6351             Comp_Type     : Entity_Id;
6352             Is_Array_Aggr : Boolean;
6353
6354          begin
6355             if Is_Static_Expression (N) then
6356                return True;
6357
6358             elsif Nkind (N) = N_Null then
6359                return True;
6360
6361             --  Attributes are allowed in general, even if their prefix is a
6362             --  formal type. (It seems that certain attributes known not to be
6363             --  static might not be allowed, but there are no rules to prevent
6364             --  them.)
6365
6366             elsif Nkind (N) = N_Attribute_Reference then
6367                return True;
6368
6369             --  The name of a discriminant evaluated within its parent type is
6370             --  defined to be preelaborable (10.2.1(8)). Note that we test for
6371             --  names that denote discriminals as well as discriminants to
6372             --  catch references occurring within init procs.
6373
6374             elsif Is_Entity_Name (N)
6375               and then
6376                 (Ekind (Entity (N)) = E_Discriminant
6377                   or else
6378                     ((Ekind (Entity (N)) = E_Constant
6379                        or else Ekind (Entity (N)) = E_In_Parameter)
6380                      and then Present (Discriminal_Link (Entity (N)))))
6381             then
6382                return True;
6383
6384             elsif Nkind (N) = N_Qualified_Expression then
6385                return Is_Preelaborable_Expression (Expression (N));
6386
6387             --  For aggregates we have to check that each of the associations
6388             --  is preelaborable.
6389
6390             elsif Nkind (N) = N_Aggregate
6391               or else Nkind (N) = N_Extension_Aggregate
6392             then
6393                Is_Array_Aggr := Is_Array_Type (Etype (N));
6394
6395                if Is_Array_Aggr then
6396                   Comp_Type := Component_Type (Etype (N));
6397                end if;
6398
6399                --  Check the ancestor part of extension aggregates, which must
6400                --  be either the name of a type that has preelaborable init or
6401                --  an expression that is preelaborable.
6402
6403                if Nkind (N) = N_Extension_Aggregate then
6404                   declare
6405                      Anc_Part : constant Node_Id := Ancestor_Part (N);
6406
6407                   begin
6408                      if Is_Entity_Name (Anc_Part)
6409                        and then Is_Type (Entity (Anc_Part))
6410                      then
6411                         if not Has_Preelaborable_Initialization
6412                                  (Entity (Anc_Part))
6413                         then
6414                            return False;
6415                         end if;
6416
6417                      elsif not Is_Preelaborable_Expression (Anc_Part) then
6418                         return False;
6419                      end if;
6420                   end;
6421                end if;
6422
6423                --  Check positional associations
6424
6425                Exp := First (Expressions (N));
6426                while Present (Exp) loop
6427                   if not Is_Preelaborable_Expression (Exp) then
6428                      return False;
6429                   end if;
6430
6431                   Next (Exp);
6432                end loop;
6433
6434                --  Check named associations
6435
6436                Assn := First (Component_Associations (N));
6437                while Present (Assn) loop
6438                   Choice := First (Choices (Assn));
6439                   while Present (Choice) loop
6440                      if Is_Array_Aggr then
6441                         if Nkind (Choice) = N_Others_Choice then
6442                            null;
6443
6444                         elsif Nkind (Choice) = N_Range then
6445                            if not Is_Static_Range (Choice) then
6446                               return False;
6447                            end if;
6448
6449                         elsif not Is_Static_Expression (Choice) then
6450                            return False;
6451                         end if;
6452
6453                      else
6454                         Comp_Type := Etype (Choice);
6455                      end if;
6456
6457                      Next (Choice);
6458                   end loop;
6459
6460                   --  If the association has a <> at this point, then we have
6461                   --  to check whether the component's type has preelaborable
6462                   --  initialization. Note that this only occurs when the
6463                   --  association's corresponding component does not have a
6464                   --  default expression, the latter case having already been
6465                   --  expanded as an expression for the association.
6466
6467                   if Box_Present (Assn) then
6468                      if not Has_Preelaborable_Initialization (Comp_Type) then
6469                         return False;
6470                      end if;
6471
6472                   --  In the expression case we check whether the expression
6473                   --  is preelaborable.
6474
6475                   elsif
6476                     not Is_Preelaborable_Expression (Expression (Assn))
6477                   then
6478                      return False;
6479                   end if;
6480
6481                   Next (Assn);
6482                end loop;
6483
6484                --  If we get here then aggregate as a whole is preelaborable
6485
6486                return True;
6487
6488             --  All other cases are not preelaborable
6489
6490             else
6491                return False;
6492             end if;
6493          end Is_Preelaborable_Expression;
6494
6495       --  Start of processing for Check_Components
6496
6497       begin
6498          --  Loop through entities of record or protected type
6499
6500          Ent := E;
6501          while Present (Ent) loop
6502
6503             --  We are interested only in components and discriminants
6504
6505             Exp := Empty;
6506
6507             case Ekind (Ent) is
6508                when E_Component =>
6509
6510                   --  Get default expression if any. If there is no declaration
6511                   --  node, it means we have an internal entity. The parent and
6512                   --  tag fields are examples of such entities. For such cases,
6513                   --  we just test the type of the entity.
6514
6515                   if Present (Declaration_Node (Ent)) then
6516                      Exp := Expression (Declaration_Node (Ent));
6517                   end if;
6518
6519                when E_Discriminant =>
6520
6521                   --  Note: for a renamed discriminant, the Declaration_Node
6522                   --  may point to the one from the ancestor, and have a
6523                   --  different expression, so use the proper attribute to
6524                   --  retrieve the expression from the derived constraint.
6525
6526                   Exp := Discriminant_Default_Value (Ent);
6527
6528                when others =>
6529                   goto Check_Next_Entity;
6530             end case;
6531
6532             --  A component has PI if it has no default expression and the
6533             --  component type has PI.
6534
6535             if No (Exp) then
6536                if not Has_Preelaborable_Initialization (Etype (Ent)) then
6537                   Has_PE := False;
6538                   exit;
6539                end if;
6540
6541             --  Require the default expression to be preelaborable
6542
6543             elsif not Is_Preelaborable_Expression (Exp) then
6544                Has_PE := False;
6545                exit;
6546             end if;
6547
6548          <<Check_Next_Entity>>
6549             Next_Entity (Ent);
6550          end loop;
6551       end Check_Components;
6552
6553    --  Start of processing for Has_Preelaborable_Initialization
6554
6555    begin
6556       --  Immediate return if already marked as known preelaborable init. This
6557       --  covers types for which this function has already been called once
6558       --  and returned True (in which case the result is cached), and also
6559       --  types to which a pragma Preelaborable_Initialization applies.
6560
6561       if Known_To_Have_Preelab_Init (E) then
6562          return True;
6563       end if;
6564
6565       --  If the type is a subtype representing a generic actual type, then
6566       --  test whether its base type has preelaborable initialization since
6567       --  the subtype representing the actual does not inherit this attribute
6568       --  from the actual or formal. (but maybe it should???)
6569
6570       if Is_Generic_Actual_Type (E) then
6571          return Has_Preelaborable_Initialization (Base_Type (E));
6572       end if;
6573
6574       --  All elementary types have preelaborable initialization
6575
6576       if Is_Elementary_Type (E) then
6577          Has_PE := True;
6578
6579       --  Array types have PI if the component type has PI
6580
6581       elsif Is_Array_Type (E) then
6582          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
6583
6584       --  A derived type has preelaborable initialization if its parent type
6585       --  has preelaborable initialization and (in the case of a derived record
6586       --  extension) if the non-inherited components all have preelaborable
6587       --  initialization. However, a user-defined controlled type with an
6588       --  overriding Initialize procedure does not have preelaborable
6589       --  initialization.
6590
6591       elsif Is_Derived_Type (E) then
6592
6593          --  If the derived type is a private extension then it doesn't have
6594          --  preelaborable initialization.
6595
6596          if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
6597             return False;
6598          end if;
6599
6600          --  First check whether ancestor type has preelaborable initialization
6601
6602          Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
6603
6604          --  If OK, check extension components (if any)
6605
6606          if Has_PE and then Is_Record_Type (E) then
6607             Check_Components (First_Entity (E));
6608          end if;
6609
6610          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
6611          --  with a user defined Initialize procedure does not have PI.
6612
6613          if Has_PE
6614            and then Is_Controlled (E)
6615            and then Has_Overriding_Initialize (E)
6616          then
6617             Has_PE := False;
6618          end if;
6619
6620       --  Private types not derived from a type having preelaborable init and
6621       --  that are not marked with pragma Preelaborable_Initialization do not
6622       --  have preelaborable initialization.
6623
6624       elsif Is_Private_Type (E) then
6625          return False;
6626
6627       --  Record type has PI if it is non private and all components have PI
6628
6629       elsif Is_Record_Type (E) then
6630          Has_PE := True;
6631          Check_Components (First_Entity (E));
6632
6633       --  Protected types must not have entries, and components must meet
6634       --  same set of rules as for record components.
6635
6636       elsif Is_Protected_Type (E) then
6637          if Has_Entries (E) then
6638             Has_PE := False;
6639          else
6640             Has_PE := True;
6641             Check_Components (First_Entity (E));
6642             Check_Components (First_Private_Entity (E));
6643          end if;
6644
6645       --  Type System.Address always has preelaborable initialization
6646
6647       elsif Is_RTE (E, RE_Address) then
6648          Has_PE := True;
6649
6650       --  In all other cases, type does not have preelaborable initialization
6651
6652       else
6653          return False;
6654       end if;
6655
6656       --  If type has preelaborable initialization, cache result
6657
6658       if Has_PE then
6659          Set_Known_To_Have_Preelab_Init (E);
6660       end if;
6661
6662       return Has_PE;
6663    end Has_Preelaborable_Initialization;
6664
6665    ---------------------------
6666    -- Has_Private_Component --
6667    ---------------------------
6668
6669    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
6670       Btype     : Entity_Id := Base_Type (Type_Id);
6671       Component : Entity_Id;
6672
6673    begin
6674       if Error_Posted (Type_Id)
6675         or else Error_Posted (Btype)
6676       then
6677          return False;
6678       end if;
6679
6680       if Is_Class_Wide_Type (Btype) then
6681          Btype := Root_Type (Btype);
6682       end if;
6683
6684       if Is_Private_Type (Btype) then
6685          declare
6686             UT : constant Entity_Id := Underlying_Type (Btype);
6687          begin
6688             if No (UT) then
6689                if No (Full_View (Btype)) then
6690                   return not Is_Generic_Type (Btype)
6691                     and then not Is_Generic_Type (Root_Type (Btype));
6692                else
6693                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
6694                end if;
6695             else
6696                return not Is_Frozen (UT) and then Has_Private_Component (UT);
6697             end if;
6698          end;
6699
6700       elsif Is_Array_Type (Btype) then
6701          return Has_Private_Component (Component_Type (Btype));
6702
6703       elsif Is_Record_Type (Btype) then
6704          Component := First_Component (Btype);
6705          while Present (Component) loop
6706             if Has_Private_Component (Etype (Component)) then
6707                return True;
6708             end if;
6709
6710             Next_Component (Component);
6711          end loop;
6712
6713          return False;
6714
6715       elsif Is_Protected_Type (Btype)
6716         and then Present (Corresponding_Record_Type (Btype))
6717       then
6718          return Has_Private_Component (Corresponding_Record_Type (Btype));
6719
6720       else
6721          return False;
6722       end if;
6723    end Has_Private_Component;
6724
6725    ----------------------
6726    -- Has_Signed_Zeros --
6727    ----------------------
6728
6729    function Has_Signed_Zeros (E : Entity_Id) return Boolean is
6730    begin
6731       return Is_Floating_Point_Type (E)
6732         and then Signed_Zeros_On_Target
6733         and then not Vax_Float (E);
6734    end Has_Signed_Zeros;
6735
6736    -----------------------------
6737    -- Has_Static_Array_Bounds --
6738    -----------------------------
6739
6740    function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
6741       Ndims : constant Nat := Number_Dimensions (Typ);
6742
6743       Index : Node_Id;
6744       Low   : Node_Id;
6745       High  : Node_Id;
6746
6747    begin
6748       --  Unconstrained types do not have static bounds
6749
6750       if not Is_Constrained (Typ) then
6751          return False;
6752       end if;
6753
6754       --  First treat string literals specially, as the lower bound and length
6755       --  of string literals are not stored like those of arrays.
6756
6757       --  A string literal always has static bounds
6758
6759       if Ekind (Typ) = E_String_Literal_Subtype then
6760          return True;
6761       end if;
6762
6763       --  Treat all dimensions in turn
6764
6765       Index := First_Index (Typ);
6766       for Indx in 1 .. Ndims loop
6767
6768          --  In case of an erroneous index which is not a discrete type, return
6769          --  that the type is not static.
6770
6771          if not Is_Discrete_Type (Etype (Index))
6772            or else Etype (Index) = Any_Type
6773          then
6774             return False;
6775          end if;
6776
6777          Get_Index_Bounds (Index, Low, High);
6778
6779          if Error_Posted (Low) or else Error_Posted (High) then
6780             return False;
6781          end if;
6782
6783          if Is_OK_Static_Expression (Low)
6784               and then
6785             Is_OK_Static_Expression (High)
6786          then
6787             null;
6788          else
6789             return False;
6790          end if;
6791
6792          Next (Index);
6793       end loop;
6794
6795       --  If we fall through the loop, all indexes matched
6796
6797       return True;
6798    end Has_Static_Array_Bounds;
6799
6800    ----------------
6801    -- Has_Stream --
6802    ----------------
6803
6804    function Has_Stream (T : Entity_Id) return Boolean is
6805       E : Entity_Id;
6806
6807    begin
6808       if No (T) then
6809          return False;
6810
6811       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
6812          return True;
6813
6814       elsif Is_Array_Type (T) then
6815          return Has_Stream (Component_Type (T));
6816
6817       elsif Is_Record_Type (T) then
6818          E := First_Component (T);
6819          while Present (E) loop
6820             if Has_Stream (Etype (E)) then
6821                return True;
6822             else
6823                Next_Component (E);
6824             end if;
6825          end loop;
6826
6827          return False;
6828
6829       elsif Is_Private_Type (T) then
6830          return Has_Stream (Underlying_Type (T));
6831
6832       else
6833          return False;
6834       end if;
6835    end Has_Stream;
6836
6837    ----------------
6838    -- Has_Suffix --
6839    ----------------
6840
6841    function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
6842    begin
6843       Get_Name_String (Chars (E));
6844       return Name_Buffer (Name_Len) = Suffix;
6845    end Has_Suffix;
6846
6847    ----------------
6848    -- Add_Suffix --
6849    ----------------
6850
6851    function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
6852    begin
6853       Get_Name_String (Chars (E));
6854       Add_Char_To_Name_Buffer (Suffix);
6855       return Name_Find;
6856    end Add_Suffix;
6857
6858    -------------------
6859    -- Remove_Suffix --
6860    -------------------
6861
6862    function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
6863    begin
6864       pragma Assert (Has_Suffix (E, Suffix));
6865       Get_Name_String (Chars (E));
6866       Name_Len := Name_Len - 1;
6867       return Name_Find;
6868    end Remove_Suffix;
6869
6870    --------------------------
6871    -- Has_Tagged_Component --
6872    --------------------------
6873
6874    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
6875       Comp : Entity_Id;
6876
6877    begin
6878       if Is_Private_Type (Typ)
6879         and then Present (Underlying_Type (Typ))
6880       then
6881          return Has_Tagged_Component (Underlying_Type (Typ));
6882
6883       elsif Is_Array_Type (Typ) then
6884          return Has_Tagged_Component (Component_Type (Typ));
6885
6886       elsif Is_Tagged_Type (Typ) then
6887          return True;
6888
6889       elsif Is_Record_Type (Typ) then
6890          Comp := First_Component (Typ);
6891          while Present (Comp) loop
6892             if Has_Tagged_Component (Etype (Comp)) then
6893                return True;
6894             end if;
6895
6896             Next_Component (Comp);
6897          end loop;
6898
6899          return False;
6900
6901       else
6902          return False;
6903       end if;
6904    end Has_Tagged_Component;
6905
6906    -------------------------
6907    -- Implementation_Kind --
6908    -------------------------
6909
6910    function Implementation_Kind (Subp : Entity_Id) return Name_Id is
6911       Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
6912       Arg       : Node_Id;
6913    begin
6914       pragma Assert (Present (Impl_Prag));
6915       Arg := Last (Pragma_Argument_Associations (Impl_Prag));
6916       return Chars (Get_Pragma_Arg (Arg));
6917    end Implementation_Kind;
6918
6919    --------------------------
6920    -- Implements_Interface --
6921    --------------------------
6922
6923    function Implements_Interface
6924      (Typ_Ent         : Entity_Id;
6925       Iface_Ent       : Entity_Id;
6926       Exclude_Parents : Boolean := False) return Boolean
6927    is
6928       Ifaces_List : Elist_Id;
6929       Elmt        : Elmt_Id;
6930       Iface       : Entity_Id := Base_Type (Iface_Ent);
6931       Typ         : Entity_Id := Base_Type (Typ_Ent);
6932
6933    begin
6934       if Is_Class_Wide_Type (Typ) then
6935          Typ := Root_Type (Typ);
6936       end if;
6937
6938       if not Has_Interfaces (Typ) then
6939          return False;
6940       end if;
6941
6942       if Is_Class_Wide_Type (Iface) then
6943          Iface := Root_Type (Iface);
6944       end if;
6945
6946       Collect_Interfaces (Typ, Ifaces_List);
6947
6948       Elmt := First_Elmt (Ifaces_List);
6949       while Present (Elmt) loop
6950          if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
6951            and then Exclude_Parents
6952          then
6953             null;
6954
6955          elsif Node (Elmt) = Iface then
6956             return True;
6957          end if;
6958
6959          Next_Elmt (Elmt);
6960       end loop;
6961
6962       return False;
6963    end Implements_Interface;
6964
6965    -----------------
6966    -- In_Instance --
6967    -----------------
6968
6969    function In_Instance return Boolean is
6970       Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
6971       S         : Entity_Id;
6972
6973    begin
6974       S := Current_Scope;
6975       while Present (S)
6976         and then S /= Standard_Standard
6977       loop
6978          if (Ekind (S) = E_Function
6979               or else Ekind (S) = E_Package
6980               or else Ekind (S) = E_Procedure)
6981            and then Is_Generic_Instance (S)
6982          then
6983             --  A child instance is always compiled in the context of a parent
6984             --  instance. Nevertheless, the actuals are not analyzed in an
6985             --  instance context. We detect this case by examining the current
6986             --  compilation unit, which must be a child instance, and checking
6987             --  that it is not currently on the scope stack.
6988
6989             if Is_Child_Unit (Curr_Unit)
6990               and then
6991                 Nkind (Unit (Cunit (Current_Sem_Unit)))
6992                   = N_Package_Instantiation
6993               and then not In_Open_Scopes (Curr_Unit)
6994             then
6995                return False;
6996             else
6997                return True;
6998             end if;
6999          end if;
7000
7001          S := Scope (S);
7002       end loop;
7003
7004       return False;
7005    end In_Instance;
7006
7007    ----------------------
7008    -- In_Instance_Body --
7009    ----------------------
7010
7011    function In_Instance_Body return Boolean is
7012       S : Entity_Id;
7013
7014    begin
7015       S := Current_Scope;
7016       while Present (S)
7017         and then S /= Standard_Standard
7018       loop
7019          if (Ekind (S) = E_Function
7020               or else Ekind (S) = E_Procedure)
7021            and then Is_Generic_Instance (S)
7022          then
7023             return True;
7024
7025          elsif Ekind (S) = E_Package
7026            and then In_Package_Body (S)
7027            and then Is_Generic_Instance (S)
7028          then
7029             return True;
7030          end if;
7031
7032          S := Scope (S);
7033       end loop;
7034
7035       return False;
7036    end In_Instance_Body;
7037
7038    -----------------------------
7039    -- In_Instance_Not_Visible --
7040    -----------------------------
7041
7042    function In_Instance_Not_Visible return Boolean is
7043       S : Entity_Id;
7044
7045    begin
7046       S := Current_Scope;
7047       while Present (S)
7048         and then S /= Standard_Standard
7049       loop
7050          if (Ekind (S) = E_Function
7051               or else Ekind (S) = E_Procedure)
7052            and then Is_Generic_Instance (S)
7053          then
7054             return True;
7055
7056          elsif Ekind (S) = E_Package
7057            and then (In_Package_Body (S) or else In_Private_Part (S))
7058            and then Is_Generic_Instance (S)
7059          then
7060             return True;
7061          end if;
7062
7063          S := Scope (S);
7064       end loop;
7065
7066       return False;
7067    end In_Instance_Not_Visible;
7068
7069    ------------------------------
7070    -- In_Instance_Visible_Part --
7071    ------------------------------
7072
7073    function In_Instance_Visible_Part return Boolean is
7074       S : Entity_Id;
7075
7076    begin
7077       S := Current_Scope;
7078       while Present (S)
7079         and then S /= Standard_Standard
7080       loop
7081          if Ekind (S) = E_Package
7082            and then Is_Generic_Instance (S)
7083            and then not In_Package_Body (S)
7084            and then not In_Private_Part (S)
7085          then
7086             return True;
7087          end if;
7088
7089          S := Scope (S);
7090       end loop;
7091
7092       return False;
7093    end In_Instance_Visible_Part;
7094
7095    ---------------------
7096    -- In_Package_Body --
7097    ---------------------
7098
7099    function In_Package_Body return Boolean is
7100       S : Entity_Id;
7101
7102    begin
7103       S := Current_Scope;
7104       while Present (S)
7105         and then S /= Standard_Standard
7106       loop
7107          if Ekind (S) = E_Package
7108            and then In_Package_Body (S)
7109          then
7110             return True;
7111          else
7112             S := Scope (S);
7113          end if;
7114       end loop;
7115
7116       return False;
7117    end In_Package_Body;
7118
7119    --------------------------------
7120    -- In_Parameter_Specification --
7121    --------------------------------
7122
7123    function In_Parameter_Specification (N : Node_Id) return Boolean is
7124       PN : Node_Id;
7125
7126    begin
7127       PN := Parent (N);
7128       while Present (PN) loop
7129          if Nkind (PN) = N_Parameter_Specification then
7130             return True;
7131          end if;
7132
7133          PN := Parent (PN);
7134       end loop;
7135
7136       return False;
7137    end In_Parameter_Specification;
7138
7139    -------------------------------------
7140    -- In_Reverse_Storage_Order_Object --
7141    -------------------------------------
7142
7143    function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
7144       Pref : Node_Id;
7145       Btyp : Entity_Id := Empty;
7146
7147    begin
7148       --  Climb up indexed components
7149
7150       Pref := N;
7151       loop
7152          case Nkind (Pref) is
7153             when N_Selected_Component =>
7154                Pref := Prefix (Pref);
7155                exit;
7156
7157             when N_Indexed_Component =>
7158                Pref := Prefix (Pref);
7159
7160             when others =>
7161                Pref := Empty;
7162                exit;
7163          end case;
7164       end loop;
7165
7166       if Present (Pref) then
7167          Btyp := Base_Type (Etype (Pref));
7168       end if;
7169
7170       return
7171         Present (Btyp)
7172           and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
7173           and then Reverse_Storage_Order (Btyp);
7174    end In_Reverse_Storage_Order_Object;
7175
7176    --------------------------------------
7177    -- In_Subprogram_Or_Concurrent_Unit --
7178    --------------------------------------
7179
7180    function In_Subprogram_Or_Concurrent_Unit return Boolean is
7181       E : Entity_Id;
7182       K : Entity_Kind;
7183
7184    begin
7185       --  Use scope chain to check successively outer scopes
7186
7187       E := Current_Scope;
7188       loop
7189          K := Ekind (E);
7190
7191          if K in Subprogram_Kind
7192            or else K in Concurrent_Kind
7193            or else K in Generic_Subprogram_Kind
7194          then
7195             return True;
7196
7197          elsif E = Standard_Standard then
7198             return False;
7199          end if;
7200
7201          E := Scope (E);
7202       end loop;
7203    end In_Subprogram_Or_Concurrent_Unit;
7204
7205    ---------------------
7206    -- In_Visible_Part --
7207    ---------------------
7208
7209    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
7210    begin
7211       return
7212         Is_Package_Or_Generic_Package (Scope_Id)
7213           and then In_Open_Scopes (Scope_Id)
7214           and then not In_Package_Body (Scope_Id)
7215           and then not In_Private_Part (Scope_Id);
7216    end In_Visible_Part;
7217
7218    --------------------------------
7219    -- Incomplete_Or_Private_View --
7220    --------------------------------
7221
7222    function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
7223       function Inspect_Decls
7224         (Decls : List_Id;
7225          Taft  : Boolean := False) return Entity_Id;
7226       --  Check whether a declarative region contains the incomplete or private
7227       --  view of Typ.
7228
7229       -------------------
7230       -- Inspect_Decls --
7231       -------------------
7232
7233       function Inspect_Decls
7234         (Decls : List_Id;
7235          Taft  : Boolean := False) return Entity_Id
7236       is
7237          Decl  : Node_Id;
7238          Match : Node_Id;
7239
7240       begin
7241          Decl := First (Decls);
7242          while Present (Decl) loop
7243             Match := Empty;
7244
7245             if Taft then
7246                if Nkind (Decl) = N_Incomplete_Type_Declaration then
7247                   Match := Defining_Identifier (Decl);
7248                end if;
7249
7250             else
7251                if Nkind_In (Decl, N_Private_Extension_Declaration,
7252                                   N_Private_Type_Declaration)
7253                then
7254                   Match := Defining_Identifier (Decl);
7255                end if;
7256             end if;
7257
7258             if Present (Match)
7259               and then Present (Full_View (Match))
7260               and then Full_View (Match) = Typ
7261             then
7262                return Match;
7263             end if;
7264
7265             Next (Decl);
7266          end loop;
7267
7268          return Empty;
7269       end Inspect_Decls;
7270
7271       --  Local variables
7272
7273       Prev : Entity_Id;
7274
7275    --  Start of processing for Incomplete_Or_Partial_View
7276
7277    begin
7278       --  Incomplete type case
7279
7280       Prev := Current_Entity_In_Scope (Typ);
7281
7282       if Present (Prev)
7283         and then Is_Incomplete_Type (Prev)
7284         and then Present (Full_View (Prev))
7285         and then Full_View (Prev) = Typ
7286       then
7287          return Prev;
7288       end if;
7289
7290       --  Private or Taft amendment type case
7291
7292       declare
7293          Pkg      : constant Entity_Id := Scope (Typ);
7294          Pkg_Decl : Node_Id := Pkg;
7295
7296       begin
7297          if Ekind (Pkg) = E_Package then
7298             while Nkind (Pkg_Decl) /= N_Package_Specification loop
7299                Pkg_Decl := Parent (Pkg_Decl);
7300             end loop;
7301
7302             --  It is knows that Typ has a private view, look for it in the
7303             --  visible declarations of the enclosing scope. A special case
7304             --  of this is when the two views have been exchanged - the full
7305             --  appears earlier than the private.
7306
7307             if Has_Private_Declaration (Typ) then
7308                Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
7309
7310                --  Exchanged view case, look in the private declarations
7311
7312                if No (Prev) then
7313                   Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
7314                end if;
7315
7316                return Prev;
7317
7318             --  Otherwise if this is the package body, then Typ is a potential
7319             --  Taft amendment type. The incomplete view should be located in
7320             --  the private declarations of the enclosing scope.
7321
7322             elsif In_Package_Body (Pkg) then
7323                return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
7324             end if;
7325          end if;
7326       end;
7327
7328       --  The type has no incomplete or private view
7329
7330       return Empty;
7331    end Incomplete_Or_Private_View;
7332
7333    ---------------------------------
7334    -- Insert_Explicit_Dereference --
7335    ---------------------------------
7336
7337    procedure Insert_Explicit_Dereference (N : Node_Id) is
7338       New_Prefix : constant Node_Id := Relocate_Node (N);
7339       Ent        : Entity_Id := Empty;
7340       Pref       : Node_Id;
7341       I          : Interp_Index;
7342       It         : Interp;
7343       T          : Entity_Id;
7344
7345    begin
7346       Save_Interps (N, New_Prefix);
7347
7348       Rewrite (N,
7349         Make_Explicit_Dereference (Sloc (Parent (N)),
7350           Prefix => New_Prefix));
7351
7352       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
7353
7354       if Is_Overloaded (New_Prefix) then
7355
7356          --  The dereference is also overloaded, and its interpretations are
7357          --  the designated types of the interpretations of the original node.
7358
7359          Set_Etype (N, Any_Type);
7360
7361          Get_First_Interp (New_Prefix, I, It);
7362          while Present (It.Nam) loop
7363             T := It.Typ;
7364
7365             if Is_Access_Type (T) then
7366                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
7367             end if;
7368
7369             Get_Next_Interp (I, It);
7370          end loop;
7371
7372          End_Interp_List;
7373
7374       else
7375          --  Prefix is unambiguous: mark the original prefix (which might
7376          --  Come_From_Source) as a reference, since the new (relocated) one
7377          --  won't be taken into account.
7378
7379          if Is_Entity_Name (New_Prefix) then
7380             Ent := Entity (New_Prefix);
7381             Pref := New_Prefix;
7382
7383          --  For a retrieval of a subcomponent of some composite object,
7384          --  retrieve the ultimate entity if there is one.
7385
7386          elsif Nkind (New_Prefix) = N_Selected_Component
7387            or else Nkind (New_Prefix) = N_Indexed_Component
7388          then
7389             Pref := Prefix (New_Prefix);
7390             while Present (Pref)
7391               and then
7392                 (Nkind (Pref) = N_Selected_Component
7393                   or else Nkind (Pref) = N_Indexed_Component)
7394             loop
7395                Pref := Prefix (Pref);
7396             end loop;
7397
7398             if Present (Pref) and then Is_Entity_Name (Pref) then
7399                Ent := Entity (Pref);
7400             end if;
7401          end if;
7402
7403          --  Place the reference on the entity node
7404
7405          if Present (Ent) then
7406             Generate_Reference (Ent, Pref);
7407          end if;
7408       end if;
7409    end Insert_Explicit_Dereference;
7410
7411    ------------------------------------------
7412    -- Inspect_Deferred_Constant_Completion --
7413    ------------------------------------------
7414
7415    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
7416       Decl   : Node_Id;
7417
7418    begin
7419       Decl := First (Decls);
7420       while Present (Decl) loop
7421
7422          --  Deferred constant signature
7423
7424          if Nkind (Decl) = N_Object_Declaration
7425            and then Constant_Present (Decl)
7426            and then No (Expression (Decl))
7427
7428             --  No need to check internally generated constants
7429
7430            and then Comes_From_Source (Decl)
7431
7432             --  The constant is not completed. A full object declaration or a
7433             --  pragma Import complete a deferred constant.
7434
7435            and then not Has_Completion (Defining_Identifier (Decl))
7436          then
7437             Error_Msg_N
7438               ("constant declaration requires initialization expression",
7439               Defining_Identifier (Decl));
7440          end if;
7441
7442          Decl := Next (Decl);
7443       end loop;
7444    end Inspect_Deferred_Constant_Completion;
7445
7446    -----------------------------
7447    -- Is_Actual_Out_Parameter --
7448    -----------------------------
7449
7450    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
7451       Formal : Entity_Id;
7452       Call   : Node_Id;
7453    begin
7454       Find_Actual (N, Formal, Call);
7455       return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
7456    end Is_Actual_Out_Parameter;
7457
7458    -------------------------
7459    -- Is_Actual_Parameter --
7460    -------------------------
7461
7462    function Is_Actual_Parameter (N : Node_Id) return Boolean is
7463       PK : constant Node_Kind := Nkind (Parent (N));
7464
7465    begin
7466       case PK is
7467          when N_Parameter_Association =>
7468             return N = Explicit_Actual_Parameter (Parent (N));
7469
7470          when N_Subprogram_Call =>
7471             return Is_List_Member (N)
7472               and then
7473                 List_Containing (N) = Parameter_Associations (Parent (N));
7474
7475          when others =>
7476             return False;
7477       end case;
7478    end Is_Actual_Parameter;
7479
7480    --------------------------------
7481    -- Is_Actual_Tagged_Parameter --
7482    --------------------------------
7483
7484    function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
7485       Formal : Entity_Id;
7486       Call   : Node_Id;
7487    begin
7488       Find_Actual (N, Formal, Call);
7489       return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
7490    end Is_Actual_Tagged_Parameter;
7491
7492    ---------------------
7493    -- Is_Aliased_View --
7494    ---------------------
7495
7496    function Is_Aliased_View (Obj : Node_Id) return Boolean is
7497       E : Entity_Id;
7498
7499    begin
7500       if Is_Entity_Name (Obj) then
7501          E := Entity (Obj);
7502
7503          return
7504            (Is_Object (E)
7505              and then
7506                (Is_Aliased (E)
7507                  or else (Present (Renamed_Object (E))
7508                            and then Is_Aliased_View (Renamed_Object (E)))))
7509
7510            or else ((Is_Formal (E)
7511                       or else Ekind (E) = E_Generic_In_Out_Parameter
7512                       or else Ekind (E) = E_Generic_In_Parameter)
7513                     and then Is_Tagged_Type (Etype (E)))
7514
7515            or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
7516
7517            --  Current instance of type, either directly or as rewritten
7518            --  reference to the current object.
7519
7520            or else (Is_Entity_Name (Original_Node (Obj))
7521                      and then Present (Entity (Original_Node (Obj)))
7522                      and then Is_Type (Entity (Original_Node (Obj))))
7523
7524            or else (Is_Type (E) and then E = Current_Scope)
7525
7526            or else (Is_Incomplete_Or_Private_Type (E)
7527                      and then Full_View (E) = Current_Scope)
7528
7529            --  Ada 2012 AI05-0053: the return object of an extended return
7530            --  statement is aliased if its type is immutably limited.
7531
7532            or else (Is_Return_Object (E)
7533                      and then Is_Immutably_Limited_Type (Etype (E)));
7534
7535       elsif Nkind (Obj) = N_Selected_Component then
7536          return Is_Aliased (Entity (Selector_Name (Obj)));
7537
7538       elsif Nkind (Obj) = N_Indexed_Component then
7539          return Has_Aliased_Components (Etype (Prefix (Obj)))
7540            or else
7541              (Is_Access_Type (Etype (Prefix (Obj)))
7542                and then Has_Aliased_Components
7543                           (Designated_Type (Etype (Prefix (Obj)))));
7544
7545       elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
7546          return Is_Tagged_Type (Etype (Obj))
7547            and then Is_Aliased_View (Expression (Obj));
7548
7549       elsif Nkind (Obj) = N_Explicit_Dereference then
7550          return Nkind (Original_Node (Obj)) /= N_Function_Call;
7551
7552       else
7553          return False;
7554       end if;
7555    end Is_Aliased_View;
7556
7557    -------------------------
7558    -- Is_Ancestor_Package --
7559    -------------------------
7560
7561    function Is_Ancestor_Package
7562      (E1 : Entity_Id;
7563       E2 : Entity_Id) return Boolean
7564    is
7565       Par : Entity_Id;
7566
7567    begin
7568       Par := E2;
7569       while Present (Par)
7570         and then Par /= Standard_Standard
7571       loop
7572          if Par = E1 then
7573             return True;
7574          end if;
7575
7576          Par := Scope (Par);
7577       end loop;
7578
7579       return False;
7580    end Is_Ancestor_Package;
7581
7582    ----------------------
7583    -- Is_Atomic_Object --
7584    ----------------------
7585
7586    function Is_Atomic_Object (N : Node_Id) return Boolean is
7587
7588       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
7589       --  Determines if given object has atomic components
7590
7591       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
7592       --  If prefix is an implicit dereference, examine designated type
7593
7594       ----------------------
7595       -- Is_Atomic_Prefix --
7596       ----------------------
7597
7598       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
7599       begin
7600          if Is_Access_Type (Etype (N)) then
7601             return
7602               Has_Atomic_Components (Designated_Type (Etype (N)));
7603          else
7604             return Object_Has_Atomic_Components (N);
7605          end if;
7606       end Is_Atomic_Prefix;
7607
7608       ----------------------------------
7609       -- Object_Has_Atomic_Components --
7610       ----------------------------------
7611
7612       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
7613       begin
7614          if Has_Atomic_Components (Etype (N))
7615            or else Is_Atomic (Etype (N))
7616          then
7617             return True;
7618
7619          elsif Is_Entity_Name (N)
7620            and then (Has_Atomic_Components (Entity (N))
7621                       or else Is_Atomic (Entity (N)))
7622          then
7623             return True;
7624
7625          elsif Nkind (N) = N_Selected_Component
7626            and then Is_Atomic (Entity (Selector_Name (N)))
7627          then
7628             return True;
7629
7630          elsif Nkind (N) = N_Indexed_Component
7631            or else Nkind (N) = N_Selected_Component
7632          then
7633             return Is_Atomic_Prefix (Prefix (N));
7634
7635          else
7636             return False;
7637          end if;
7638       end Object_Has_Atomic_Components;
7639
7640    --  Start of processing for Is_Atomic_Object
7641
7642    begin
7643       --  Predicate is not relevant to subprograms
7644
7645       if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
7646          return False;
7647
7648       elsif Is_Atomic (Etype (N))
7649         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
7650       then
7651          return True;
7652
7653       elsif Nkind (N) = N_Selected_Component
7654         and then Is_Atomic (Entity (Selector_Name (N)))
7655       then
7656          return True;
7657
7658       elsif Nkind (N) = N_Indexed_Component
7659         or else Nkind (N) = N_Selected_Component
7660       then
7661          return Is_Atomic_Prefix (Prefix (N));
7662
7663       else
7664          return False;
7665       end if;
7666    end Is_Atomic_Object;
7667
7668    -----------------------
7669    -- Is_Bounded_String --
7670    -----------------------
7671
7672    function Is_Bounded_String (T : Entity_Id) return Boolean is
7673       Under : constant Entity_Id := Underlying_Type (Root_Type (T));
7674
7675    begin
7676       --  Check whether T is ultimately derived from Ada.Strings.Superbounded.
7677       --  Super_String, or one of the [Wide_]Wide_ versions. This will
7678       --  be True for all the Bounded_String types in instances of the
7679       --  Generic_Bounded_Length generics, and for types derived from those.
7680
7681       return Present (Under)
7682         and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
7683                   Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
7684                   Is_RTE (Root_Type (Under), RO_WW_Super_String));
7685    end Is_Bounded_String;
7686
7687    -----------------------------
7688    -- Is_Concurrent_Interface --
7689    -----------------------------
7690
7691    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
7692    begin
7693       return
7694         Is_Interface (T)
7695           and then
7696             (Is_Protected_Interface (T)
7697                or else Is_Synchronized_Interface (T)
7698                or else Is_Task_Interface (T));
7699    end Is_Concurrent_Interface;
7700
7701    --------------------------------------
7702    -- Is_Controlling_Limited_Procedure --
7703    --------------------------------------
7704
7705    function Is_Controlling_Limited_Procedure
7706      (Proc_Nam : Entity_Id) return Boolean
7707    is
7708       Param_Typ : Entity_Id := Empty;
7709
7710    begin
7711       if Ekind (Proc_Nam) = E_Procedure
7712         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
7713       then
7714          Param_Typ := Etype (Parameter_Type (First (
7715                         Parameter_Specifications (Parent (Proc_Nam)))));
7716
7717       --  In this case where an Itype was created, the procedure call has been
7718       --  rewritten.
7719
7720       elsif Present (Associated_Node_For_Itype (Proc_Nam))
7721         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
7722         and then
7723           Present (Parameter_Associations
7724                      (Associated_Node_For_Itype (Proc_Nam)))
7725       then
7726          Param_Typ :=
7727            Etype (First (Parameter_Associations
7728                           (Associated_Node_For_Itype (Proc_Nam))));
7729       end if;
7730
7731       if Present (Param_Typ) then
7732          return
7733            Is_Interface (Param_Typ)
7734              and then Is_Limited_Record (Param_Typ);
7735       end if;
7736
7737       return False;
7738    end Is_Controlling_Limited_Procedure;
7739
7740    -----------------------------
7741    -- Is_CPP_Constructor_Call --
7742    -----------------------------
7743
7744    function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
7745    begin
7746       return Nkind (N) = N_Function_Call
7747         and then Is_CPP_Class (Etype (Etype (N)))
7748         and then Is_Constructor (Entity (Name (N)))
7749         and then Is_Imported (Entity (Name (N)));
7750    end Is_CPP_Constructor_Call;
7751
7752    -----------------
7753    -- Is_Delegate --
7754    -----------------
7755
7756    function Is_Delegate (T : Entity_Id) return Boolean is
7757       Desig_Type : Entity_Id;
7758
7759    begin
7760       if VM_Target /= CLI_Target then
7761          return False;
7762       end if;
7763
7764       --  Access-to-subprograms are delegates in CIL
7765
7766       if Ekind (T) = E_Access_Subprogram_Type then
7767          return True;
7768       end if;
7769
7770       if Ekind (T) not in Access_Kind then
7771
7772          --  A delegate is a managed pointer. If no designated type is defined
7773          --  it means that it's not a delegate.
7774
7775          return False;
7776       end if;
7777
7778       Desig_Type := Etype (Directly_Designated_Type (T));
7779
7780       if not Is_Tagged_Type (Desig_Type) then
7781          return False;
7782       end if;
7783
7784       --  Test if the type is inherited from [mscorlib]System.Delegate
7785
7786       while Etype (Desig_Type) /= Desig_Type loop
7787          if Chars (Scope (Desig_Type)) /= No_Name
7788            and then Is_Imported (Scope (Desig_Type))
7789            and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
7790          then
7791             return True;
7792          end if;
7793
7794          Desig_Type := Etype (Desig_Type);
7795       end loop;
7796
7797       return False;
7798    end Is_Delegate;
7799
7800    ----------------------------------------------
7801    -- Is_Dependent_Component_Of_Mutable_Object --
7802    ----------------------------------------------
7803
7804    function Is_Dependent_Component_Of_Mutable_Object
7805      (Object : Node_Id) return Boolean
7806    is
7807       P           : Node_Id;
7808       Prefix_Type : Entity_Id;
7809       P_Aliased   : Boolean := False;
7810       Comp        : Entity_Id;
7811
7812       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
7813       --  Returns True if and only if Comp is declared within a variant part
7814
7815       --------------------------------
7816       -- Is_Declared_Within_Variant --
7817       --------------------------------
7818
7819       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
7820          Comp_Decl : constant Node_Id   := Parent (Comp);
7821          Comp_List : constant Node_Id   := Parent (Comp_Decl);
7822       begin
7823          return Nkind (Parent (Comp_List)) = N_Variant;
7824       end Is_Declared_Within_Variant;
7825
7826    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
7827
7828    begin
7829       if Is_Variable (Object) then
7830
7831          if Nkind (Object) = N_Selected_Component then
7832             P := Prefix (Object);
7833             Prefix_Type := Etype (P);
7834
7835             if Is_Entity_Name (P) then
7836
7837                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
7838                   Prefix_Type := Base_Type (Prefix_Type);
7839                end if;
7840
7841                if Is_Aliased (Entity (P)) then
7842                   P_Aliased := True;
7843                end if;
7844
7845             --  A discriminant check on a selected component may be expanded
7846             --  into a dereference when removing side-effects. Recover the
7847             --  original node and its type, which may be unconstrained.
7848
7849             elsif Nkind (P) = N_Explicit_Dereference
7850               and then not (Comes_From_Source (P))
7851             then
7852                P := Original_Node (P);
7853                Prefix_Type := Etype (P);
7854
7855             else
7856                --  Check for prefix being an aliased component???
7857
7858                null;
7859
7860             end if;
7861
7862             --  A heap object is constrained by its initial value
7863
7864             --  Ada 2005 (AI-363): Always assume the object could be mutable in
7865             --  the dereferenced case, since the access value might denote an
7866             --  unconstrained aliased object, whereas in Ada 95 the designated
7867             --  object is guaranteed to be constrained. A worst-case assumption
7868             --  has to apply in Ada 2005 because we can't tell at compile time
7869             --  whether the object is "constrained by its initial value"
7870             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
7871             --  semantic rules -- these rules are acknowledged to need fixing).
7872
7873             if Ada_Version < Ada_2005 then
7874                if Is_Access_Type (Prefix_Type)
7875                  or else Nkind (P) = N_Explicit_Dereference
7876                then
7877                   return False;
7878                end if;
7879
7880             elsif Ada_Version >= Ada_2005 then
7881                if Is_Access_Type (Prefix_Type) then
7882
7883                   --  If the access type is pool-specific, and there is no
7884                   --  constrained partial view of the designated type, then the
7885                   --  designated object is known to be constrained.
7886
7887                   if Ekind (Prefix_Type) = E_Access_Type
7888                     and then not Effectively_Has_Constrained_Partial_View
7889                                    (Typ  => Designated_Type (Prefix_Type),
7890                                     Scop => Current_Scope)
7891                   then
7892                      return False;
7893
7894                   --  Otherwise (general access type, or there is a constrained
7895                   --  partial view of the designated type), we need to check
7896                   --  based on the designated type.
7897
7898                   else
7899                      Prefix_Type := Designated_Type (Prefix_Type);
7900                   end if;
7901                end if;
7902             end if;
7903
7904             Comp :=
7905               Original_Record_Component (Entity (Selector_Name (Object)));
7906
7907             --  As per AI-0017, the renaming is illegal in a generic body, even
7908             --  if the subtype is indefinite.
7909
7910             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
7911
7912             if not Is_Constrained (Prefix_Type)
7913               and then (not Is_Indefinite_Subtype (Prefix_Type)
7914                          or else
7915                           (Is_Generic_Type (Prefix_Type)
7916                             and then Ekind (Current_Scope) = E_Generic_Package
7917                             and then In_Package_Body (Current_Scope)))
7918
7919               and then (Is_Declared_Within_Variant (Comp)
7920                           or else Has_Discriminant_Dependent_Constraint (Comp))
7921               and then (not P_Aliased or else Ada_Version >= Ada_2005)
7922             then
7923                return True;
7924
7925             else
7926                return
7927                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
7928
7929             end if;
7930
7931          elsif Nkind (Object) = N_Indexed_Component
7932            or else Nkind (Object) = N_Slice
7933          then
7934             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
7935
7936          --  A type conversion that Is_Variable is a view conversion:
7937          --  go back to the denoted object.
7938
7939          elsif Nkind (Object) = N_Type_Conversion then
7940             return
7941               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
7942          end if;
7943       end if;
7944
7945       return False;
7946    end Is_Dependent_Component_Of_Mutable_Object;
7947
7948    ---------------------
7949    -- Is_Dereferenced --
7950    ---------------------
7951
7952    function Is_Dereferenced (N : Node_Id) return Boolean is
7953       P : constant Node_Id := Parent (N);
7954    begin
7955       return
7956          (Nkind (P) = N_Selected_Component
7957             or else
7958           Nkind (P) = N_Explicit_Dereference
7959             or else
7960           Nkind (P) = N_Indexed_Component
7961             or else
7962           Nkind (P) = N_Slice)
7963         and then Prefix (P) = N;
7964    end Is_Dereferenced;
7965
7966    ----------------------
7967    -- Is_Descendent_Of --
7968    ----------------------
7969
7970    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
7971       T    : Entity_Id;
7972       Etyp : Entity_Id;
7973
7974    begin
7975       pragma Assert (Nkind (T1) in N_Entity);
7976       pragma Assert (Nkind (T2) in N_Entity);
7977
7978       T := Base_Type (T1);
7979
7980       --  Immediate return if the types match
7981
7982       if T = T2 then
7983          return True;
7984
7985       --  Comment needed here ???
7986
7987       elsif Ekind (T) = E_Class_Wide_Type then
7988          return Etype (T) = T2;
7989
7990       --  All other cases
7991
7992       else
7993          loop
7994             Etyp := Etype (T);
7995
7996             --  Done if we found the type we are looking for
7997
7998             if Etyp = T2 then
7999                return True;
8000
8001             --  Done if no more derivations to check
8002
8003             elsif T = T1
8004               or else T = Etyp
8005             then
8006                return False;
8007
8008             --  Following test catches error cases resulting from prev errors
8009
8010             elsif No (Etyp) then
8011                return False;
8012
8013             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
8014                return False;
8015
8016             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
8017                return False;
8018             end if;
8019
8020             T := Base_Type (Etyp);
8021          end loop;
8022       end if;
8023    end Is_Descendent_Of;
8024
8025    ----------------------------
8026    -- Is_Expression_Function --
8027    ----------------------------
8028
8029    function Is_Expression_Function (Subp : Entity_Id) return Boolean is
8030       Decl : constant Node_Id := Unit_Declaration_Node (Subp);
8031
8032    begin
8033       return Ekind (Subp) = E_Function
8034         and then Nkind (Decl) = N_Subprogram_Declaration
8035         and then
8036           (Nkind (Original_Node (Decl)) = N_Expression_Function
8037             or else
8038               (Present (Corresponding_Body (Decl))
8039                 and then
8040                   Nkind (Original_Node
8041                      (Unit_Declaration_Node (Corresponding_Body (Decl))))
8042                  = N_Expression_Function));
8043    end Is_Expression_Function;
8044
8045    --------------
8046    -- Is_False --
8047    --------------
8048
8049    function Is_False (U : Uint) return Boolean is
8050    begin
8051       return (U = 0);
8052    end Is_False;
8053
8054    ---------------------------
8055    -- Is_Fixed_Model_Number --
8056    ---------------------------
8057
8058    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
8059       S : constant Ureal := Small_Value (T);
8060       M : Urealp.Save_Mark;
8061       R : Boolean;
8062    begin
8063       M := Urealp.Mark;
8064       R := (U = UR_Trunc (U / S) * S);
8065       Urealp.Release (M);
8066       return R;
8067    end Is_Fixed_Model_Number;
8068
8069    -------------------------------
8070    -- Is_Fully_Initialized_Type --
8071    -------------------------------
8072
8073    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
8074    begin
8075       --  In Ada2012, a scalar type with an aspect Default_Value
8076       --  is fully initialized.
8077
8078       if Is_Scalar_Type (Typ) then
8079          return Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ);
8080
8081       elsif Is_Access_Type (Typ) then
8082          return True;
8083
8084       elsif Is_Array_Type (Typ) then
8085          if Is_Fully_Initialized_Type (Component_Type (Typ))
8086            or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
8087          then
8088             return True;
8089          end if;
8090
8091          --  An interesting case, if we have a constrained type one of whose
8092          --  bounds is known to be null, then there are no elements to be
8093          --  initialized, so all the elements are initialized!
8094
8095          if Is_Constrained (Typ) then
8096             declare
8097                Indx     : Node_Id;
8098                Indx_Typ : Entity_Id;
8099                Lbd, Hbd : Node_Id;
8100
8101             begin
8102                Indx := First_Index (Typ);
8103                while Present (Indx) loop
8104                   if Etype (Indx) = Any_Type then
8105                      return False;
8106
8107                   --  If index is a range, use directly
8108
8109                   elsif Nkind (Indx) = N_Range then
8110                      Lbd := Low_Bound  (Indx);
8111                      Hbd := High_Bound (Indx);
8112
8113                   else
8114                      Indx_Typ := Etype (Indx);
8115
8116                      if Is_Private_Type (Indx_Typ)  then
8117                         Indx_Typ := Full_View (Indx_Typ);
8118                      end if;
8119
8120                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
8121                         return False;
8122                      else
8123                         Lbd := Type_Low_Bound  (Indx_Typ);
8124                         Hbd := Type_High_Bound (Indx_Typ);
8125                      end if;
8126                   end if;
8127
8128                   if Compile_Time_Known_Value (Lbd)
8129                     and then Compile_Time_Known_Value (Hbd)
8130                   then
8131                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
8132                         return True;
8133                      end if;
8134                   end if;
8135
8136                   Next_Index (Indx);
8137                end loop;
8138             end;
8139          end if;
8140
8141          --  If no null indexes, then type is not fully initialized
8142
8143          return False;
8144
8145       --  Record types
8146
8147       elsif Is_Record_Type (Typ) then
8148          if Has_Discriminants (Typ)
8149            and then
8150              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
8151            and then Is_Fully_Initialized_Variant (Typ)
8152          then
8153             return True;
8154          end if;
8155
8156          --  We consider bounded string types to be fully initialized, because
8157          --  otherwise we get false alarms when the Data component is not
8158          --  default-initialized.
8159
8160          if Is_Bounded_String (Typ) then
8161             return True;
8162          end if;
8163
8164          --  Controlled records are considered to be fully initialized if
8165          --  there is a user defined Initialize routine. This may not be
8166          --  entirely correct, but as the spec notes, we are guessing here
8167          --  what is best from the point of view of issuing warnings.
8168
8169          if Is_Controlled (Typ) then
8170             declare
8171                Utyp : constant Entity_Id := Underlying_Type (Typ);
8172
8173             begin
8174                if Present (Utyp) then
8175                   declare
8176                      Init : constant Entity_Id :=
8177                               (Find_Prim_Op
8178                                  (Underlying_Type (Typ), Name_Initialize));
8179
8180                   begin
8181                      if Present (Init)
8182                        and then Comes_From_Source (Init)
8183                        and then not
8184                          Is_Predefined_File_Name
8185                            (File_Name (Get_Source_File_Index (Sloc (Init))))
8186                      then
8187                         return True;
8188
8189                      elsif Has_Null_Extension (Typ)
8190                         and then
8191                           Is_Fully_Initialized_Type
8192                             (Etype (Base_Type (Typ)))
8193                      then
8194                         return True;
8195                      end if;
8196                   end;
8197                end if;
8198             end;
8199          end if;
8200
8201          --  Otherwise see if all record components are initialized
8202
8203          declare
8204             Ent : Entity_Id;
8205
8206          begin
8207             Ent := First_Entity (Typ);
8208             while Present (Ent) loop
8209                if Ekind (Ent) = E_Component
8210                  and then (No (Parent (Ent))
8211                              or else No (Expression (Parent (Ent))))
8212                  and then not Is_Fully_Initialized_Type (Etype (Ent))
8213
8214                   --  Special VM case for tag components, which need to be
8215                   --  defined in this case, but are never initialized as VMs
8216                   --  are using other dispatching mechanisms. Ignore this
8217                   --  uninitialized case. Note that this applies both to the
8218                   --  uTag entry and the main vtable pointer (CPP_Class case).
8219
8220                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
8221                then
8222                   return False;
8223                end if;
8224
8225                Next_Entity (Ent);
8226             end loop;
8227          end;
8228
8229          --  No uninitialized components, so type is fully initialized.
8230          --  Note that this catches the case of no components as well.
8231
8232          return True;
8233
8234       elsif Is_Concurrent_Type (Typ) then
8235          return True;
8236
8237       elsif Is_Private_Type (Typ) then
8238          declare
8239             U : constant Entity_Id := Underlying_Type (Typ);
8240
8241          begin
8242             if No (U) then
8243                return False;
8244             else
8245                return Is_Fully_Initialized_Type (U);
8246             end if;
8247          end;
8248
8249       else
8250          return False;
8251       end if;
8252    end Is_Fully_Initialized_Type;
8253
8254    ----------------------------------
8255    -- Is_Fully_Initialized_Variant --
8256    ----------------------------------
8257
8258    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
8259       Loc           : constant Source_Ptr := Sloc (Typ);
8260       Constraints   : constant List_Id    := New_List;
8261       Components    : constant Elist_Id   := New_Elmt_List;
8262       Comp_Elmt     : Elmt_Id;
8263       Comp_Id       : Node_Id;
8264       Comp_List     : Node_Id;
8265       Discr         : Entity_Id;
8266       Discr_Val     : Node_Id;
8267
8268       Report_Errors : Boolean;
8269       pragma Warnings (Off, Report_Errors);
8270
8271    begin
8272       if Serious_Errors_Detected > 0 then
8273          return False;
8274       end if;
8275
8276       if Is_Record_Type (Typ)
8277         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
8278         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
8279       then
8280          Comp_List := Component_List (Type_Definition (Parent (Typ)));
8281
8282          Discr := First_Discriminant (Typ);
8283          while Present (Discr) loop
8284             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
8285                Discr_Val := Expression (Parent (Discr));
8286
8287                if Present (Discr_Val)
8288                  and then Is_OK_Static_Expression (Discr_Val)
8289                then
8290                   Append_To (Constraints,
8291                     Make_Component_Association (Loc,
8292                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
8293                       Expression => New_Copy (Discr_Val)));
8294                else
8295                   return False;
8296                end if;
8297             else
8298                return False;
8299             end if;
8300
8301             Next_Discriminant (Discr);
8302          end loop;
8303
8304          Gather_Components
8305            (Typ           => Typ,
8306             Comp_List     => Comp_List,
8307             Governed_By   => Constraints,
8308             Into          => Components,
8309             Report_Errors => Report_Errors);
8310
8311          --  Check that each component present is fully initialized
8312
8313          Comp_Elmt := First_Elmt (Components);
8314          while Present (Comp_Elmt) loop
8315             Comp_Id := Node (Comp_Elmt);
8316
8317             if Ekind (Comp_Id) = E_Component
8318               and then (No (Parent (Comp_Id))
8319                          or else No (Expression (Parent (Comp_Id))))
8320               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
8321             then
8322                return False;
8323             end if;
8324
8325             Next_Elmt (Comp_Elmt);
8326          end loop;
8327
8328          return True;
8329
8330       elsif Is_Private_Type (Typ) then
8331          declare
8332             U : constant Entity_Id := Underlying_Type (Typ);
8333
8334          begin
8335             if No (U) then
8336                return False;
8337             else
8338                return Is_Fully_Initialized_Variant (U);
8339             end if;
8340          end;
8341       else
8342          return False;
8343       end if;
8344    end Is_Fully_Initialized_Variant;
8345
8346    ----------------------------
8347    -- Is_Inherited_Operation --
8348    ----------------------------
8349
8350    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
8351       pragma Assert (Is_Overloadable (E));
8352       Kind : constant Node_Kind := Nkind (Parent (E));
8353    begin
8354       return Kind = N_Full_Type_Declaration
8355         or else Kind = N_Private_Extension_Declaration
8356         or else Kind = N_Subtype_Declaration
8357         or else (Ekind (E) = E_Enumeration_Literal
8358                   and then Is_Derived_Type (Etype (E)));
8359    end Is_Inherited_Operation;
8360
8361    -------------------------------------
8362    -- Is_Inherited_Operation_For_Type --
8363    -------------------------------------
8364
8365    function Is_Inherited_Operation_For_Type
8366      (E   : Entity_Id;
8367       Typ : Entity_Id) return Boolean
8368    is
8369    begin
8370       return Is_Inherited_Operation (E)
8371         and then Etype (Parent (E)) = Typ;
8372    end Is_Inherited_Operation_For_Type;
8373
8374    -----------------
8375    -- Is_Iterator --
8376    -----------------
8377
8378    function Is_Iterator (Typ : Entity_Id) return Boolean is
8379       Ifaces_List : Elist_Id;
8380       Iface_Elmt  : Elmt_Id;
8381       Iface       : Entity_Id;
8382
8383    begin
8384       if Is_Class_Wide_Type (Typ)
8385         and then
8386           (Chars (Etype (Typ)) = Name_Forward_Iterator
8387              or else
8388            Chars (Etype (Typ)) = Name_Reversible_Iterator)
8389         and then
8390           Is_Predefined_File_Name
8391             (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
8392       then
8393          return True;
8394
8395       elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
8396          return False;
8397
8398       else
8399          Collect_Interfaces (Typ, Ifaces_List);
8400
8401          Iface_Elmt := First_Elmt (Ifaces_List);
8402          while Present (Iface_Elmt) loop
8403             Iface := Node (Iface_Elmt);
8404             if Chars (Iface) = Name_Forward_Iterator
8405               and then
8406                 Is_Predefined_File_Name
8407                   (Unit_File_Name (Get_Source_Unit (Iface)))
8408             then
8409                return True;
8410             end if;
8411
8412             Next_Elmt (Iface_Elmt);
8413          end loop;
8414
8415          return False;
8416       end if;
8417    end Is_Iterator;
8418
8419    ------------
8420    -- Is_LHS --
8421    ------------
8422
8423    --  We seem to have a lot of overlapping functions that do similar things
8424    --  (testing for left hand sides or lvalues???). Anyway, since this one is
8425    --  purely syntactic, it should be in Sem_Aux I would think???
8426
8427    function Is_LHS (N : Node_Id) return Boolean is
8428       P : constant Node_Id := Parent (N);
8429
8430    begin
8431       if Nkind (P) = N_Assignment_Statement then
8432          return Name (P) = N;
8433
8434       elsif
8435         Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
8436       then
8437          return N = Prefix (P) and then Is_LHS (P);
8438
8439       else
8440          return False;
8441       end if;
8442    end Is_LHS;
8443
8444    -----------------------------
8445    -- Is_Library_Level_Entity --
8446    -----------------------------
8447
8448    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
8449    begin
8450       --  The following is a small optimization, and it also properly handles
8451       --  discriminals, which in task bodies might appear in expressions before
8452       --  the corresponding procedure has been created, and which therefore do
8453       --  not have an assigned scope.
8454
8455       if Is_Formal (E) then
8456          return False;
8457       end if;
8458
8459       --  Normal test is simply that the enclosing dynamic scope is Standard
8460
8461       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
8462    end Is_Library_Level_Entity;
8463
8464    --------------------------------
8465    -- Is_Limited_Class_Wide_Type --
8466    --------------------------------
8467
8468    function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
8469    begin
8470       return
8471         Is_Class_Wide_Type (Typ)
8472           and then Is_Limited_Type (Typ);
8473    end Is_Limited_Class_Wide_Type;
8474
8475    ---------------------------------
8476    -- Is_Local_Variable_Reference --
8477    ---------------------------------
8478
8479    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
8480    begin
8481       if not Is_Entity_Name (Expr) then
8482          return False;
8483
8484       else
8485          declare
8486             Ent : constant Entity_Id := Entity (Expr);
8487             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
8488          begin
8489             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
8490                return False;
8491             else
8492                return Present (Sub) and then Sub = Current_Subprogram;
8493             end if;
8494          end;
8495       end if;
8496    end Is_Local_Variable_Reference;
8497
8498    -------------------------
8499    -- Is_Object_Reference --
8500    -------------------------
8501
8502    function Is_Object_Reference (N : Node_Id) return Boolean is
8503
8504       function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
8505       --  Determine whether N is the name of an internally-generated renaming
8506
8507       --------------------------------------
8508       -- Is_Internally_Generated_Renaming --
8509       --------------------------------------
8510
8511       function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
8512          P : Node_Id;
8513
8514       begin
8515          P := N;
8516          while Present (P) loop
8517             if Nkind (P) = N_Object_Renaming_Declaration then
8518                return not Comes_From_Source (P);
8519             elsif Is_List_Member (P) then
8520                return False;
8521             end if;
8522
8523             P := Parent (P);
8524          end loop;
8525
8526          return False;
8527       end Is_Internally_Generated_Renaming;
8528
8529    --  Start of processing for Is_Object_Reference
8530
8531    begin
8532       if Is_Entity_Name (N) then
8533          return Present (Entity (N)) and then Is_Object (Entity (N));
8534
8535       else
8536          case Nkind (N) is
8537             when N_Indexed_Component | N_Slice =>
8538                return
8539                  Is_Object_Reference (Prefix (N))
8540                    or else Is_Access_Type (Etype (Prefix (N)));
8541
8542             --  In Ada 95, a function call is a constant object; a procedure
8543             --  call is not.
8544
8545             when N_Function_Call =>
8546                return Etype (N) /= Standard_Void_Type;
8547
8548             --  Attributes 'Input and 'Result produce objects
8549
8550             when N_Attribute_Reference =>
8551                return Attribute_Name (N) = Name_Input
8552                         or else
8553                       Attribute_Name (N) = Name_Result;
8554
8555             when N_Selected_Component =>
8556                return
8557                  Is_Object_Reference (Selector_Name (N))
8558                    and then
8559                      (Is_Object_Reference (Prefix (N))
8560                         or else Is_Access_Type (Etype (Prefix (N))));
8561
8562             when N_Explicit_Dereference =>
8563                return True;
8564
8565             --  A view conversion of a tagged object is an object reference
8566
8567             when N_Type_Conversion =>
8568                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
8569                  and then Is_Tagged_Type (Etype (Expression (N)))
8570                  and then Is_Object_Reference (Expression (N));
8571
8572             --  An unchecked type conversion is considered to be an object if
8573             --  the operand is an object (this construction arises only as a
8574             --  result of expansion activities).
8575
8576             when N_Unchecked_Type_Conversion =>
8577                return True;
8578
8579             --  Allow string literals to act as objects as long as they appear
8580             --  in internally-generated renamings. The expansion of iterators
8581             --  may generate such renamings when the range involves a string
8582             --  literal.
8583
8584             when N_String_Literal =>
8585                return Is_Internally_Generated_Renaming (Parent (N));
8586
8587             --  AI05-0003: In Ada 2012 a qualified expression is a name.
8588             --  This allows disambiguation of function calls and the use
8589             --  of aggregates in more contexts.
8590
8591             when N_Qualified_Expression =>
8592                if Ada_Version <  Ada_2012 then
8593                   return False;
8594                else
8595                   return Is_Object_Reference (Expression (N))
8596                     or else Nkind (Expression (N)) = N_Aggregate;
8597                end if;
8598
8599             when others =>
8600                return False;
8601          end case;
8602       end if;
8603    end Is_Object_Reference;
8604
8605    -----------------------------------
8606    -- Is_OK_Variable_For_Out_Formal --
8607    -----------------------------------
8608
8609    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
8610    begin
8611       Note_Possible_Modification (AV, Sure => True);
8612
8613       --  We must reject parenthesized variable names. The check for
8614       --  Comes_From_Source is present because there are currently
8615       --  cases where the compiler violates this rule (e.g. passing
8616       --  a task object to its controlled Initialize routine).
8617
8618       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
8619          return False;
8620
8621       --  A variable is always allowed
8622
8623       elsif Is_Variable (AV) then
8624          return True;
8625
8626       --  Unchecked conversions are allowed only if they come from the
8627       --  generated code, which sometimes uses unchecked conversions for out
8628       --  parameters in cases where code generation is unaffected. We tell
8629       --  source unchecked conversions by seeing if they are rewrites of an
8630       --  original Unchecked_Conversion function call, or of an explicit
8631       --  conversion of a function call.
8632
8633       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
8634          if Nkind (Original_Node (AV)) = N_Function_Call then
8635             return False;
8636
8637          elsif Comes_From_Source (AV)
8638            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
8639          then
8640             return False;
8641
8642          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
8643             return Is_OK_Variable_For_Out_Formal (Expression (AV));
8644
8645          else
8646             return True;
8647          end if;
8648
8649       --  Normal type conversions are allowed if argument is a variable
8650
8651       elsif Nkind (AV) = N_Type_Conversion then
8652          if Is_Variable (Expression (AV))
8653            and then Paren_Count (Expression (AV)) = 0
8654          then
8655             Note_Possible_Modification (Expression (AV), Sure => True);
8656             return True;
8657
8658          --  We also allow a non-parenthesized expression that raises
8659          --  constraint error if it rewrites what used to be a variable
8660
8661          elsif Raises_Constraint_Error (Expression (AV))
8662             and then Paren_Count (Expression (AV)) = 0
8663             and then Is_Variable (Original_Node (Expression (AV)))
8664          then
8665             return True;
8666
8667          --  Type conversion of something other than a variable
8668
8669          else
8670             return False;
8671          end if;
8672
8673       --  If this node is rewritten, then test the original form, if that is
8674       --  OK, then we consider the rewritten node OK (for example, if the
8675       --  original node is a conversion, then Is_Variable will not be true
8676       --  but we still want to allow the conversion if it converts a variable).
8677
8678       elsif Original_Node (AV) /= AV then
8679
8680          --  In Ada 2012, the explicit dereference may be a rewritten call to a
8681          --  Reference function.
8682
8683          if Ada_Version >= Ada_2012
8684            and then Nkind (Original_Node (AV)) = N_Function_Call
8685            and then
8686              Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
8687          then
8688             return True;
8689
8690          else
8691             return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
8692          end if;
8693
8694       --  All other non-variables are rejected
8695
8696       else
8697          return False;
8698       end if;
8699    end Is_OK_Variable_For_Out_Formal;
8700
8701    -----------------------------------
8702    -- Is_Partially_Initialized_Type --
8703    -----------------------------------
8704
8705    function Is_Partially_Initialized_Type
8706      (Typ              : Entity_Id;
8707       Include_Implicit : Boolean := True) return Boolean
8708    is
8709    begin
8710       if Is_Scalar_Type (Typ) then
8711          return False;
8712
8713       elsif Is_Access_Type (Typ) then
8714          return Include_Implicit;
8715
8716       elsif Is_Array_Type (Typ) then
8717
8718          --  If component type is partially initialized, so is array type
8719
8720          if Is_Partially_Initialized_Type
8721               (Component_Type (Typ), Include_Implicit)
8722          then
8723             return True;
8724
8725          --  Otherwise we are only partially initialized if we are fully
8726          --  initialized (this is the empty array case, no point in us
8727          --  duplicating that code here).
8728
8729          else
8730             return Is_Fully_Initialized_Type (Typ);
8731          end if;
8732
8733       elsif Is_Record_Type (Typ) then
8734
8735          --  A discriminated type is always partially initialized if in
8736          --  all mode
8737
8738          if Has_Discriminants (Typ) and then Include_Implicit then
8739             return True;
8740
8741          --  A tagged type is always partially initialized
8742
8743          elsif Is_Tagged_Type (Typ) then
8744             return True;
8745
8746          --  Case of non-discriminated record
8747
8748          else
8749             declare
8750                Ent : Entity_Id;
8751
8752                Component_Present : Boolean := False;
8753                --  Set True if at least one component is present. If no
8754                --  components are present, then record type is fully
8755                --  initialized (another odd case, like the null array).
8756
8757             begin
8758                --  Loop through components
8759
8760                Ent := First_Entity (Typ);
8761                while Present (Ent) loop
8762                   if Ekind (Ent) = E_Component then
8763                      Component_Present := True;
8764
8765                      --  If a component has an initialization expression then
8766                      --  the enclosing record type is partially initialized
8767
8768                      if Present (Parent (Ent))
8769                        and then Present (Expression (Parent (Ent)))
8770                      then
8771                         return True;
8772
8773                      --  If a component is of a type which is itself partially
8774                      --  initialized, then the enclosing record type is also.
8775
8776                      elsif Is_Partially_Initialized_Type
8777                              (Etype (Ent), Include_Implicit)
8778                      then
8779                         return True;
8780                      end if;
8781                   end if;
8782
8783                   Next_Entity (Ent);
8784                end loop;
8785
8786                --  No initialized components found. If we found any components
8787                --  they were all uninitialized so the result is false.
8788
8789                if Component_Present then
8790                   return False;
8791
8792                --  But if we found no components, then all the components are
8793                --  initialized so we consider the type to be initialized.
8794
8795                else
8796                   return True;
8797                end if;
8798             end;
8799          end if;
8800
8801       --  Concurrent types are always fully initialized
8802
8803       elsif Is_Concurrent_Type (Typ) then
8804          return True;
8805
8806       --  For a private type, go to underlying type. If there is no underlying
8807       --  type then just assume this partially initialized. Not clear if this
8808       --  can happen in a non-error case, but no harm in testing for this.
8809
8810       elsif Is_Private_Type (Typ) then
8811          declare
8812             U : constant Entity_Id := Underlying_Type (Typ);
8813          begin
8814             if No (U) then
8815                return True;
8816             else
8817                return Is_Partially_Initialized_Type (U, Include_Implicit);
8818             end if;
8819          end;
8820
8821       --  For any other type (are there any?) assume partially initialized
8822
8823       else
8824          return True;
8825       end if;
8826    end Is_Partially_Initialized_Type;
8827
8828    ------------------------------------
8829    -- Is_Potentially_Persistent_Type --
8830    ------------------------------------
8831
8832    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
8833       Comp : Entity_Id;
8834       Indx : Node_Id;
8835
8836    begin
8837       --  For private type, test corresponding full type
8838
8839       if Is_Private_Type (T) then
8840          return Is_Potentially_Persistent_Type (Full_View (T));
8841
8842       --  Scalar types are potentially persistent
8843
8844       elsif Is_Scalar_Type (T) then
8845          return True;
8846
8847       --  Record type is potentially persistent if not tagged and the types of
8848       --  all it components are potentially persistent, and no component has
8849       --  an initialization expression.
8850
8851       elsif Is_Record_Type (T)
8852         and then not Is_Tagged_Type (T)
8853         and then not Is_Partially_Initialized_Type (T)
8854       then
8855          Comp := First_Component (T);
8856          while Present (Comp) loop
8857             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
8858                return False;
8859             else
8860                Next_Entity (Comp);
8861             end if;
8862          end loop;
8863
8864          return True;
8865
8866       --  Array type is potentially persistent if its component type is
8867       --  potentially persistent and if all its constraints are static.
8868
8869       elsif Is_Array_Type (T) then
8870          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
8871             return False;
8872          end if;
8873
8874          Indx := First_Index (T);
8875          while Present (Indx) loop
8876             if not Is_OK_Static_Subtype (Etype (Indx)) then
8877                return False;
8878             else
8879                Next_Index (Indx);
8880             end if;
8881          end loop;
8882
8883          return True;
8884
8885       --  All other types are not potentially persistent
8886
8887       else
8888          return False;
8889       end if;
8890    end Is_Potentially_Persistent_Type;
8891
8892    ---------------------------------
8893    -- Is_Protected_Self_Reference --
8894    ---------------------------------
8895
8896    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
8897
8898       function In_Access_Definition (N : Node_Id) return Boolean;
8899       --  Returns true if N belongs to an access definition
8900
8901       --------------------------
8902       -- In_Access_Definition --
8903       --------------------------
8904
8905       function In_Access_Definition (N : Node_Id) return Boolean is
8906          P : Node_Id;
8907
8908       begin
8909          P := Parent (N);
8910          while Present (P) loop
8911             if Nkind (P) = N_Access_Definition then
8912                return True;
8913             end if;
8914
8915             P := Parent (P);
8916          end loop;
8917
8918          return False;
8919       end In_Access_Definition;
8920
8921    --  Start of processing for Is_Protected_Self_Reference
8922
8923    begin
8924       --  Verify that prefix is analyzed and has the proper form. Note that
8925       --  the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
8926       --  which also produce the address of an entity, do not analyze their
8927       --  prefix because they denote entities that are not necessarily visible.
8928       --  Neither of them can apply to a protected type.
8929
8930       return Ada_Version >= Ada_2005
8931         and then Is_Entity_Name (N)
8932         and then Present (Entity (N))
8933         and then Is_Protected_Type (Entity (N))
8934         and then In_Open_Scopes (Entity (N))
8935         and then not In_Access_Definition (N);
8936    end Is_Protected_Self_Reference;
8937
8938    -----------------------------
8939    -- Is_RCI_Pkg_Spec_Or_Body --
8940    -----------------------------
8941
8942    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
8943
8944       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
8945       --  Return True if the unit of Cunit is an RCI package declaration
8946
8947       ---------------------------
8948       -- Is_RCI_Pkg_Decl_Cunit --
8949       ---------------------------
8950
8951       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
8952          The_Unit : constant Node_Id := Unit (Cunit);
8953
8954       begin
8955          if Nkind (The_Unit) /= N_Package_Declaration then
8956             return False;
8957          end if;
8958
8959          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
8960       end Is_RCI_Pkg_Decl_Cunit;
8961
8962    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
8963
8964    begin
8965       return Is_RCI_Pkg_Decl_Cunit (Cunit)
8966         or else
8967          (Nkind (Unit (Cunit)) = N_Package_Body
8968            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
8969    end Is_RCI_Pkg_Spec_Or_Body;
8970
8971    -----------------------------------------
8972    -- Is_Remote_Access_To_Class_Wide_Type --
8973    -----------------------------------------
8974
8975    function Is_Remote_Access_To_Class_Wide_Type
8976      (E : Entity_Id) return Boolean
8977    is
8978    begin
8979       --  A remote access to class-wide type is a general access to object type
8980       --  declared in the visible part of a Remote_Types or Remote_Call_
8981       --  Interface unit.
8982
8983       return Ekind (E) = E_General_Access_Type
8984         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
8985    end Is_Remote_Access_To_Class_Wide_Type;
8986
8987    -----------------------------------------
8988    -- Is_Remote_Access_To_Subprogram_Type --
8989    -----------------------------------------
8990
8991    function Is_Remote_Access_To_Subprogram_Type
8992      (E : Entity_Id) return Boolean
8993    is
8994    begin
8995       return (Ekind (E) = E_Access_Subprogram_Type
8996                 or else (Ekind (E) = E_Record_Type
8997                            and then Present (Corresponding_Remote_Type (E))))
8998         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
8999    end Is_Remote_Access_To_Subprogram_Type;
9000
9001    --------------------
9002    -- Is_Remote_Call --
9003    --------------------
9004
9005    function Is_Remote_Call (N : Node_Id) return Boolean is
9006    begin
9007       if Nkind (N) not in N_Subprogram_Call then
9008
9009          --  An entry call cannot be remote
9010
9011          return False;
9012
9013       elsif Nkind (Name (N)) in N_Has_Entity
9014         and then Is_Remote_Call_Interface (Entity (Name (N)))
9015       then
9016          --  A subprogram declared in the spec of a RCI package is remote
9017
9018          return True;
9019
9020       elsif Nkind (Name (N)) = N_Explicit_Dereference
9021         and then Is_Remote_Access_To_Subprogram_Type
9022                    (Etype (Prefix (Name (N))))
9023       then
9024          --  The dereference of a RAS is a remote call
9025
9026          return True;
9027
9028       elsif Present (Controlling_Argument (N))
9029         and then Is_Remote_Access_To_Class_Wide_Type
9030           (Etype (Controlling_Argument (N)))
9031       then
9032          --  Any primitive operation call with a controlling argument of
9033          --  a RACW type is a remote call.
9034
9035          return True;
9036       end if;
9037
9038       --  All other calls are local calls
9039
9040       return False;
9041    end Is_Remote_Call;
9042
9043    ----------------------
9044    -- Is_Renamed_Entry --
9045    ----------------------
9046
9047    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
9048       Orig_Node : Node_Id := Empty;
9049       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
9050
9051       function Is_Entry (Nam : Node_Id) return Boolean;
9052       --  Determine whether Nam is an entry. Traverse selectors if there are
9053       --  nested selected components.
9054
9055       --------------
9056       -- Is_Entry --
9057       --------------
9058
9059       function Is_Entry (Nam : Node_Id) return Boolean is
9060       begin
9061          if Nkind (Nam) = N_Selected_Component then
9062             return Is_Entry (Selector_Name (Nam));
9063          end if;
9064
9065          return Ekind (Entity (Nam)) = E_Entry;
9066       end Is_Entry;
9067
9068    --  Start of processing for Is_Renamed_Entry
9069
9070    begin
9071       if Present (Alias (Proc_Nam)) then
9072          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
9073       end if;
9074
9075       --  Look for a rewritten subprogram renaming declaration
9076
9077       if Nkind (Subp_Decl) = N_Subprogram_Declaration
9078         and then Present (Original_Node (Subp_Decl))
9079       then
9080          Orig_Node := Original_Node (Subp_Decl);
9081       end if;
9082
9083       --  The rewritten subprogram is actually an entry
9084
9085       if Present (Orig_Node)
9086         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
9087         and then Is_Entry (Name (Orig_Node))
9088       then
9089          return True;
9090       end if;
9091
9092       return False;
9093    end Is_Renamed_Entry;
9094
9095    ----------------------------
9096    -- Is_Reversible_Iterator --
9097    ----------------------------
9098
9099    function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
9100       Ifaces_List : Elist_Id;
9101       Iface_Elmt  : Elmt_Id;
9102       Iface       : Entity_Id;
9103
9104    begin
9105       if Is_Class_Wide_Type (Typ)
9106         and then  Chars (Etype (Typ)) = Name_Reversible_Iterator
9107         and then
9108           Is_Predefined_File_Name
9109             (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
9110       then
9111          return True;
9112
9113       elsif not Is_Tagged_Type (Typ)
9114         or else not Is_Derived_Type (Typ)
9115       then
9116          return False;
9117
9118       else
9119          Collect_Interfaces (Typ, Ifaces_List);
9120
9121          Iface_Elmt := First_Elmt (Ifaces_List);
9122          while Present (Iface_Elmt) loop
9123             Iface := Node (Iface_Elmt);
9124             if Chars (Iface) = Name_Reversible_Iterator
9125               and then
9126                 Is_Predefined_File_Name
9127                   (Unit_File_Name (Get_Source_Unit (Iface)))
9128             then
9129                return True;
9130             end if;
9131
9132             Next_Elmt (Iface_Elmt);
9133          end loop;
9134       end if;
9135
9136       return False;
9137    end Is_Reversible_Iterator;
9138
9139    ----------------------
9140    -- Is_Selector_Name --
9141    ----------------------
9142
9143    function Is_Selector_Name (N : Node_Id) return Boolean is
9144    begin
9145       if not Is_List_Member (N) then
9146          declare
9147             P : constant Node_Id   := Parent (N);
9148             K : constant Node_Kind := Nkind (P);
9149          begin
9150             return
9151               (K = N_Expanded_Name          or else
9152                K = N_Generic_Association    or else
9153                K = N_Parameter_Association  or else
9154                K = N_Selected_Component)
9155               and then Selector_Name (P) = N;
9156          end;
9157
9158       else
9159          declare
9160             L : constant List_Id := List_Containing (N);
9161             P : constant Node_Id := Parent (L);
9162          begin
9163             return (Nkind (P) = N_Discriminant_Association
9164                      and then Selector_Names (P) = L)
9165               or else
9166                    (Nkind (P) = N_Component_Association
9167                      and then Choices (P) = L);
9168          end;
9169       end if;
9170    end Is_Selector_Name;
9171
9172    ----------------------------------
9173    -- Is_SPARK_Initialization_Expr --
9174    ----------------------------------
9175
9176    function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
9177       Is_Ok     : Boolean;
9178       Expr      : Node_Id;
9179       Comp_Assn : Node_Id;
9180       Orig_N    : constant Node_Id := Original_Node (N);
9181
9182    begin
9183       Is_Ok := True;
9184
9185       if not Comes_From_Source (Orig_N) then
9186          goto Done;
9187       end if;
9188
9189       pragma Assert (Nkind (Orig_N) in N_Subexpr);
9190
9191       case Nkind (Orig_N) is
9192          when N_Character_Literal |
9193               N_Integer_Literal   |
9194               N_Real_Literal      |
9195               N_String_Literal    =>
9196             null;
9197
9198          when N_Identifier    |
9199               N_Expanded_Name =>
9200             if Is_Entity_Name (Orig_N)
9201               and then Present (Entity (Orig_N))  --  needed in some cases
9202             then
9203                case Ekind (Entity (Orig_N)) is
9204                   when E_Constant            |
9205                        E_Enumeration_Literal |
9206                        E_Named_Integer       |
9207                        E_Named_Real          =>
9208                      null;
9209                   when others =>
9210                      if Is_Type (Entity (Orig_N)) then
9211                         null;
9212                      else
9213                         Is_Ok := False;
9214                      end if;
9215                end case;
9216             end if;
9217
9218          when N_Qualified_Expression |
9219               N_Type_Conversion      =>
9220             Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
9221
9222          when N_Unary_Op =>
9223             Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
9224
9225          when N_Binary_Op       |
9226               N_Short_Circuit   |
9227               N_Membership_Test =>
9228             Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
9229               and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
9230
9231          when N_Aggregate           |
9232               N_Extension_Aggregate =>
9233             if Nkind (Orig_N) = N_Extension_Aggregate then
9234                Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
9235             end if;
9236
9237             Expr := First (Expressions (Orig_N));
9238             while Present (Expr) loop
9239                if not Is_SPARK_Initialization_Expr (Expr) then
9240                   Is_Ok := False;
9241                   goto Done;
9242                end if;
9243
9244                Next (Expr);
9245             end loop;
9246
9247             Comp_Assn := First (Component_Associations (Orig_N));
9248             while Present (Comp_Assn) loop
9249                Expr := Expression (Comp_Assn);
9250                if Present (Expr)  --  needed for box association
9251                  and then not Is_SPARK_Initialization_Expr (Expr)
9252                then
9253                   Is_Ok := False;
9254                   goto Done;
9255                end if;
9256
9257                Next (Comp_Assn);
9258             end loop;
9259
9260          when N_Attribute_Reference =>
9261             if Nkind (Prefix (Orig_N)) in N_Subexpr then
9262                Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
9263             end if;
9264
9265             Expr := First (Expressions (Orig_N));
9266             while Present (Expr) loop
9267                if not Is_SPARK_Initialization_Expr (Expr) then
9268                   Is_Ok := False;
9269                   goto Done;
9270                end if;
9271
9272                Next (Expr);
9273             end loop;
9274
9275          --  Selected components might be expanded named not yet resolved, so
9276          --  default on the safe side. (Eg on sparklex.ads)
9277
9278          when N_Selected_Component =>
9279             null;
9280
9281          when others =>
9282             Is_Ok := False;
9283       end case;
9284
9285    <<Done>>
9286       return Is_Ok;
9287    end Is_SPARK_Initialization_Expr;
9288
9289    -------------------------------
9290    -- Is_SPARK_Object_Reference --
9291    -------------------------------
9292
9293    function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
9294    begin
9295       if Is_Entity_Name (N) then
9296          return Present (Entity (N))
9297            and then
9298              (Ekind_In (Entity (N), E_Constant, E_Variable)
9299               or else Ekind (Entity (N)) in Formal_Kind);
9300
9301       else
9302          case Nkind (N) is
9303             when N_Selected_Component =>
9304                return Is_SPARK_Object_Reference (Prefix (N));
9305
9306             when others =>
9307                return False;
9308          end case;
9309       end if;
9310    end Is_SPARK_Object_Reference;
9311
9312    ------------------
9313    -- Is_Statement --
9314    ------------------
9315
9316    function Is_Statement (N : Node_Id) return Boolean is
9317    begin
9318       return
9319         Nkind (N) in N_Statement_Other_Than_Procedure_Call
9320           or else Nkind (N) = N_Procedure_Call_Statement;
9321    end Is_Statement;
9322
9323    --------------------------------------------------
9324    -- Is_Subprogram_Stub_Without_Prior_Declaration --
9325    --------------------------------------------------
9326
9327    function Is_Subprogram_Stub_Without_Prior_Declaration
9328      (N : Node_Id) return Boolean
9329    is
9330    begin
9331       --  A subprogram stub without prior declaration serves as declaration for
9332       --  the actual subprogram body. As such, it has an attached defining
9333       --  entity of E_[Generic_]Function or E_[Generic_]Procedure.
9334
9335       return Nkind (N) = N_Subprogram_Body_Stub
9336         and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
9337    end Is_Subprogram_Stub_Without_Prior_Declaration;
9338
9339    ---------------------------------
9340    -- Is_Synchronized_Tagged_Type --
9341    ---------------------------------
9342
9343    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
9344       Kind : constant Entity_Kind := Ekind (Base_Type (E));
9345
9346    begin
9347       --  A task or protected type derived from an interface is a tagged type.
9348       --  Such a tagged type is called a synchronized tagged type, as are
9349       --  synchronized interfaces and private extensions whose declaration
9350       --  includes the reserved word synchronized.
9351
9352       return (Is_Tagged_Type (E)
9353                 and then (Kind = E_Task_Type
9354                            or else Kind = E_Protected_Type))
9355             or else
9356              (Is_Interface (E)
9357                 and then Is_Synchronized_Interface (E))
9358             or else
9359              (Ekind (E) = E_Record_Type_With_Private
9360                 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
9361                 and then (Synchronized_Present (Parent (E))
9362                            or else Is_Synchronized_Interface (Etype (E))));
9363    end Is_Synchronized_Tagged_Type;
9364
9365    -----------------
9366    -- Is_Transfer --
9367    -----------------
9368
9369    function Is_Transfer (N : Node_Id) return Boolean is
9370       Kind : constant Node_Kind := Nkind (N);
9371
9372    begin
9373       if Kind = N_Simple_Return_Statement
9374            or else
9375          Kind = N_Extended_Return_Statement
9376            or else
9377          Kind = N_Goto_Statement
9378            or else
9379          Kind = N_Raise_Statement
9380            or else
9381          Kind = N_Requeue_Statement
9382       then
9383          return True;
9384
9385       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
9386         and then No (Condition (N))
9387       then
9388          return True;
9389
9390       elsif Kind = N_Procedure_Call_Statement
9391         and then Is_Entity_Name (Name (N))
9392         and then Present (Entity (Name (N)))
9393         and then No_Return (Entity (Name (N)))
9394       then
9395          return True;
9396
9397       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
9398          return True;
9399
9400       else
9401          return False;
9402       end if;
9403    end Is_Transfer;
9404
9405    -------------
9406    -- Is_True --
9407    -------------
9408
9409    function Is_True (U : Uint) return Boolean is
9410    begin
9411       return (U /= 0);
9412    end Is_True;
9413
9414    -------------------------------
9415    -- Is_Universal_Numeric_Type --
9416    -------------------------------
9417
9418    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
9419    begin
9420       return T = Universal_Integer or else T = Universal_Real;
9421    end Is_Universal_Numeric_Type;
9422
9423    -------------------
9424    -- Is_Value_Type --
9425    -------------------
9426
9427    function Is_Value_Type (T : Entity_Id) return Boolean is
9428    begin
9429       return VM_Target = CLI_Target
9430         and then Nkind (T) in N_Has_Chars
9431         and then Chars (T) /= No_Name
9432         and then Get_Name_String (Chars (T)) = "valuetype";
9433    end Is_Value_Type;
9434
9435    ---------------------
9436    -- Is_VMS_Operator --
9437    ---------------------
9438
9439    function Is_VMS_Operator (Op : Entity_Id) return Boolean is
9440    begin
9441       --  The VMS operators are declared in a child of System that is loaded
9442       --  through pragma Extend_System. In some rare cases a program is run
9443       --  with this extension but without indicating that the target is VMS.
9444
9445       return Ekind (Op) = E_Function
9446         and then Is_Intrinsic_Subprogram (Op)
9447         and then
9448           ((Present_System_Aux
9449             and then Scope (Op) = System_Aux_Id)
9450            or else
9451            (True_VMS_Target
9452              and then Scope (Scope (Op)) = RTU_Entity (System)));
9453    end Is_VMS_Operator;
9454
9455    -----------------
9456    -- Is_Variable --
9457    -----------------
9458
9459    function Is_Variable
9460      (N                 : Node_Id;
9461       Use_Original_Node : Boolean := True) return Boolean
9462    is
9463       Orig_Node : Node_Id;
9464
9465       function In_Protected_Function (E : Entity_Id) return Boolean;
9466       --  Within a protected function, the private components of the enclosing
9467       --  protected type are constants. A function nested within a (protected)
9468       --  procedure is not itself protected.
9469
9470       function Is_Variable_Prefix (P : Node_Id) return Boolean;
9471       --  Prefixes can involve implicit dereferences, in which case we must
9472       --  test for the case of a reference of a constant access type, which can
9473       --  can never be a variable.
9474
9475       ---------------------------
9476       -- In_Protected_Function --
9477       ---------------------------
9478
9479       function In_Protected_Function (E : Entity_Id) return Boolean is
9480          Prot : constant Entity_Id := Scope (E);
9481          S    : Entity_Id;
9482
9483       begin
9484          if not Is_Protected_Type (Prot) then
9485             return False;
9486          else
9487             S := Current_Scope;
9488             while Present (S) and then S /= Prot loop
9489                if Ekind (S) = E_Function and then Scope (S) = Prot then
9490                   return True;
9491                end if;
9492
9493                S := Scope (S);
9494             end loop;
9495
9496             return False;
9497          end if;
9498       end In_Protected_Function;
9499
9500       ------------------------
9501       -- Is_Variable_Prefix --
9502       ------------------------
9503
9504       function Is_Variable_Prefix (P : Node_Id) return Boolean is
9505       begin
9506          if Is_Access_Type (Etype (P)) then
9507             return not Is_Access_Constant (Root_Type (Etype (P)));
9508
9509          --  For the case of an indexed component whose prefix has a packed
9510          --  array type, the prefix has been rewritten into a type conversion.
9511          --  Determine variable-ness from the converted expression.
9512
9513          elsif Nkind (P) = N_Type_Conversion
9514            and then not Comes_From_Source (P)
9515            and then Is_Array_Type (Etype (P))
9516            and then Is_Packed (Etype (P))
9517          then
9518             return Is_Variable (Expression (P));
9519
9520          else
9521             return Is_Variable (P);
9522          end if;
9523       end Is_Variable_Prefix;
9524
9525    --  Start of processing for Is_Variable
9526
9527    begin
9528       --  Check if we perform the test on the original node since this may be a
9529       --  test of syntactic categories which must not be disturbed by whatever
9530       --  rewriting might have occurred. For example, an aggregate, which is
9531       --  certainly NOT a variable, could be turned into a variable by
9532       --  expansion.
9533
9534       if Use_Original_Node then
9535          Orig_Node := Original_Node (N);
9536       else
9537          Orig_Node := N;
9538       end if;
9539
9540       --  Definitely OK if Assignment_OK is set. Since this is something that
9541       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
9542
9543       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
9544          return True;
9545
9546       --  Normally we go to the original node, but there is one exception where
9547       --  we use the rewritten node, namely when it is an explicit dereference.
9548       --  The generated code may rewrite a prefix which is an access type with
9549       --  an explicit dereference. The dereference is a variable, even though
9550       --  the original node may not be (since it could be a constant of the
9551       --  access type).
9552
9553       --  In Ada 2005 we have a further case to consider: the prefix may be a
9554       --  function call given in prefix notation. The original node appears to
9555       --  be a selected component, but we need to examine the call.
9556
9557       elsif Nkind (N) = N_Explicit_Dereference
9558         and then Nkind (Orig_Node) /= N_Explicit_Dereference
9559         and then Present (Etype (Orig_Node))
9560         and then Is_Access_Type (Etype (Orig_Node))
9561       then
9562          --  Note that if the prefix is an explicit dereference that does not
9563          --  come from source, we must check for a rewritten function call in
9564          --  prefixed notation before other forms of rewriting, to prevent a
9565          --  compiler crash.
9566
9567          return
9568            (Nkind (Orig_Node) = N_Function_Call
9569              and then not Is_Access_Constant (Etype (Prefix (N))))
9570            or else
9571              Is_Variable_Prefix (Original_Node (Prefix (N)));
9572
9573       --  in Ada 2012, the dereference may have been added for a type with
9574       --  a declared implicit dereference aspect.
9575
9576       elsif Nkind (N) = N_Explicit_Dereference
9577         and then Present (Etype (Orig_Node))
9578         and then  Ada_Version >= Ada_2012
9579         and then Has_Implicit_Dereference (Etype (Orig_Node))
9580       then
9581          return True;
9582
9583       --  A function call is never a variable
9584
9585       elsif Nkind (N) = N_Function_Call then
9586          return False;
9587
9588       --  All remaining checks use the original node
9589
9590       elsif Is_Entity_Name (Orig_Node)
9591         and then Present (Entity (Orig_Node))
9592       then
9593          declare
9594             E : constant Entity_Id := Entity (Orig_Node);
9595             K : constant Entity_Kind := Ekind (E);
9596
9597          begin
9598             return (K = E_Variable
9599                       and then Nkind (Parent (E)) /= N_Exception_Handler)
9600               or else  (K = E_Component
9601                           and then not In_Protected_Function (E))
9602               or else  K = E_Out_Parameter
9603               or else  K = E_In_Out_Parameter
9604               or else  K = E_Generic_In_Out_Parameter
9605
9606                --  Current instance of type
9607
9608               or else (Is_Type (E) and then In_Open_Scopes (E))
9609               or else (Is_Incomplete_Or_Private_Type (E)
9610                         and then In_Open_Scopes (Full_View (E)));
9611          end;
9612
9613       else
9614          case Nkind (Orig_Node) is
9615             when N_Indexed_Component | N_Slice =>
9616                return Is_Variable_Prefix (Prefix (Orig_Node));
9617
9618             when N_Selected_Component =>
9619                return Is_Variable_Prefix (Prefix (Orig_Node))
9620                  and then Is_Variable (Selector_Name (Orig_Node));
9621
9622             --  For an explicit dereference, the type of the prefix cannot
9623             --  be an access to constant or an access to subprogram.
9624
9625             when N_Explicit_Dereference =>
9626                declare
9627                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
9628                begin
9629                   return Is_Access_Type (Typ)
9630                     and then not Is_Access_Constant (Root_Type (Typ))
9631                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
9632                end;
9633
9634             --  The type conversion is the case where we do not deal with the
9635             --  context dependent special case of an actual parameter. Thus
9636             --  the type conversion is only considered a variable for the
9637             --  purposes of this routine if the target type is tagged. However,
9638             --  a type conversion is considered to be a variable if it does not
9639             --  come from source (this deals for example with the conversions
9640             --  of expressions to their actual subtypes).
9641
9642             when N_Type_Conversion =>
9643                return Is_Variable (Expression (Orig_Node))
9644                  and then
9645                    (not Comes_From_Source (Orig_Node)
9646                       or else
9647                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
9648                           and then
9649                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
9650
9651             --  GNAT allows an unchecked type conversion as a variable. This
9652             --  only affects the generation of internal expanded code, since
9653             --  calls to instantiations of Unchecked_Conversion are never
9654             --  considered variables (since they are function calls).
9655
9656             when N_Unchecked_Type_Conversion =>
9657                return Is_Variable (Expression (Orig_Node));
9658
9659             when others =>
9660                return False;
9661          end case;
9662       end if;
9663    end Is_Variable;
9664
9665    ---------------------------
9666    -- Is_Visibly_Controlled --
9667    ---------------------------
9668
9669    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
9670       Root : constant Entity_Id := Root_Type (T);
9671    begin
9672       return Chars (Scope (Root)) = Name_Finalization
9673         and then Chars (Scope (Scope (Root))) = Name_Ada
9674         and then Scope (Scope (Scope (Root))) = Standard_Standard;
9675    end Is_Visibly_Controlled;
9676
9677    ------------------------
9678    -- Is_Volatile_Object --
9679    ------------------------
9680
9681    function Is_Volatile_Object (N : Node_Id) return Boolean is
9682
9683       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
9684       --  Determines if given object has volatile components
9685
9686       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
9687       --  If prefix is an implicit dereference, examine designated type
9688
9689       ------------------------
9690       -- Is_Volatile_Prefix --
9691       ------------------------
9692
9693       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
9694          Typ  : constant Entity_Id := Etype (N);
9695
9696       begin
9697          if Is_Access_Type (Typ) then
9698             declare
9699                Dtyp : constant Entity_Id := Designated_Type (Typ);
9700
9701             begin
9702                return Is_Volatile (Dtyp)
9703                  or else Has_Volatile_Components (Dtyp);
9704             end;
9705
9706          else
9707             return Object_Has_Volatile_Components (N);
9708          end if;
9709       end Is_Volatile_Prefix;
9710
9711       ------------------------------------
9712       -- Object_Has_Volatile_Components --
9713       ------------------------------------
9714
9715       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
9716          Typ : constant Entity_Id := Etype (N);
9717
9718       begin
9719          if Is_Volatile (Typ)
9720            or else Has_Volatile_Components (Typ)
9721          then
9722             return True;
9723
9724          elsif Is_Entity_Name (N)
9725            and then (Has_Volatile_Components (Entity (N))
9726                       or else Is_Volatile (Entity (N)))
9727          then
9728             return True;
9729
9730          elsif Nkind (N) = N_Indexed_Component
9731            or else Nkind (N) = N_Selected_Component
9732          then
9733             return Is_Volatile_Prefix (Prefix (N));
9734
9735          else
9736             return False;
9737          end if;
9738       end Object_Has_Volatile_Components;
9739
9740    --  Start of processing for Is_Volatile_Object
9741
9742    begin
9743       if Is_Volatile (Etype (N))
9744         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
9745       then
9746          return True;
9747
9748       elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
9749         and then Is_Volatile_Prefix (Prefix (N))
9750       then
9751          return True;
9752
9753       elsif Nkind (N) = N_Selected_Component
9754         and then Is_Volatile (Entity (Selector_Name (N)))
9755       then
9756          return True;
9757
9758       else
9759          return False;
9760       end if;
9761    end Is_Volatile_Object;
9762
9763    ---------------------------
9764    -- Itype_Has_Declaration --
9765    ---------------------------
9766
9767    function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
9768    begin
9769       pragma Assert (Is_Itype (Id));
9770       return Present (Parent (Id))
9771         and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
9772                                         N_Subtype_Declaration)
9773         and then Defining_Entity (Parent (Id)) = Id;
9774    end Itype_Has_Declaration;
9775
9776    -------------------------
9777    -- Kill_Current_Values --
9778    -------------------------
9779
9780    procedure Kill_Current_Values
9781      (Ent                  : Entity_Id;
9782       Last_Assignment_Only : Boolean := False)
9783    is
9784    begin
9785       --  ??? do we have to worry about clearing cached checks?
9786
9787       if Is_Assignable (Ent) then
9788          Set_Last_Assignment (Ent, Empty);
9789       end if;
9790
9791       if Is_Object (Ent) then
9792          if not Last_Assignment_Only then
9793             Kill_Checks (Ent);
9794             Set_Current_Value (Ent, Empty);
9795
9796             if not Can_Never_Be_Null (Ent) then
9797                Set_Is_Known_Non_Null (Ent, False);
9798             end if;
9799
9800             Set_Is_Known_Null (Ent, False);
9801
9802             --  Reset Is_Known_Valid unless type is always valid, or if we have
9803             --  a loop parameter (loop parameters are always valid, since their
9804             --  bounds are defined by the bounds given in the loop header).
9805
9806             if not Is_Known_Valid (Etype (Ent))
9807               and then Ekind (Ent) /= E_Loop_Parameter
9808             then
9809                Set_Is_Known_Valid (Ent, False);
9810             end if;
9811          end if;
9812       end if;
9813    end Kill_Current_Values;
9814
9815    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
9816       S : Entity_Id;
9817
9818       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
9819       --  Clear current value for entity E and all entities chained to E
9820
9821       ------------------------------------------
9822       -- Kill_Current_Values_For_Entity_Chain --
9823       ------------------------------------------
9824
9825       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
9826          Ent : Entity_Id;
9827       begin
9828          Ent := E;
9829          while Present (Ent) loop
9830             Kill_Current_Values (Ent, Last_Assignment_Only);
9831             Next_Entity (Ent);
9832          end loop;
9833       end Kill_Current_Values_For_Entity_Chain;
9834
9835    --  Start of processing for Kill_Current_Values
9836
9837    begin
9838       --  Kill all saved checks, a special case of killing saved values
9839
9840       if not Last_Assignment_Only then
9841          Kill_All_Checks;
9842       end if;
9843
9844       --  Loop through relevant scopes, which includes the current scope and
9845       --  any parent scopes if the current scope is a block or a package.
9846
9847       S := Current_Scope;
9848       Scope_Loop : loop
9849
9850          --  Clear current values of all entities in current scope
9851
9852          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
9853
9854          --  If scope is a package, also clear current values of all private
9855          --  entities in the scope.
9856
9857          if Is_Package_Or_Generic_Package (S)
9858            or else Is_Concurrent_Type (S)
9859          then
9860             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
9861          end if;
9862
9863          --  If this is a not a subprogram, deal with parents
9864
9865          if not Is_Subprogram (S) then
9866             S := Scope (S);
9867             exit Scope_Loop when S = Standard_Standard;
9868          else
9869             exit Scope_Loop;
9870          end if;
9871       end loop Scope_Loop;
9872    end Kill_Current_Values;
9873
9874    --------------------------
9875    -- Kill_Size_Check_Code --
9876    --------------------------
9877
9878    procedure Kill_Size_Check_Code (E : Entity_Id) is
9879    begin
9880       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
9881         and then Present (Size_Check_Code (E))
9882       then
9883          Remove (Size_Check_Code (E));
9884          Set_Size_Check_Code (E, Empty);
9885       end if;
9886    end Kill_Size_Check_Code;
9887
9888    --------------------------
9889    -- Known_To_Be_Assigned --
9890    --------------------------
9891
9892    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
9893       P : constant Node_Id := Parent (N);
9894
9895    begin
9896       case Nkind (P) is
9897
9898          --  Test left side of assignment
9899
9900          when N_Assignment_Statement =>
9901             return N = Name (P);
9902
9903             --  Function call arguments are never lvalues
9904
9905          when N_Function_Call =>
9906             return False;
9907
9908          --  Positional parameter for procedure or accept call
9909
9910          when N_Procedure_Call_Statement |
9911               N_Accept_Statement
9912           =>
9913             declare
9914                Proc : Entity_Id;
9915                Form : Entity_Id;
9916                Act  : Node_Id;
9917
9918             begin
9919                Proc := Get_Subprogram_Entity (P);
9920
9921                if No (Proc) then
9922                   return False;
9923                end if;
9924
9925                --  If we are not a list member, something is strange, so
9926                --  be conservative and return False.
9927
9928                if not Is_List_Member (N) then
9929                   return False;
9930                end if;
9931
9932                --  We are going to find the right formal by stepping forward
9933                --  through the formals, as we step backwards in the actuals.
9934
9935                Form := First_Formal (Proc);
9936                Act  := N;
9937                loop
9938                   --  If no formal, something is weird, so be conservative
9939                   --  and return False.
9940
9941                   if No (Form) then
9942                      return False;
9943                   end if;
9944
9945                   Prev (Act);
9946                   exit when No (Act);
9947                   Next_Formal (Form);
9948                end loop;
9949
9950                return Ekind (Form) /= E_In_Parameter;
9951             end;
9952
9953          --  Named parameter for procedure or accept call
9954
9955          when N_Parameter_Association =>
9956             declare
9957                Proc : Entity_Id;
9958                Form : Entity_Id;
9959
9960             begin
9961                Proc := Get_Subprogram_Entity (Parent (P));
9962
9963                if No (Proc) then
9964                   return False;
9965                end if;
9966
9967                --  Loop through formals to find the one that matches
9968
9969                Form := First_Formal (Proc);
9970                loop
9971                   --  If no matching formal, that's peculiar, some kind of
9972                   --  previous error, so return False to be conservative.
9973                   --  Actually this also happens in legal code in the case
9974                   --  where P is a parameter association for an Extra_Formal???
9975
9976                   if No (Form) then
9977                      return False;
9978                   end if;
9979
9980                   --  Else test for match
9981
9982                   if Chars (Form) = Chars (Selector_Name (P)) then
9983                      return Ekind (Form) /= E_In_Parameter;
9984                   end if;
9985
9986                   Next_Formal (Form);
9987                end loop;
9988             end;
9989
9990          --  Test for appearing in a conversion that itself appears
9991          --  in an lvalue context, since this should be an lvalue.
9992
9993          when N_Type_Conversion =>
9994             return Known_To_Be_Assigned (P);
9995
9996          --  All other references are definitely not known to be modifications
9997
9998          when others =>
9999             return False;
10000
10001       end case;
10002    end Known_To_Be_Assigned;
10003
10004    ---------------------------
10005    -- Last_Source_Statement --
10006    ---------------------------
10007
10008    function Last_Source_Statement (HSS : Node_Id) return Node_Id is
10009       N : Node_Id;
10010
10011    begin
10012       N := Last (Statements (HSS));
10013       while Present (N) loop
10014          exit when Comes_From_Source (N);
10015          Prev (N);
10016       end loop;
10017
10018       return N;
10019    end Last_Source_Statement;
10020
10021    ----------------------------------
10022    -- Matching_Static_Array_Bounds --
10023    ----------------------------------
10024
10025    function Matching_Static_Array_Bounds
10026      (L_Typ : Node_Id;
10027       R_Typ : Node_Id) return Boolean
10028    is
10029       L_Ndims : constant Nat := Number_Dimensions (L_Typ);
10030       R_Ndims : constant Nat := Number_Dimensions (R_Typ);
10031
10032       L_Index : Node_Id;
10033       R_Index : Node_Id;
10034       L_Low   : Node_Id;
10035       L_High  : Node_Id;
10036       L_Len   : Uint;
10037       R_Low   : Node_Id;
10038       R_High  : Node_Id;
10039       R_Len   : Uint;
10040
10041    begin
10042       if L_Ndims /= R_Ndims then
10043          return False;
10044       end if;
10045
10046       --  Unconstrained types do not have static bounds
10047
10048       if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
10049          return False;
10050       end if;
10051
10052       --  First treat specially the first dimension, as the lower bound and
10053       --  length of string literals are not stored like those of arrays.
10054
10055       if Ekind (L_Typ) = E_String_Literal_Subtype then
10056          L_Low := String_Literal_Low_Bound (L_Typ);
10057          L_Len := String_Literal_Length (L_Typ);
10058       else
10059          L_Index := First_Index (L_Typ);
10060          Get_Index_Bounds (L_Index, L_Low, L_High);
10061
10062          if         Is_OK_Static_Expression (L_Low)
10063            and then Is_OK_Static_Expression (L_High)
10064          then
10065             if Expr_Value (L_High) < Expr_Value (L_Low) then
10066                L_Len := Uint_0;
10067             else
10068                L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
10069             end if;
10070          else
10071             return False;
10072          end if;
10073       end if;
10074
10075       if Ekind (R_Typ) = E_String_Literal_Subtype then
10076          R_Low := String_Literal_Low_Bound (R_Typ);
10077          R_Len := String_Literal_Length (R_Typ);
10078       else
10079          R_Index := First_Index (R_Typ);
10080          Get_Index_Bounds (R_Index, R_Low, R_High);
10081
10082          if         Is_OK_Static_Expression (R_Low)
10083            and then Is_OK_Static_Expression (R_High)
10084          then
10085             if Expr_Value (R_High) < Expr_Value (R_Low) then
10086                R_Len := Uint_0;
10087             else
10088                R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
10089             end if;
10090          else
10091             return False;
10092          end if;
10093       end if;
10094
10095       if         Is_OK_Static_Expression (L_Low)
10096         and then Is_OK_Static_Expression (R_Low)
10097         and then Expr_Value (L_Low) = Expr_Value (R_Low)
10098         and then L_Len = R_Len
10099       then
10100          null;
10101       else
10102          return False;
10103       end if;
10104
10105       --  Then treat all other dimensions
10106
10107       for Indx in 2 .. L_Ndims loop
10108          Next (L_Index);
10109          Next (R_Index);
10110
10111          Get_Index_Bounds (L_Index, L_Low, L_High);
10112          Get_Index_Bounds (R_Index, R_Low, R_High);
10113
10114          if         Is_OK_Static_Expression (L_Low)
10115            and then Is_OK_Static_Expression (L_High)
10116            and then Is_OK_Static_Expression (R_Low)
10117            and then Is_OK_Static_Expression (R_High)
10118            and then Expr_Value (L_Low)  = Expr_Value (R_Low)
10119            and then Expr_Value (L_High) = Expr_Value (R_High)
10120          then
10121             null;
10122          else
10123             return False;
10124          end if;
10125       end loop;
10126
10127       --  If we fall through the loop, all indexes matched
10128
10129       return True;
10130    end Matching_Static_Array_Bounds;
10131
10132    -------------------
10133    -- May_Be_Lvalue --
10134    -------------------
10135
10136    function May_Be_Lvalue (N : Node_Id) return Boolean is
10137       P : constant Node_Id := Parent (N);
10138
10139    begin
10140       case Nkind (P) is
10141
10142          --  Test left side of assignment
10143
10144          when N_Assignment_Statement =>
10145             return N = Name (P);
10146
10147          --  Test prefix of component or attribute. Note that the prefix of an
10148          --  explicit or implicit dereference cannot be an l-value.
10149
10150          when N_Attribute_Reference =>
10151             return N = Prefix (P)
10152               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
10153
10154          --  For an expanded name, the name is an lvalue if the expanded name
10155          --  is an lvalue, but the prefix is never an lvalue, since it is just
10156          --  the scope where the name is found.
10157
10158          when N_Expanded_Name =>
10159             if N = Prefix (P) then
10160                return May_Be_Lvalue (P);
10161             else
10162                return False;
10163             end if;
10164
10165          --  For a selected component A.B, A is certainly an lvalue if A.B is.
10166          --  B is a little interesting, if we have A.B := 3, there is some
10167          --  discussion as to whether B is an lvalue or not, we choose to say
10168          --  it is. Note however that A is not an lvalue if it is of an access
10169          --  type since this is an implicit dereference.
10170
10171          when N_Selected_Component =>
10172             if N = Prefix (P)
10173               and then Present (Etype (N))
10174               and then Is_Access_Type (Etype (N))
10175             then
10176                return False;
10177             else
10178                return May_Be_Lvalue (P);
10179             end if;
10180
10181          --  For an indexed component or slice, the index or slice bounds is
10182          --  never an lvalue. The prefix is an lvalue if the indexed component
10183          --  or slice is an lvalue, except if it is an access type, where we
10184          --  have an implicit dereference.
10185
10186          when N_Indexed_Component | N_Slice =>
10187             if N /= Prefix (P)
10188               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
10189             then
10190                return False;
10191             else
10192                return May_Be_Lvalue (P);
10193             end if;
10194
10195          --  Prefix of a reference is an lvalue if the reference is an lvalue
10196
10197          when N_Reference =>
10198             return May_Be_Lvalue (P);
10199
10200          --  Prefix of explicit dereference is never an lvalue
10201
10202          when N_Explicit_Dereference =>
10203             return False;
10204
10205          --  Positional parameter for subprogram, entry, or accept call.
10206          --  In older versions of Ada function call arguments are never
10207          --  lvalues. In Ada 2012 functions can have in-out parameters.
10208
10209          when N_Subprogram_Call      |
10210               N_Entry_Call_Statement |
10211               N_Accept_Statement
10212          =>
10213             if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
10214                return False;
10215             end if;
10216
10217             --  The following mechanism is clumsy and fragile. A single flag
10218             --  set in Resolve_Actuals would be preferable ???
10219
10220             declare
10221                Proc : Entity_Id;
10222                Form : Entity_Id;
10223                Act  : Node_Id;
10224
10225             begin
10226                Proc := Get_Subprogram_Entity (P);
10227
10228                if No (Proc) then
10229                   return True;
10230                end if;
10231
10232                --  If we are not a list member, something is strange, so be
10233                --  conservative and return True.
10234
10235                if not Is_List_Member (N) then
10236                   return True;
10237                end if;
10238
10239                --  We are going to find the right formal by stepping forward
10240                --  through the formals, as we step backwards in the actuals.
10241
10242                Form := First_Formal (Proc);
10243                Act  := N;
10244                loop
10245                   --  If no formal, something is weird, so be conservative and
10246                   --  return True.
10247
10248                   if No (Form) then
10249                      return True;
10250                   end if;
10251
10252                   Prev (Act);
10253                   exit when No (Act);
10254                   Next_Formal (Form);
10255                end loop;
10256
10257                return Ekind (Form) /= E_In_Parameter;
10258             end;
10259
10260          --  Named parameter for procedure or accept call
10261
10262          when N_Parameter_Association =>
10263             declare
10264                Proc : Entity_Id;
10265                Form : Entity_Id;
10266
10267             begin
10268                Proc := Get_Subprogram_Entity (Parent (P));
10269
10270                if No (Proc) then
10271                   return True;
10272                end if;
10273
10274                --  Loop through formals to find the one that matches
10275
10276                Form := First_Formal (Proc);
10277                loop
10278                   --  If no matching formal, that's peculiar, some kind of
10279                   --  previous error, so return True to be conservative.
10280                   --  Actually happens with legal code for an unresolved call
10281                   --  where we may get the wrong homonym???
10282
10283                   if No (Form) then
10284                      return True;
10285                   end if;
10286
10287                   --  Else test for match
10288
10289                   if Chars (Form) = Chars (Selector_Name (P)) then
10290                      return Ekind (Form) /= E_In_Parameter;
10291                   end if;
10292
10293                   Next_Formal (Form);
10294                end loop;
10295             end;
10296
10297          --  Test for appearing in a conversion that itself appears in an
10298          --  lvalue context, since this should be an lvalue.
10299
10300          when N_Type_Conversion =>
10301             return May_Be_Lvalue (P);
10302
10303          --  Test for appearance in object renaming declaration
10304
10305          when N_Object_Renaming_Declaration =>
10306             return True;
10307
10308          --  All other references are definitely not lvalues
10309
10310          when others =>
10311             return False;
10312
10313       end case;
10314    end May_Be_Lvalue;
10315
10316    -----------------------
10317    -- Mark_Coextensions --
10318    -----------------------
10319
10320    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
10321       Is_Dynamic : Boolean;
10322       --  Indicates whether the context causes nested coextensions to be
10323       --  dynamic or static
10324
10325       function Mark_Allocator (N : Node_Id) return Traverse_Result;
10326       --  Recognize an allocator node and label it as a dynamic coextension
10327
10328       --------------------
10329       -- Mark_Allocator --
10330       --------------------
10331
10332       function Mark_Allocator (N : Node_Id) return Traverse_Result is
10333       begin
10334          if Nkind (N) = N_Allocator then
10335             if Is_Dynamic then
10336                Set_Is_Dynamic_Coextension (N);
10337
10338             --  If the allocator expression is potentially dynamic, it may
10339             --  be expanded out of order and require dynamic allocation
10340             --  anyway, so we treat the coextension itself as dynamic.
10341             --  Potential optimization ???
10342
10343             elsif Nkind (Expression (N)) = N_Qualified_Expression
10344               and then Nkind (Expression (Expression (N))) = N_Op_Concat
10345             then
10346                Set_Is_Dynamic_Coextension (N);
10347             else
10348                Set_Is_Static_Coextension (N);
10349             end if;
10350          end if;
10351
10352          return OK;
10353       end Mark_Allocator;
10354
10355       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
10356
10357    --  Start of processing Mark_Coextensions
10358
10359    begin
10360       case Nkind (Context_Nod) is
10361
10362          --  Comment here ???
10363
10364          when N_Assignment_Statement    =>
10365             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
10366
10367          --  An allocator that is a component of a returned aggregate
10368          --  must be dynamic.
10369
10370          when N_Simple_Return_Statement =>
10371             declare
10372                Expr : constant Node_Id := Expression (Context_Nod);
10373             begin
10374                Is_Dynamic :=
10375                  Nkind (Expr) = N_Allocator
10376                    or else
10377                      (Nkind (Expr) = N_Qualified_Expression
10378                        and then Nkind (Expression (Expr)) = N_Aggregate);
10379             end;
10380
10381          --  An alloctor within an object declaration in an extended return
10382          --  statement is of necessity dynamic.
10383
10384          when N_Object_Declaration =>
10385             Is_Dynamic := Nkind (Root_Nod) = N_Allocator
10386               or else
10387                 Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
10388
10389          --  This routine should not be called for constructs which may not
10390          --  contain coextensions.
10391
10392          when others =>
10393             raise Program_Error;
10394       end case;
10395
10396       Mark_Allocators (Root_Nod);
10397    end Mark_Coextensions;
10398
10399    -----------------
10400    -- Must_Inline --
10401    -----------------
10402
10403    function Must_Inline (Subp : Entity_Id) return Boolean is
10404    begin
10405       return
10406         (Optimization_Level = 0
10407
10408           --  AAMP and VM targets have no support for inlining in the backend.
10409           --  Hence we do as much inlining as possible in the front end.
10410
10411           or else AAMP_On_Target
10412           or else VM_Target /= No_VM)
10413         and then Has_Pragma_Inline (Subp)
10414         and then (Has_Pragma_Inline_Always (Subp) or else Front_End_Inlining);
10415    end Must_Inline;
10416
10417    ----------------------
10418    -- Needs_One_Actual --
10419    ----------------------
10420
10421    function Needs_One_Actual (E : Entity_Id) return Boolean is
10422       Formal : Entity_Id;
10423
10424    begin
10425       --  Ada 2005 or later, and formals present
10426
10427       if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
10428          Formal := Next_Formal (First_Formal (E));
10429          while Present (Formal) loop
10430             if No (Default_Value (Formal)) then
10431                return False;
10432             end if;
10433
10434             Next_Formal (Formal);
10435          end loop;
10436
10437          return True;
10438
10439       --  Ada 83/95 or no formals
10440
10441       else
10442          return False;
10443       end if;
10444    end Needs_One_Actual;
10445
10446    ------------------------
10447    -- New_Copy_List_Tree --
10448    ------------------------
10449
10450    function New_Copy_List_Tree (List : List_Id) return List_Id is
10451       NL : List_Id;
10452       E  : Node_Id;
10453
10454    begin
10455       if List = No_List then
10456          return No_List;
10457
10458       else
10459          NL := New_List;
10460          E := First (List);
10461
10462          while Present (E) loop
10463             Append (New_Copy_Tree (E), NL);
10464             E := Next (E);
10465          end loop;
10466
10467          return NL;
10468       end if;
10469    end New_Copy_List_Tree;
10470
10471    -------------------
10472    -- New_Copy_Tree --
10473    -------------------
10474
10475    use Atree.Unchecked_Access;
10476    use Atree_Private_Part;
10477
10478    --  Our approach here requires a two pass traversal of the tree. The
10479    --  first pass visits all nodes that eventually will be copied looking
10480    --  for defining Itypes. If any defining Itypes are found, then they are
10481    --  copied, and an entry is added to the replacement map. In the second
10482    --  phase, the tree is copied, using the replacement map to replace any
10483    --  Itype references within the copied tree.
10484
10485    --  The following hash tables are used if the Map supplied has more
10486    --  than hash threshold entries to speed up access to the map. If
10487    --  there are fewer entries, then the map is searched sequentially
10488    --  (because setting up a hash table for only a few entries takes
10489    --  more time than it saves.
10490
10491    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
10492    --  Hash function used for hash operations
10493
10494    -------------------
10495    -- New_Copy_Hash --
10496    -------------------
10497
10498    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
10499    begin
10500       return Nat (E) mod (NCT_Header_Num'Last + 1);
10501    end New_Copy_Hash;
10502
10503    ---------------
10504    -- NCT_Assoc --
10505    ---------------
10506
10507    --  The hash table NCT_Assoc associates old entities in the table
10508    --  with their corresponding new entities (i.e. the pairs of entries
10509    --  presented in the original Map argument are Key-Element pairs).
10510
10511    package NCT_Assoc is new Simple_HTable (
10512      Header_Num => NCT_Header_Num,
10513      Element    => Entity_Id,
10514      No_Element => Empty,
10515      Key        => Entity_Id,
10516      Hash       => New_Copy_Hash,
10517      Equal      => Types."=");
10518
10519    ---------------------
10520    -- NCT_Itype_Assoc --
10521    ---------------------
10522
10523    --  The hash table NCT_Itype_Assoc contains entries only for those
10524    --  old nodes which have a non-empty Associated_Node_For_Itype set.
10525    --  The key is the associated node, and the element is the new node
10526    --  itself (NOT the associated node for the new node).
10527
10528    package NCT_Itype_Assoc is new Simple_HTable (
10529      Header_Num => NCT_Header_Num,
10530      Element    => Entity_Id,
10531      No_Element => Empty,
10532      Key        => Entity_Id,
10533      Hash       => New_Copy_Hash,
10534      Equal      => Types."=");
10535
10536    --  Start of processing for New_Copy_Tree function
10537
10538    function New_Copy_Tree
10539      (Source    : Node_Id;
10540       Map       : Elist_Id := No_Elist;
10541       New_Sloc  : Source_Ptr := No_Location;
10542       New_Scope : Entity_Id := Empty) return Node_Id
10543    is
10544       Actual_Map : Elist_Id := Map;
10545       --  This is the actual map for the copy. It is initialized with the
10546       --  given elements, and then enlarged as required for Itypes that are
10547       --  copied during the first phase of the copy operation. The visit
10548       --  procedures add elements to this map as Itypes are encountered.
10549       --  The reason we cannot use Map directly, is that it may well be
10550       --  (and normally is) initialized to No_Elist, and if we have mapped
10551       --  entities, we have to reset it to point to a real Elist.
10552
10553       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
10554       --  Called during second phase to map entities into their corresponding
10555       --  copies using Actual_Map. If the argument is not an entity, or is not
10556       --  in Actual_Map, then it is returned unchanged.
10557
10558       procedure Build_NCT_Hash_Tables;
10559       --  Builds hash tables (number of elements >= threshold value)
10560
10561       function Copy_Elist_With_Replacement
10562         (Old_Elist : Elist_Id) return Elist_Id;
10563       --  Called during second phase to copy element list doing replacements
10564
10565       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
10566       --  Called during the second phase to process a copied Itype. The actual
10567       --  copy happened during the first phase (so that we could make the entry
10568       --  in the mapping), but we still have to deal with the descendents of
10569       --  the copied Itype and copy them where necessary.
10570
10571       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
10572       --  Called during second phase to copy list doing replacements
10573
10574       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
10575       --  Called during second phase to copy node doing replacements
10576
10577       procedure Visit_Elist (E : Elist_Id);
10578       --  Called during first phase to visit all elements of an Elist
10579
10580       procedure Visit_Field (F : Union_Id; N : Node_Id);
10581       --  Visit a single field, recursing to call Visit_Node or Visit_List
10582       --  if the field is a syntactic descendent of the current node (i.e.
10583       --  its parent is Node N).
10584
10585       procedure Visit_Itype (Old_Itype : Entity_Id);
10586       --  Called during first phase to visit subsidiary fields of a defining
10587       --  Itype, and also create a copy and make an entry in the replacement
10588       --  map for the new copy.
10589
10590       procedure Visit_List (L : List_Id);
10591       --  Called during first phase to visit all elements of a List
10592
10593       procedure Visit_Node (N : Node_Or_Entity_Id);
10594       --  Called during first phase to visit a node and all its subtrees
10595
10596       -----------
10597       -- Assoc --
10598       -----------
10599
10600       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
10601          E   : Elmt_Id;
10602          Ent : Entity_Id;
10603
10604       begin
10605          if not Has_Extension (N) or else No (Actual_Map) then
10606             return N;
10607
10608          elsif NCT_Hash_Tables_Used then
10609             Ent := NCT_Assoc.Get (Entity_Id (N));
10610
10611             if Present (Ent) then
10612                return Ent;
10613             else
10614                return N;
10615             end if;
10616
10617          --  No hash table used, do serial search
10618
10619          else
10620             E := First_Elmt (Actual_Map);
10621             while Present (E) loop
10622                if Node (E) = N then
10623                   return Node (Next_Elmt (E));
10624                else
10625                   E := Next_Elmt (Next_Elmt (E));
10626                end if;
10627             end loop;
10628          end if;
10629
10630          return N;
10631       end Assoc;
10632
10633       ---------------------------
10634       -- Build_NCT_Hash_Tables --
10635       ---------------------------
10636
10637       procedure Build_NCT_Hash_Tables is
10638          Elmt : Elmt_Id;
10639          Ent  : Entity_Id;
10640       begin
10641          if NCT_Hash_Table_Setup then
10642             NCT_Assoc.Reset;
10643             NCT_Itype_Assoc.Reset;
10644          end if;
10645
10646          Elmt := First_Elmt (Actual_Map);
10647          while Present (Elmt) loop
10648             Ent := Node (Elmt);
10649
10650             --  Get new entity, and associate old and new
10651
10652             Next_Elmt (Elmt);
10653             NCT_Assoc.Set (Ent, Node (Elmt));
10654
10655             if Is_Type (Ent) then
10656                declare
10657                   Anode : constant Entity_Id :=
10658                             Associated_Node_For_Itype (Ent);
10659
10660                begin
10661                   if Present (Anode) then
10662
10663                      --  Enter a link between the associated node of the
10664                      --  old Itype and the new Itype, for updating later
10665                      --  when node is copied.
10666
10667                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
10668                   end if;
10669                end;
10670             end if;
10671
10672             Next_Elmt (Elmt);
10673          end loop;
10674
10675          NCT_Hash_Tables_Used := True;
10676          NCT_Hash_Table_Setup := True;
10677       end Build_NCT_Hash_Tables;
10678
10679       ---------------------------------
10680       -- Copy_Elist_With_Replacement --
10681       ---------------------------------
10682
10683       function Copy_Elist_With_Replacement
10684         (Old_Elist : Elist_Id) return Elist_Id
10685       is
10686          M         : Elmt_Id;
10687          New_Elist : Elist_Id;
10688
10689       begin
10690          if No (Old_Elist) then
10691             return No_Elist;
10692
10693          else
10694             New_Elist := New_Elmt_List;
10695
10696             M := First_Elmt (Old_Elist);
10697             while Present (M) loop
10698                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
10699                Next_Elmt (M);
10700             end loop;
10701          end if;
10702
10703          return New_Elist;
10704       end Copy_Elist_With_Replacement;
10705
10706       ---------------------------------
10707       -- Copy_Itype_With_Replacement --
10708       ---------------------------------
10709
10710       --  This routine exactly parallels its phase one analog Visit_Itype,
10711
10712       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
10713       begin
10714          --  Translate Next_Entity, Scope and Etype fields, in case they
10715          --  reference entities that have been mapped into copies.
10716
10717          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
10718          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
10719
10720          if Present (New_Scope) then
10721             Set_Scope    (New_Itype, New_Scope);
10722          else
10723             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
10724          end if;
10725
10726          --  Copy referenced fields
10727
10728          if Is_Discrete_Type (New_Itype) then
10729             Set_Scalar_Range (New_Itype,
10730               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
10731
10732          elsif Has_Discriminants (Base_Type (New_Itype)) then
10733             Set_Discriminant_Constraint (New_Itype,
10734               Copy_Elist_With_Replacement
10735                 (Discriminant_Constraint (New_Itype)));
10736
10737          elsif Is_Array_Type (New_Itype) then
10738             if Present (First_Index (New_Itype)) then
10739                Set_First_Index (New_Itype,
10740                  First (Copy_List_With_Replacement
10741                          (List_Containing (First_Index (New_Itype)))));
10742             end if;
10743
10744             if Is_Packed (New_Itype) then
10745                Set_Packed_Array_Type (New_Itype,
10746                  Copy_Node_With_Replacement
10747                    (Packed_Array_Type (New_Itype)));
10748             end if;
10749          end if;
10750       end Copy_Itype_With_Replacement;
10751
10752       --------------------------------
10753       -- Copy_List_With_Replacement --
10754       --------------------------------
10755
10756       function Copy_List_With_Replacement
10757         (Old_List : List_Id) return List_Id
10758       is
10759          New_List : List_Id;
10760          E        : Node_Id;
10761
10762       begin
10763          if Old_List = No_List then
10764             return No_List;
10765
10766          else
10767             New_List := Empty_List;
10768
10769             E := First (Old_List);
10770             while Present (E) loop
10771                Append (Copy_Node_With_Replacement (E), New_List);
10772                Next (E);
10773             end loop;
10774
10775             return New_List;
10776          end if;
10777       end Copy_List_With_Replacement;
10778
10779       --------------------------------
10780       -- Copy_Node_With_Replacement --
10781       --------------------------------
10782
10783       function Copy_Node_With_Replacement
10784         (Old_Node : Node_Id) return Node_Id
10785       is
10786          New_Node : Node_Id;
10787
10788          procedure Adjust_Named_Associations
10789            (Old_Node : Node_Id;
10790             New_Node : Node_Id);
10791          --  If a call node has named associations, these are chained through
10792          --  the First_Named_Actual, Next_Named_Actual links. These must be
10793          --  propagated separately to the new parameter list, because these
10794          --  are not syntactic fields.
10795
10796          function Copy_Field_With_Replacement
10797            (Field : Union_Id) return Union_Id;
10798          --  Given Field, which is a field of Old_Node, return a copy of it
10799          --  if it is a syntactic field (i.e. its parent is Node), setting
10800          --  the parent of the copy to poit to New_Node. Otherwise returns
10801          --  the field (possibly mapped if it is an entity).
10802
10803          -------------------------------
10804          -- Adjust_Named_Associations --
10805          -------------------------------
10806
10807          procedure Adjust_Named_Associations
10808            (Old_Node : Node_Id;
10809             New_Node : Node_Id)
10810          is
10811             Old_E : Node_Id;
10812             New_E : Node_Id;
10813
10814             Old_Next : Node_Id;
10815             New_Next : Node_Id;
10816
10817          begin
10818             Old_E := First (Parameter_Associations (Old_Node));
10819             New_E := First (Parameter_Associations (New_Node));
10820             while Present (Old_E) loop
10821                if Nkind (Old_E) = N_Parameter_Association
10822                  and then Present (Next_Named_Actual (Old_E))
10823                then
10824                   if First_Named_Actual (Old_Node)
10825                     =  Explicit_Actual_Parameter (Old_E)
10826                   then
10827                      Set_First_Named_Actual
10828                        (New_Node, Explicit_Actual_Parameter (New_E));
10829                   end if;
10830
10831                   --  Now scan parameter list from the beginning,to locate
10832                   --  next named actual, which can be out of order.
10833
10834                   Old_Next := First (Parameter_Associations (Old_Node));
10835                   New_Next := First (Parameter_Associations (New_Node));
10836
10837                   while Nkind (Old_Next) /= N_Parameter_Association
10838                     or else  Explicit_Actual_Parameter (Old_Next)
10839                       /= Next_Named_Actual (Old_E)
10840                   loop
10841                      Next (Old_Next);
10842                      Next (New_Next);
10843                   end loop;
10844
10845                   Set_Next_Named_Actual
10846                     (New_E, Explicit_Actual_Parameter (New_Next));
10847                end if;
10848
10849                Next (Old_E);
10850                Next (New_E);
10851             end loop;
10852          end Adjust_Named_Associations;
10853
10854          ---------------------------------
10855          -- Copy_Field_With_Replacement --
10856          ---------------------------------
10857
10858          function Copy_Field_With_Replacement
10859            (Field : Union_Id) return Union_Id
10860          is
10861          begin
10862             if Field = Union_Id (Empty) then
10863                return Field;
10864
10865             elsif Field in Node_Range then
10866                declare
10867                   Old_N : constant Node_Id := Node_Id (Field);
10868                   New_N : Node_Id;
10869
10870                begin
10871                   --  If syntactic field, as indicated by the parent pointer
10872                   --  being set, then copy the referenced node recursively.
10873
10874                   if Parent (Old_N) = Old_Node then
10875                      New_N := Copy_Node_With_Replacement (Old_N);
10876
10877                      if New_N /= Old_N then
10878                         Set_Parent (New_N, New_Node);
10879                      end if;
10880
10881                   --  For semantic fields, update possible entity reference
10882                   --  from the replacement map.
10883
10884                   else
10885                      New_N := Assoc (Old_N);
10886                   end if;
10887
10888                   return Union_Id (New_N);
10889                end;
10890
10891             elsif Field in List_Range then
10892                declare
10893                   Old_L : constant List_Id := List_Id (Field);
10894                   New_L : List_Id;
10895
10896                begin
10897                   --  If syntactic field, as indicated by the parent pointer,
10898                   --  then recursively copy the entire referenced list.
10899
10900                   if Parent (Old_L) = Old_Node then
10901                      New_L := Copy_List_With_Replacement (Old_L);
10902                      Set_Parent (New_L, New_Node);
10903
10904                   --  For semantic list, just returned unchanged
10905
10906                   else
10907                      New_L := Old_L;
10908                   end if;
10909
10910                   return Union_Id (New_L);
10911                end;
10912
10913             --  Anything other than a list or a node is returned unchanged
10914
10915             else
10916                return Field;
10917             end if;
10918          end Copy_Field_With_Replacement;
10919
10920       --  Start of processing for Copy_Node_With_Replacement
10921
10922       begin
10923          if Old_Node <= Empty_Or_Error then
10924             return Old_Node;
10925
10926          elsif Has_Extension (Old_Node) then
10927             return Assoc (Old_Node);
10928
10929          else
10930             New_Node := New_Copy (Old_Node);
10931
10932             --  If the node we are copying is the associated node of a
10933             --  previously copied Itype, then adjust the associated node
10934             --  of the copy of that Itype accordingly.
10935
10936             if Present (Actual_Map) then
10937                declare
10938                   E   : Elmt_Id;
10939                   Ent : Entity_Id;
10940
10941                begin
10942                   --  Case of hash table used
10943
10944                   if NCT_Hash_Tables_Used then
10945                      Ent := NCT_Itype_Assoc.Get (Old_Node);
10946
10947                      if Present (Ent) then
10948                         Set_Associated_Node_For_Itype (Ent, New_Node);
10949                      end if;
10950
10951                   --  Case of no hash table used
10952
10953                   else
10954                      E := First_Elmt (Actual_Map);
10955                      while Present (E) loop
10956                         if Is_Itype (Node (E))
10957                           and then
10958                             Old_Node = Associated_Node_For_Itype (Node (E))
10959                         then
10960                            Set_Associated_Node_For_Itype
10961                              (Node (Next_Elmt (E)), New_Node);
10962                         end if;
10963
10964                         E := Next_Elmt (Next_Elmt (E));
10965                      end loop;
10966                   end if;
10967                end;
10968             end if;
10969
10970             --  Recursively copy descendents
10971
10972             Set_Field1
10973               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
10974             Set_Field2
10975               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
10976             Set_Field3
10977               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
10978             Set_Field4
10979               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
10980             Set_Field5
10981               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
10982
10983             --  Adjust Sloc of new node if necessary
10984
10985             if New_Sloc /= No_Location then
10986                Set_Sloc (New_Node, New_Sloc);
10987
10988                --  If we adjust the Sloc, then we are essentially making
10989                --  a completely new node, so the Comes_From_Source flag
10990                --  should be reset to the proper default value.
10991
10992                Nodes.Table (New_Node).Comes_From_Source :=
10993                  Default_Node.Comes_From_Source;
10994             end if;
10995
10996             --  If the node is call and has named associations,
10997             --  set the corresponding links in the copy.
10998
10999             if (Nkind (Old_Node) = N_Function_Call
11000                  or else Nkind (Old_Node) = N_Entry_Call_Statement
11001                  or else
11002                    Nkind (Old_Node) = N_Procedure_Call_Statement)
11003               and then Present (First_Named_Actual (Old_Node))
11004             then
11005                Adjust_Named_Associations (Old_Node, New_Node);
11006             end if;
11007
11008             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
11009             --  The replacement mechanism applies to entities, and is not used
11010             --  here. Eventually we may need a more general graph-copying
11011             --  routine. For now, do a sequential search to find desired node.
11012
11013             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
11014               and then Present (First_Real_Statement (Old_Node))
11015             then
11016                declare
11017                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
11018                   N1, N2 : Node_Id;
11019
11020                begin
11021                   N1 := First (Statements (Old_Node));
11022                   N2 := First (Statements (New_Node));
11023
11024                   while N1 /= Old_F loop
11025                      Next (N1);
11026                      Next (N2);
11027                   end loop;
11028
11029                   Set_First_Real_Statement (New_Node, N2);
11030                end;
11031             end if;
11032          end if;
11033
11034          --  All done, return copied node
11035
11036          return New_Node;
11037       end Copy_Node_With_Replacement;
11038
11039       -----------------
11040       -- Visit_Elist --
11041       -----------------
11042
11043       procedure Visit_Elist (E : Elist_Id) is
11044          Elmt : Elmt_Id;
11045       begin
11046          if Present (E) then
11047             Elmt := First_Elmt (E);
11048
11049             while Elmt /= No_Elmt loop
11050                Visit_Node (Node (Elmt));
11051                Next_Elmt (Elmt);
11052             end loop;
11053          end if;
11054       end Visit_Elist;
11055
11056       -----------------
11057       -- Visit_Field --
11058       -----------------
11059
11060       procedure Visit_Field (F : Union_Id; N : Node_Id) is
11061       begin
11062          if F = Union_Id (Empty) then
11063             return;
11064
11065          elsif F in Node_Range then
11066
11067             --  Copy node if it is syntactic, i.e. its parent pointer is
11068             --  set to point to the field that referenced it (certain
11069             --  Itypes will also meet this criterion, which is fine, since
11070             --  these are clearly Itypes that do need to be copied, since
11071             --  we are copying their parent.)
11072
11073             if Parent (Node_Id (F)) = N then
11074                Visit_Node (Node_Id (F));
11075                return;
11076
11077             --  Another case, if we are pointing to an Itype, then we want
11078             --  to copy it if its associated node is somewhere in the tree
11079             --  being copied.
11080
11081             --  Note: the exclusion of self-referential copies is just an
11082             --  optimization, since the search of the already copied list
11083             --  would catch it, but it is a common case (Etype pointing
11084             --  to itself for an Itype that is a base type).
11085
11086             elsif Has_Extension (Node_Id (F))
11087               and then Is_Itype (Entity_Id (F))
11088               and then Node_Id (F) /= N
11089             then
11090                declare
11091                   P : Node_Id;
11092
11093                begin
11094                   P := Associated_Node_For_Itype (Node_Id (F));
11095                   while Present (P) loop
11096                      if P = Source then
11097                         Visit_Node (Node_Id (F));
11098                         return;
11099                      else
11100                         P := Parent (P);
11101                      end if;
11102                   end loop;
11103
11104                   --  An Itype whose parent is not being copied definitely
11105                   --  should NOT be copied, since it does not belong in any
11106                   --  sense to the copied subtree.
11107
11108                   return;
11109                end;
11110             end if;
11111
11112          elsif F in List_Range
11113            and then Parent (List_Id (F)) = N
11114          then
11115             Visit_List (List_Id (F));
11116             return;
11117          end if;
11118       end Visit_Field;
11119
11120       -----------------
11121       -- Visit_Itype --
11122       -----------------
11123
11124       procedure Visit_Itype (Old_Itype : Entity_Id) is
11125          New_Itype : Entity_Id;
11126          E         : Elmt_Id;
11127          Ent       : Entity_Id;
11128
11129       begin
11130          --  Itypes that describe the designated type of access to subprograms
11131          --  have the structure of subprogram declarations, with signatures,
11132          --  etc. Either we duplicate the signatures completely, or choose to
11133          --  share such itypes, which is fine because their elaboration will
11134          --  have no side effects.
11135
11136          if Ekind (Old_Itype) = E_Subprogram_Type then
11137             return;
11138          end if;
11139
11140          New_Itype := New_Copy (Old_Itype);
11141
11142          --  The new Itype has all the attributes of the old one, and
11143          --  we just copy the contents of the entity. However, the back-end
11144          --  needs different names for debugging purposes, so we create a
11145          --  new internal name for it in all cases.
11146
11147          Set_Chars (New_Itype, New_Internal_Name ('T'));
11148
11149          --  If our associated node is an entity that has already been copied,
11150          --  then set the associated node of the copy to point to the right
11151          --  copy. If we have copied an Itype that is itself the associated
11152          --  node of some previously copied Itype, then we set the right
11153          --  pointer in the other direction.
11154
11155          if Present (Actual_Map) then
11156
11157             --  Case of hash tables used
11158
11159             if NCT_Hash_Tables_Used then
11160
11161                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
11162
11163                if Present (Ent) then
11164                   Set_Associated_Node_For_Itype (New_Itype, Ent);
11165                end if;
11166
11167                Ent := NCT_Itype_Assoc.Get (Old_Itype);
11168                if Present (Ent) then
11169                   Set_Associated_Node_For_Itype (Ent, New_Itype);
11170
11171                --  If the hash table has no association for this Itype and
11172                --  its associated node, enter one now.
11173
11174                else
11175                   NCT_Itype_Assoc.Set
11176                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
11177                end if;
11178
11179             --  Case of hash tables not used
11180
11181             else
11182                E := First_Elmt (Actual_Map);
11183                while Present (E) loop
11184                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
11185                      Set_Associated_Node_For_Itype
11186                        (New_Itype, Node (Next_Elmt (E)));
11187                   end if;
11188
11189                   if Is_Type (Node (E))
11190                     and then
11191                       Old_Itype = Associated_Node_For_Itype (Node (E))
11192                   then
11193                      Set_Associated_Node_For_Itype
11194                        (Node (Next_Elmt (E)), New_Itype);
11195                   end if;
11196
11197                   E := Next_Elmt (Next_Elmt (E));
11198                end loop;
11199             end if;
11200          end if;
11201
11202          if Present (Freeze_Node (New_Itype)) then
11203             Set_Is_Frozen (New_Itype, False);
11204             Set_Freeze_Node (New_Itype, Empty);
11205          end if;
11206
11207          --  Add new association to map
11208
11209          if No (Actual_Map) then
11210             Actual_Map := New_Elmt_List;
11211          end if;
11212
11213          Append_Elmt (Old_Itype, Actual_Map);
11214          Append_Elmt (New_Itype, Actual_Map);
11215
11216          if NCT_Hash_Tables_Used then
11217             NCT_Assoc.Set (Old_Itype, New_Itype);
11218
11219          else
11220             NCT_Table_Entries := NCT_Table_Entries + 1;
11221
11222             if NCT_Table_Entries > NCT_Hash_Threshold then
11223                Build_NCT_Hash_Tables;
11224             end if;
11225          end if;
11226
11227          --  If a record subtype is simply copied, the entity list will be
11228          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
11229
11230          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
11231             Set_Cloned_Subtype (New_Itype, Old_Itype);
11232          end if;
11233
11234          --  Visit descendents that eventually get copied
11235
11236          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
11237
11238          if Is_Discrete_Type (Old_Itype) then
11239             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
11240
11241          elsif Has_Discriminants (Base_Type (Old_Itype)) then
11242             --  ??? This should involve call to Visit_Field
11243             Visit_Elist (Discriminant_Constraint (Old_Itype));
11244
11245          elsif Is_Array_Type (Old_Itype) then
11246             if Present (First_Index (Old_Itype)) then
11247                Visit_Field (Union_Id (List_Containing
11248                                 (First_Index (Old_Itype))),
11249                             Old_Itype);
11250             end if;
11251
11252             if Is_Packed (Old_Itype) then
11253                Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
11254                             Old_Itype);
11255             end if;
11256          end if;
11257       end Visit_Itype;
11258
11259       ----------------
11260       -- Visit_List --
11261       ----------------
11262
11263       procedure Visit_List (L : List_Id) is
11264          N : Node_Id;
11265       begin
11266          if L /= No_List then
11267             N := First (L);
11268
11269             while Present (N) loop
11270                Visit_Node (N);
11271                Next (N);
11272             end loop;
11273          end if;
11274       end Visit_List;
11275
11276       ----------------
11277       -- Visit_Node --
11278       ----------------
11279
11280       procedure Visit_Node (N : Node_Or_Entity_Id) is
11281
11282       --  Start of processing for Visit_Node
11283
11284       begin
11285          --  Handle case of an Itype, which must be copied
11286
11287          if Has_Extension (N)
11288            and then Is_Itype (N)
11289          then
11290             --  Nothing to do if already in the list. This can happen with an
11291             --  Itype entity that appears more than once in the tree.
11292             --  Note that we do not want to visit descendents in this case.
11293
11294             --  Test for already in list when hash table is used
11295
11296             if NCT_Hash_Tables_Used then
11297                if Present (NCT_Assoc.Get (Entity_Id (N))) then
11298                   return;
11299                end if;
11300
11301             --  Test for already in list when hash table not used
11302
11303             else
11304                declare
11305                   E : Elmt_Id;
11306                begin
11307                   if Present (Actual_Map) then
11308                      E := First_Elmt (Actual_Map);
11309                      while Present (E) loop
11310                         if Node (E) = N then
11311                            return;
11312                         else
11313                            E := Next_Elmt (Next_Elmt (E));
11314                         end if;
11315                      end loop;
11316                   end if;
11317                end;
11318             end if;
11319
11320             Visit_Itype (N);
11321          end if;
11322
11323          --  Visit descendents
11324
11325          Visit_Field (Field1 (N), N);
11326          Visit_Field (Field2 (N), N);
11327          Visit_Field (Field3 (N), N);
11328          Visit_Field (Field4 (N), N);
11329          Visit_Field (Field5 (N), N);
11330       end Visit_Node;
11331
11332    --  Start of processing for New_Copy_Tree
11333
11334    begin
11335       Actual_Map := Map;
11336
11337       --  See if we should use hash table
11338
11339       if No (Actual_Map) then
11340          NCT_Hash_Tables_Used := False;
11341
11342       else
11343          declare
11344             Elmt : Elmt_Id;
11345
11346          begin
11347             NCT_Table_Entries := 0;
11348
11349             Elmt := First_Elmt (Actual_Map);
11350             while Present (Elmt) loop
11351                NCT_Table_Entries := NCT_Table_Entries + 1;
11352                Next_Elmt (Elmt);
11353                Next_Elmt (Elmt);
11354             end loop;
11355
11356             if NCT_Table_Entries > NCT_Hash_Threshold then
11357                Build_NCT_Hash_Tables;
11358             else
11359                NCT_Hash_Tables_Used := False;
11360             end if;
11361          end;
11362       end if;
11363
11364       --  Hash table set up if required, now start phase one by visiting
11365       --  top node (we will recursively visit the descendents).
11366
11367       Visit_Node (Source);
11368
11369       --  Now the second phase of the copy can start. First we process
11370       --  all the mapped entities, copying their descendents.
11371
11372       if Present (Actual_Map) then
11373          declare
11374             Elmt      : Elmt_Id;
11375             New_Itype : Entity_Id;
11376          begin
11377             Elmt := First_Elmt (Actual_Map);
11378             while Present (Elmt) loop
11379                Next_Elmt (Elmt);
11380                New_Itype := Node (Elmt);
11381                Copy_Itype_With_Replacement (New_Itype);
11382                Next_Elmt (Elmt);
11383             end loop;
11384          end;
11385       end if;
11386
11387       --  Now we can copy the actual tree
11388
11389       return Copy_Node_With_Replacement (Source);
11390    end New_Copy_Tree;
11391
11392    -------------------------
11393    -- New_External_Entity --
11394    -------------------------
11395
11396    function New_External_Entity
11397      (Kind         : Entity_Kind;
11398       Scope_Id     : Entity_Id;
11399       Sloc_Value   : Source_Ptr;
11400       Related_Id   : Entity_Id;
11401       Suffix       : Character;
11402       Suffix_Index : Nat := 0;
11403       Prefix       : Character := ' ') return Entity_Id
11404    is
11405       N : constant Entity_Id :=
11406             Make_Defining_Identifier (Sloc_Value,
11407               New_External_Name
11408                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
11409
11410    begin
11411       Set_Ekind          (N, Kind);
11412       Set_Is_Internal    (N, True);
11413       Append_Entity      (N, Scope_Id);
11414       Set_Public_Status  (N);
11415
11416       if Kind in Type_Kind then
11417          Init_Size_Align (N);
11418       end if;
11419
11420       return N;
11421    end New_External_Entity;
11422
11423    -------------------------
11424    -- New_Internal_Entity --
11425    -------------------------
11426
11427    function New_Internal_Entity
11428      (Kind       : Entity_Kind;
11429       Scope_Id   : Entity_Id;
11430       Sloc_Value : Source_Ptr;
11431       Id_Char    : Character) return Entity_Id
11432    is
11433       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
11434
11435    begin
11436       Set_Ekind          (N, Kind);
11437       Set_Is_Internal    (N, True);
11438       Append_Entity      (N, Scope_Id);
11439
11440       if Kind in Type_Kind then
11441          Init_Size_Align (N);
11442       end if;
11443
11444       return N;
11445    end New_Internal_Entity;
11446
11447    -----------------
11448    -- Next_Actual --
11449    -----------------
11450
11451    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
11452       N  : Node_Id;
11453
11454    begin
11455       --  If we are pointing at a positional parameter, it is a member of a
11456       --  node list (the list of parameters), and the next parameter is the
11457       --  next node on the list, unless we hit a parameter association, then
11458       --  we shift to using the chain whose head is the First_Named_Actual in
11459       --  the parent, and then is threaded using the Next_Named_Actual of the
11460       --  Parameter_Association. All this fiddling is because the original node
11461       --  list is in the textual call order, and what we need is the
11462       --  declaration order.
11463
11464       if Is_List_Member (Actual_Id) then
11465          N := Next (Actual_Id);
11466
11467          if Nkind (N) = N_Parameter_Association then
11468             return First_Named_Actual (Parent (Actual_Id));
11469          else
11470             return N;
11471          end if;
11472
11473       else
11474          return Next_Named_Actual (Parent (Actual_Id));
11475       end if;
11476    end Next_Actual;
11477
11478    procedure Next_Actual (Actual_Id : in out Node_Id) is
11479    begin
11480       Actual_Id := Next_Actual (Actual_Id);
11481    end Next_Actual;
11482
11483    ---------------------
11484    -- No_Scalar_Parts --
11485    ---------------------
11486
11487    function No_Scalar_Parts (T : Entity_Id) return Boolean is
11488       C : Entity_Id;
11489
11490    begin
11491       if Is_Scalar_Type (T) then
11492          return False;
11493
11494       elsif Is_Array_Type (T) then
11495          return No_Scalar_Parts (Component_Type (T));
11496
11497       elsif Is_Record_Type (T) or else Has_Discriminants (T) then
11498          C := First_Component_Or_Discriminant (T);
11499          while Present (C) loop
11500             if not No_Scalar_Parts (Etype (C)) then
11501                return False;
11502             else
11503                Next_Component_Or_Discriminant (C);
11504             end if;
11505          end loop;
11506       end if;
11507
11508       return True;
11509    end No_Scalar_Parts;
11510
11511    -----------------------
11512    -- Normalize_Actuals --
11513    -----------------------
11514
11515    --  Chain actuals according to formals of subprogram. If there are no named
11516    --  associations, the chain is simply the list of Parameter Associations,
11517    --  since the order is the same as the declaration order. If there are named
11518    --  associations, then the First_Named_Actual field in the N_Function_Call
11519    --  or N_Procedure_Call_Statement node points to the Parameter_Association
11520    --  node for the parameter that comes first in declaration order. The
11521    --  remaining named parameters are then chained in declaration order using
11522    --  Next_Named_Actual.
11523
11524    --  This routine also verifies that the number of actuals is compatible with
11525    --  the number and default values of formals, but performs no type checking
11526    --  (type checking is done by the caller).
11527
11528    --  If the matching succeeds, Success is set to True and the caller proceeds
11529    --  with type-checking. If the match is unsuccessful, then Success is set to
11530    --  False, and the caller attempts a different interpretation, if there is
11531    --  one.
11532
11533    --  If the flag Report is on, the call is not overloaded, and a failure to
11534    --  match can be reported here, rather than in the caller.
11535
11536    procedure Normalize_Actuals
11537      (N       : Node_Id;
11538       S       : Entity_Id;
11539       Report  : Boolean;
11540       Success : out Boolean)
11541    is
11542       Actuals     : constant List_Id := Parameter_Associations (N);
11543       Actual      : Node_Id := Empty;
11544       Formal      : Entity_Id;
11545       Last        : Node_Id := Empty;
11546       First_Named : Node_Id := Empty;
11547       Found       : Boolean;
11548
11549       Formals_To_Match : Integer := 0;
11550       Actuals_To_Match : Integer := 0;
11551
11552       procedure Chain (A : Node_Id);
11553       --  Add named actual at the proper place in the list, using the
11554       --  Next_Named_Actual link.
11555
11556       function Reporting return Boolean;
11557       --  Determines if an error is to be reported. To report an error, we
11558       --  need Report to be True, and also we do not report errors caused
11559       --  by calls to init procs that occur within other init procs. Such
11560       --  errors must always be cascaded errors, since if all the types are
11561       --  declared correctly, the compiler will certainly build decent calls!
11562
11563       -----------
11564       -- Chain --
11565       -----------
11566
11567       procedure Chain (A : Node_Id) is
11568       begin
11569          if No (Last) then
11570
11571             --  Call node points to first actual in list
11572
11573             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
11574
11575          else
11576             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
11577          end if;
11578
11579          Last := A;
11580          Set_Next_Named_Actual (Last, Empty);
11581       end Chain;
11582
11583       ---------------
11584       -- Reporting --
11585       ---------------
11586
11587       function Reporting return Boolean is
11588       begin
11589          if not Report then
11590             return False;
11591
11592          elsif not Within_Init_Proc then
11593             return True;
11594
11595          elsif Is_Init_Proc (Entity (Name (N))) then
11596             return False;
11597
11598          else
11599             return True;
11600          end if;
11601       end Reporting;
11602
11603    --  Start of processing for Normalize_Actuals
11604
11605    begin
11606       if Is_Access_Type (S) then
11607
11608          --  The name in the call is a function call that returns an access
11609          --  to subprogram. The designated type has the list of formals.
11610
11611          Formal := First_Formal (Designated_Type (S));
11612       else
11613          Formal := First_Formal (S);
11614       end if;
11615
11616       while Present (Formal) loop
11617          Formals_To_Match := Formals_To_Match + 1;
11618          Next_Formal (Formal);
11619       end loop;
11620
11621       --  Find if there is a named association, and verify that no positional
11622       --  associations appear after named ones.
11623
11624       if Present (Actuals) then
11625          Actual := First (Actuals);
11626       end if;
11627
11628       while Present (Actual)
11629         and then Nkind (Actual) /= N_Parameter_Association
11630       loop
11631          Actuals_To_Match := Actuals_To_Match + 1;
11632          Next (Actual);
11633       end loop;
11634
11635       if No (Actual) and Actuals_To_Match = Formals_To_Match then
11636
11637          --  Most common case: positional notation, no defaults
11638
11639          Success := True;
11640          return;
11641
11642       elsif Actuals_To_Match > Formals_To_Match then
11643
11644          --  Too many actuals: will not work
11645
11646          if Reporting then
11647             if Is_Entity_Name (Name (N)) then
11648                Error_Msg_N ("too many arguments in call to&", Name (N));
11649             else
11650                Error_Msg_N ("too many arguments in call", N);
11651             end if;
11652          end if;
11653
11654          Success := False;
11655          return;
11656       end if;
11657
11658       First_Named := Actual;
11659
11660       while Present (Actual) loop
11661          if Nkind (Actual) /= N_Parameter_Association then
11662             Error_Msg_N
11663               ("positional parameters not allowed after named ones", Actual);
11664             Success := False;
11665             return;
11666
11667          else
11668             Actuals_To_Match := Actuals_To_Match + 1;
11669          end if;
11670
11671          Next (Actual);
11672       end loop;
11673
11674       if Present (Actuals) then
11675          Actual := First (Actuals);
11676       end if;
11677
11678       Formal := First_Formal (S);
11679       while Present (Formal) loop
11680
11681          --  Match the formals in order. If the corresponding actual is
11682          --  positional, nothing to do. Else scan the list of named actuals
11683          --  to find the one with the right name.
11684
11685          if Present (Actual)
11686            and then Nkind (Actual) /= N_Parameter_Association
11687          then
11688             Next (Actual);
11689             Actuals_To_Match := Actuals_To_Match - 1;
11690             Formals_To_Match := Formals_To_Match - 1;
11691
11692          else
11693             --  For named parameters, search the list of actuals to find
11694             --  one that matches the next formal name.
11695
11696             Actual := First_Named;
11697             Found  := False;
11698             while Present (Actual) loop
11699                if Chars (Selector_Name (Actual)) = Chars (Formal) then
11700                   Found := True;
11701                   Chain (Actual);
11702                   Actuals_To_Match := Actuals_To_Match - 1;
11703                   Formals_To_Match := Formals_To_Match - 1;
11704                   exit;
11705                end if;
11706
11707                Next (Actual);
11708             end loop;
11709
11710             if not Found then
11711                if Ekind (Formal) /= E_In_Parameter
11712                  or else No (Default_Value (Formal))
11713                then
11714                   if Reporting then
11715                      if (Comes_From_Source (S)
11716                           or else Sloc (S) = Standard_Location)
11717                        and then Is_Overloadable (S)
11718                      then
11719                         if No (Actuals)
11720                           and then
11721                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
11722                              or else
11723                            (Nkind (Parent (N)) = N_Function_Call
11724                              or else
11725                             Nkind (Parent (N)) = N_Parameter_Association))
11726                           and then Ekind (S) /= E_Function
11727                         then
11728                            Set_Etype (N, Etype (S));
11729                         else
11730                            Error_Msg_Name_1 := Chars (S);
11731                            Error_Msg_Sloc := Sloc (S);
11732                            Error_Msg_NE
11733                              ("missing argument for parameter & " &
11734                                 "in call to % declared #", N, Formal);
11735                         end if;
11736
11737                      elsif Is_Overloadable (S) then
11738                         Error_Msg_Name_1 := Chars (S);
11739
11740                         --  Point to type derivation that generated the
11741                         --  operation.
11742
11743                         Error_Msg_Sloc := Sloc (Parent (S));
11744
11745                         Error_Msg_NE
11746                           ("missing argument for parameter & " &
11747                              "in call to % (inherited) #", N, Formal);
11748
11749                      else
11750                         Error_Msg_NE
11751                           ("missing argument for parameter &", N, Formal);
11752                      end if;
11753                   end if;
11754
11755                   Success := False;
11756                   return;
11757
11758                else
11759                   Formals_To_Match := Formals_To_Match - 1;
11760                end if;
11761             end if;
11762          end if;
11763
11764          Next_Formal (Formal);
11765       end loop;
11766
11767       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
11768          Success := True;
11769          return;
11770
11771       else
11772          if Reporting then
11773
11774             --  Find some superfluous named actual that did not get
11775             --  attached to the list of associations.
11776
11777             Actual := First (Actuals);
11778             while Present (Actual) loop
11779                if Nkind (Actual) = N_Parameter_Association
11780                  and then Actual /= Last
11781                  and then No (Next_Named_Actual (Actual))
11782                then
11783                   Error_Msg_N ("unmatched actual & in call",
11784                     Selector_Name (Actual));
11785                   exit;
11786                end if;
11787
11788                Next (Actual);
11789             end loop;
11790          end if;
11791
11792          Success := False;
11793          return;
11794       end if;
11795    end Normalize_Actuals;
11796
11797    --------------------------------
11798    -- Note_Possible_Modification --
11799    --------------------------------
11800
11801    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
11802       Modification_Comes_From_Source : constant Boolean :=
11803                                          Comes_From_Source (Parent (N));
11804
11805       Ent : Entity_Id;
11806       Exp : Node_Id;
11807
11808    begin
11809       --  Loop to find referenced entity, if there is one
11810
11811       Exp := N;
11812       loop
11813          <<Continue>>
11814          Ent := Empty;
11815
11816          if Is_Entity_Name (Exp) then
11817             Ent := Entity (Exp);
11818
11819             --  If the entity is missing, it is an undeclared identifier,
11820             --  and there is nothing to annotate.
11821
11822             if No (Ent) then
11823                return;
11824             end if;
11825
11826          elsif Nkind (Exp) = N_Explicit_Dereference then
11827             declare
11828                P : constant Node_Id := Prefix (Exp);
11829
11830             begin
11831                --  In formal verification mode, keep track of all reads and
11832                --  writes through explicit dereferences.
11833
11834                if Alfa_Mode then
11835                   Alfa.Generate_Dereference (N, 'm');
11836                end if;
11837
11838                if Nkind (P) = N_Selected_Component
11839                  and then Present (
11840                    Entry_Formal (Entity (Selector_Name (P))))
11841                then
11842                   --  Case of a reference to an entry formal
11843
11844                   Ent := Entry_Formal (Entity (Selector_Name (P)));
11845
11846                elsif Nkind (P) = N_Identifier
11847                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
11848                  and then Present (Expression (Parent (Entity (P))))
11849                  and then Nkind (Expression (Parent (Entity (P))))
11850                    = N_Reference
11851                then
11852                   --  Case of a reference to a value on which side effects have
11853                   --  been removed.
11854
11855                   Exp := Prefix (Expression (Parent (Entity (P))));
11856                   goto Continue;
11857
11858                else
11859                   return;
11860
11861                end if;
11862             end;
11863
11864          elsif     Nkind (Exp) = N_Type_Conversion
11865            or else Nkind (Exp) = N_Unchecked_Type_Conversion
11866          then
11867             Exp := Expression (Exp);
11868             goto Continue;
11869
11870          elsif     Nkind (Exp) = N_Slice
11871            or else Nkind (Exp) = N_Indexed_Component
11872            or else Nkind (Exp) = N_Selected_Component
11873          then
11874             Exp := Prefix (Exp);
11875             goto Continue;
11876
11877          else
11878             return;
11879          end if;
11880
11881          --  Now look for entity being referenced
11882
11883          if Present (Ent) then
11884             if Is_Object (Ent) then
11885                if Comes_From_Source (Exp)
11886                  or else Modification_Comes_From_Source
11887                then
11888                   --  Give warning if pragma unmodified given and we are
11889                   --  sure this is a modification.
11890
11891                   if Has_Pragma_Unmodified (Ent) and then Sure then
11892                      Error_Msg_NE
11893                        ("??pragma Unmodified given for &!", N, Ent);
11894                   end if;
11895
11896                   Set_Never_Set_In_Source (Ent, False);
11897                end if;
11898
11899                Set_Is_True_Constant (Ent, False);
11900                Set_Current_Value    (Ent, Empty);
11901                Set_Is_Known_Null    (Ent, False);
11902
11903                if not Can_Never_Be_Null (Ent) then
11904                   Set_Is_Known_Non_Null (Ent, False);
11905                end if;
11906
11907                --  Follow renaming chain
11908
11909                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
11910                  and then Present (Renamed_Object (Ent))
11911                then
11912                   Exp := Renamed_Object (Ent);
11913                   goto Continue;
11914
11915                --  The expression may be the renaming of a subcomponent of an
11916                --  array or container. The assignment to the subcomponent is
11917                --  a modification of the container.
11918
11919                elsif Comes_From_Source (Original_Node (Exp))
11920                  and then Nkind_In (Original_Node (Exp), N_Selected_Component,
11921                                                          N_Indexed_Component)
11922                then
11923                   Exp := Prefix (Original_Node (Exp));
11924                   goto Continue;
11925                end if;
11926
11927                --  Generate a reference only if the assignment comes from
11928                --  source. This excludes, for example, calls to a dispatching
11929                --  assignment operation when the left-hand side is tagged.
11930
11931                if Modification_Comes_From_Source or else Alfa_Mode then
11932                   Generate_Reference (Ent, Exp, 'm');
11933
11934                   --  If the target of the assignment is the bound variable
11935                   --  in an iterator, indicate that the corresponding array
11936                   --  or container is also modified.
11937
11938                   if Ada_Version >= Ada_2012
11939                     and then
11940                       Nkind (Parent (Ent)) = N_Iterator_Specification
11941                   then
11942                      declare
11943                         Domain : constant Node_Id := Name (Parent (Ent));
11944
11945                      begin
11946                         --  TBD : in the full version of the construct, the
11947                         --  domain of iteration can be given by an expression.
11948
11949                         if Is_Entity_Name (Domain) then
11950                            Generate_Reference      (Entity (Domain), Exp, 'm');
11951                            Set_Is_True_Constant    (Entity (Domain), False);
11952                            Set_Never_Set_In_Source (Entity (Domain), False);
11953                         end if;
11954                      end;
11955                   end if;
11956                end if;
11957
11958                Check_Nested_Access (Ent);
11959             end if;
11960
11961             Kill_Checks (Ent);
11962
11963             --  If we are sure this is a modification from source, and we know
11964             --  this modifies a constant, then give an appropriate warning.
11965
11966             if Overlays_Constant (Ent)
11967               and then Modification_Comes_From_Source
11968               and then Sure
11969             then
11970                declare
11971                   A : constant Node_Id := Address_Clause (Ent);
11972                begin
11973                   if Present (A) then
11974                      declare
11975                         Exp : constant Node_Id := Expression (A);
11976                      begin
11977                         if Nkind (Exp) = N_Attribute_Reference
11978                           and then Attribute_Name (Exp) = Name_Address
11979                           and then Is_Entity_Name (Prefix (Exp))
11980                         then
11981                            Error_Msg_Sloc := Sloc (A);
11982                            Error_Msg_NE
11983                              ("constant& may be modified via address "
11984                               & "clause#??", N, Entity (Prefix (Exp)));
11985                         end if;
11986                      end;
11987                   end if;
11988                end;
11989             end if;
11990
11991             return;
11992          end if;
11993       end loop;
11994    end Note_Possible_Modification;
11995
11996    -------------------------
11997    -- Object_Access_Level --
11998    -------------------------
11999
12000    --  Returns the static accessibility level of the view denoted by Obj. Note
12001    --  that the value returned is the result of a call to Scope_Depth. Only
12002    --  scope depths associated with dynamic scopes can actually be returned.
12003    --  Since only relative levels matter for accessibility checking, the fact
12004    --  that the distance between successive levels of accessibility is not
12005    --  always one is immaterial (invariant: if level(E2) is deeper than
12006    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
12007
12008    function Object_Access_Level (Obj : Node_Id) return Uint is
12009       function Is_Interface_Conversion (N : Node_Id) return Boolean;
12010       --  Determine whether N is a construct of the form
12011       --    Some_Type (Operand._tag'Address)
12012       --  This construct appears in the context of dispatching calls.
12013
12014       function Reference_To (Obj : Node_Id) return Node_Id;
12015       --  An explicit dereference is created when removing side-effects from
12016       --  expressions for constraint checking purposes. In this case a local
12017       --  access type is created for it. The correct access level is that of
12018       --  the original source node. We detect this case by noting that the
12019       --  prefix of the dereference is created by an object declaration whose
12020       --  initial expression is a reference.
12021
12022       -----------------------------
12023       -- Is_Interface_Conversion --
12024       -----------------------------
12025
12026       function Is_Interface_Conversion (N : Node_Id) return Boolean is
12027       begin
12028          return
12029            Nkind (N) = N_Unchecked_Type_Conversion
12030              and then Nkind (Expression (N)) = N_Attribute_Reference
12031              and then Attribute_Name (Expression (N)) = Name_Address;
12032       end Is_Interface_Conversion;
12033
12034       ------------------
12035       -- Reference_To --
12036       ------------------
12037
12038       function Reference_To (Obj : Node_Id) return Node_Id is
12039          Pref : constant Node_Id := Prefix (Obj);
12040       begin
12041          if Is_Entity_Name (Pref)
12042            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
12043            and then Present (Expression (Parent (Entity (Pref))))
12044            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
12045          then
12046             return (Prefix (Expression (Parent (Entity (Pref)))));
12047          else
12048             return Empty;
12049          end if;
12050       end Reference_To;
12051
12052       --  Local variables
12053
12054       E : Entity_Id;
12055
12056    --  Start of processing for Object_Access_Level
12057
12058    begin
12059       if Nkind (Obj) = N_Defining_Identifier
12060         or else Is_Entity_Name (Obj)
12061       then
12062          if Nkind (Obj) = N_Defining_Identifier then
12063             E := Obj;
12064          else
12065             E := Entity (Obj);
12066          end if;
12067
12068          if Is_Prival (E) then
12069             E := Prival_Link (E);
12070          end if;
12071
12072          --  If E is a type then it denotes a current instance. For this case
12073          --  we add one to the normal accessibility level of the type to ensure
12074          --  that current instances are treated as always being deeper than
12075          --  than the level of any visible named access type (see 3.10.2(21)).
12076
12077          if Is_Type (E) then
12078             return Type_Access_Level (E) +  1;
12079
12080          elsif Present (Renamed_Object (E)) then
12081             return Object_Access_Level (Renamed_Object (E));
12082
12083          --  Similarly, if E is a component of the current instance of a
12084          --  protected type, any instance of it is assumed to be at a deeper
12085          --  level than the type. For a protected object (whose type is an
12086          --  anonymous protected type) its components are at the same level
12087          --  as the type itself.
12088
12089          elsif not Is_Overloadable (E)
12090            and then Ekind (Scope (E)) = E_Protected_Type
12091            and then Comes_From_Source (Scope (E))
12092          then
12093             return Type_Access_Level (Scope (E)) + 1;
12094
12095          else
12096             return Scope_Depth (Enclosing_Dynamic_Scope (E));
12097          end if;
12098
12099       elsif Nkind (Obj) = N_Selected_Component then
12100          if Is_Access_Type (Etype (Prefix (Obj))) then
12101             return Type_Access_Level (Etype (Prefix (Obj)));
12102          else
12103             return Object_Access_Level (Prefix (Obj));
12104          end if;
12105
12106       elsif Nkind (Obj) = N_Indexed_Component then
12107          if Is_Access_Type (Etype (Prefix (Obj))) then
12108             return Type_Access_Level (Etype (Prefix (Obj)));
12109          else
12110             return Object_Access_Level (Prefix (Obj));
12111          end if;
12112
12113       elsif Nkind (Obj) = N_Explicit_Dereference then
12114
12115          --  If the prefix is a selected access discriminant then we make a
12116          --  recursive call on the prefix, which will in turn check the level
12117          --  of the prefix object of the selected discriminant.
12118
12119          if Nkind (Prefix (Obj)) = N_Selected_Component
12120            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
12121            and then
12122              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
12123          then
12124             return Object_Access_Level (Prefix (Obj));
12125
12126          --  Detect an interface conversion in the context of a dispatching
12127          --  call. Use the original form of the conversion to find the access
12128          --  level of the operand.
12129
12130          elsif Is_Interface (Etype (Obj))
12131            and then Is_Interface_Conversion (Prefix (Obj))
12132            and then Nkind (Original_Node (Obj)) = N_Type_Conversion
12133          then
12134             return Object_Access_Level (Original_Node (Obj));
12135
12136          elsif not Comes_From_Source (Obj) then
12137             declare
12138                Ref : constant Node_Id := Reference_To (Obj);
12139             begin
12140                if Present (Ref) then
12141                   return Object_Access_Level (Ref);
12142                else
12143                   return Type_Access_Level (Etype (Prefix (Obj)));
12144                end if;
12145             end;
12146
12147          else
12148             return Type_Access_Level (Etype (Prefix (Obj)));
12149          end if;
12150
12151       elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
12152          return Object_Access_Level (Expression (Obj));
12153
12154       elsif Nkind (Obj) = N_Function_Call then
12155
12156          --  Function results are objects, so we get either the access level of
12157          --  the function or, in the case of an indirect call, the level of the
12158          --  access-to-subprogram type. (This code is used for Ada 95, but it
12159          --  looks wrong, because it seems that we should be checking the level
12160          --  of the call itself, even for Ada 95. However, using the Ada 2005
12161          --  version of the code causes regressions in several tests that are
12162          --  compiled with -gnat95. ???)
12163
12164          if Ada_Version < Ada_2005 then
12165             if Is_Entity_Name (Name (Obj)) then
12166                return Subprogram_Access_Level (Entity (Name (Obj)));
12167             else
12168                return Type_Access_Level (Etype (Prefix (Name (Obj))));
12169             end if;
12170
12171          --  For Ada 2005, the level of the result object of a function call is
12172          --  defined to be the level of the call's innermost enclosing master.
12173          --  We determine that by querying the depth of the innermost enclosing
12174          --  dynamic scope.
12175
12176          else
12177             Return_Master_Scope_Depth_Of_Call : declare
12178
12179                function Innermost_Master_Scope_Depth
12180                  (N : Node_Id) return Uint;
12181                --  Returns the scope depth of the given node's innermost
12182                --  enclosing dynamic scope (effectively the accessibility
12183                --  level of the innermost enclosing master).
12184
12185                ----------------------------------
12186                -- Innermost_Master_Scope_Depth --
12187                ----------------------------------
12188
12189                function Innermost_Master_Scope_Depth
12190                  (N : Node_Id) return Uint
12191                is
12192                   Node_Par : Node_Id := Parent (N);
12193
12194                begin
12195                   --  Locate the nearest enclosing node (by traversing Parents)
12196                   --  that Defining_Entity can be applied to, and return the
12197                   --  depth of that entity's nearest enclosing dynamic scope.
12198
12199                   while Present (Node_Par) loop
12200                      case Nkind (Node_Par) is
12201                         when N_Component_Declaration           |
12202                              N_Entry_Declaration               |
12203                              N_Formal_Object_Declaration       |
12204                              N_Formal_Type_Declaration         |
12205                              N_Full_Type_Declaration           |
12206                              N_Incomplete_Type_Declaration     |
12207                              N_Loop_Parameter_Specification    |
12208                              N_Object_Declaration              |
12209                              N_Protected_Type_Declaration      |
12210                              N_Private_Extension_Declaration   |
12211                              N_Private_Type_Declaration        |
12212                              N_Subtype_Declaration             |
12213                              N_Function_Specification          |
12214                              N_Procedure_Specification         |
12215                              N_Task_Type_Declaration           |
12216                              N_Body_Stub                       |
12217                              N_Generic_Instantiation           |
12218                              N_Proper_Body                     |
12219                              N_Implicit_Label_Declaration      |
12220                              N_Package_Declaration             |
12221                              N_Single_Task_Declaration         |
12222                              N_Subprogram_Declaration          |
12223                              N_Generic_Declaration             |
12224                              N_Renaming_Declaration            |
12225                              N_Block_Statement                 |
12226                              N_Formal_Subprogram_Declaration   |
12227                              N_Abstract_Subprogram_Declaration |
12228                              N_Entry_Body                      |
12229                              N_Exception_Declaration           |
12230                              N_Formal_Package_Declaration      |
12231                              N_Number_Declaration              |
12232                              N_Package_Specification           |
12233                              N_Parameter_Specification         |
12234                              N_Single_Protected_Declaration    |
12235                              N_Subunit                         =>
12236
12237                            return Scope_Depth
12238                                     (Nearest_Dynamic_Scope
12239                                        (Defining_Entity (Node_Par)));
12240
12241                         when others =>
12242                            null;
12243                      end case;
12244
12245                      Node_Par := Parent (Node_Par);
12246                   end loop;
12247
12248                   pragma Assert (False);
12249
12250                   --  Should never reach the following return
12251
12252                   return Scope_Depth (Current_Scope) + 1;
12253                end Innermost_Master_Scope_Depth;
12254
12255             --  Start of processing for Return_Master_Scope_Depth_Of_Call
12256
12257             begin
12258                return Innermost_Master_Scope_Depth (Obj);
12259             end Return_Master_Scope_Depth_Of_Call;
12260          end if;
12261
12262       --  For convenience we handle qualified expressions, even though they
12263       --  aren't technically object names.
12264
12265       elsif Nkind (Obj) = N_Qualified_Expression then
12266          return Object_Access_Level (Expression (Obj));
12267
12268       --  Otherwise return the scope level of Standard. (If there are cases
12269       --  that fall through to this point they will be treated as having
12270       --  global accessibility for now. ???)
12271
12272       else
12273          return Scope_Depth (Standard_Standard);
12274       end if;
12275    end Object_Access_Level;
12276
12277    --------------------------------------
12278    -- Original_Corresponding_Operation --
12279    --------------------------------------
12280
12281    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
12282    is
12283       Typ : constant Entity_Id := Find_Dispatching_Type (S);
12284
12285    begin
12286       --  If S is an inherited primitive S2 the original corresponding
12287       --  operation of S is the original corresponding operation of S2
12288
12289       if Present (Alias (S))
12290         and then Find_Dispatching_Type (Alias (S)) /= Typ
12291       then
12292          return Original_Corresponding_Operation (Alias (S));
12293
12294       --  If S overrides an inherited subprogram S2 the original corresponding
12295       --  operation of S is the original corresponding operation of S2
12296
12297       elsif Present (Overridden_Operation (S)) then
12298          return Original_Corresponding_Operation (Overridden_Operation (S));
12299
12300       --  otherwise it is S itself
12301
12302       else
12303          return S;
12304       end if;
12305    end Original_Corresponding_Operation;
12306
12307    -----------------------
12308    -- Private_Component --
12309    -----------------------
12310
12311    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
12312       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
12313
12314       function Trace_Components
12315         (T     : Entity_Id;
12316          Check : Boolean) return Entity_Id;
12317       --  Recursive function that does the work, and checks against circular
12318       --  definition for each subcomponent type.
12319
12320       ----------------------
12321       -- Trace_Components --
12322       ----------------------
12323
12324       function Trace_Components
12325          (T     : Entity_Id;
12326           Check : Boolean) return Entity_Id
12327        is
12328          Btype     : constant Entity_Id := Base_Type (T);
12329          Component : Entity_Id;
12330          P         : Entity_Id;
12331          Candidate : Entity_Id := Empty;
12332
12333       begin
12334          if Check and then Btype = Ancestor then
12335             Error_Msg_N ("circular type definition", Type_Id);
12336             return Any_Type;
12337          end if;
12338
12339          if Is_Private_Type (Btype)
12340            and then not Is_Generic_Type (Btype)
12341          then
12342             if Present (Full_View (Btype))
12343               and then Is_Record_Type (Full_View (Btype))
12344               and then not Is_Frozen (Btype)
12345             then
12346                --  To indicate that the ancestor depends on a private type, the
12347                --  current Btype is sufficient. However, to check for circular
12348                --  definition we must recurse on the full view.
12349
12350                Candidate := Trace_Components (Full_View (Btype), True);
12351
12352                if Candidate = Any_Type then
12353                   return Any_Type;
12354                else
12355                   return Btype;
12356                end if;
12357
12358             else
12359                return Btype;
12360             end if;
12361
12362          elsif Is_Array_Type (Btype) then
12363             return Trace_Components (Component_Type (Btype), True);
12364
12365          elsif Is_Record_Type (Btype) then
12366             Component := First_Entity (Btype);
12367             while Present (Component)
12368               and then Comes_From_Source (Component)
12369             loop
12370                --  Skip anonymous types generated by constrained components
12371
12372                if not Is_Type (Component) then
12373                   P := Trace_Components (Etype (Component), True);
12374
12375                   if Present (P) then
12376                      if P = Any_Type then
12377                         return P;
12378                      else
12379                         Candidate := P;
12380                      end if;
12381                   end if;
12382                end if;
12383
12384                Next_Entity (Component);
12385             end loop;
12386
12387             return Candidate;
12388
12389          else
12390             return Empty;
12391          end if;
12392       end Trace_Components;
12393
12394    --  Start of processing for Private_Component
12395
12396    begin
12397       return Trace_Components (Type_Id, False);
12398    end Private_Component;
12399
12400    ---------------------------
12401    -- Primitive_Names_Match --
12402    ---------------------------
12403
12404    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
12405
12406       function Non_Internal_Name (E : Entity_Id) return Name_Id;
12407       --  Given an internal name, returns the corresponding non-internal name
12408
12409       ------------------------
12410       --  Non_Internal_Name --
12411       ------------------------
12412
12413       function Non_Internal_Name (E : Entity_Id) return Name_Id is
12414       begin
12415          Get_Name_String (Chars (E));
12416          Name_Len := Name_Len - 1;
12417          return Name_Find;
12418       end Non_Internal_Name;
12419
12420    --  Start of processing for Primitive_Names_Match
12421
12422    begin
12423       pragma Assert (Present (E1) and then Present (E2));
12424
12425       return Chars (E1) = Chars (E2)
12426         or else
12427            (not Is_Internal_Name (Chars (E1))
12428               and then Is_Internal_Name (Chars (E2))
12429               and then Non_Internal_Name (E2) = Chars (E1))
12430         or else
12431            (not Is_Internal_Name (Chars (E2))
12432               and then Is_Internal_Name (Chars (E1))
12433               and then Non_Internal_Name (E1) = Chars (E2))
12434         or else
12435            (Is_Predefined_Dispatching_Operation (E1)
12436               and then Is_Predefined_Dispatching_Operation (E2)
12437               and then Same_TSS (E1, E2))
12438         or else
12439            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
12440    end Primitive_Names_Match;
12441
12442    -----------------------
12443    -- Process_End_Label --
12444    -----------------------
12445
12446    procedure Process_End_Label
12447      (N   : Node_Id;
12448       Typ : Character;
12449       Ent : Entity_Id)
12450    is
12451       Loc  : Source_Ptr;
12452       Nam  : Node_Id;
12453       Scop : Entity_Id;
12454
12455       Label_Ref : Boolean;
12456       --  Set True if reference to end label itself is required
12457
12458       Endl : Node_Id;
12459       --  Gets set to the operator symbol or identifier that references the
12460       --  entity Ent. For the child unit case, this is the identifier from the
12461       --  designator. For other cases, this is simply Endl.
12462
12463       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
12464       --  N is an identifier node that appears as a parent unit reference in
12465       --  the case where Ent is a child unit. This procedure generates an
12466       --  appropriate cross-reference entry. E is the corresponding entity.
12467
12468       -------------------------
12469       -- Generate_Parent_Ref --
12470       -------------------------
12471
12472       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
12473       begin
12474          --  If names do not match, something weird, skip reference
12475
12476          if Chars (E) = Chars (N) then
12477
12478             --  Generate the reference. We do NOT consider this as a reference
12479             --  for unreferenced symbol purposes.
12480
12481             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
12482
12483             if Style_Check then
12484                Style.Check_Identifier (N, E);
12485             end if;
12486          end if;
12487       end Generate_Parent_Ref;
12488
12489    --  Start of processing for Process_End_Label
12490
12491    begin
12492       --  If no node, ignore. This happens in some error situations, and
12493       --  also for some internally generated structures where no end label
12494       --  references are required in any case.
12495
12496       if No (N) then
12497          return;
12498       end if;
12499
12500       --  Nothing to do if no End_Label, happens for internally generated
12501       --  constructs where we don't want an end label reference anyway. Also
12502       --  nothing to do if Endl is a string literal, which means there was
12503       --  some prior error (bad operator symbol)
12504
12505       Endl := End_Label (N);
12506
12507       if No (Endl) or else Nkind (Endl) = N_String_Literal then
12508          return;
12509       end if;
12510
12511       --  Reference node is not in extended main source unit
12512
12513       if not In_Extended_Main_Source_Unit (N) then
12514
12515          --  Generally we do not collect references except for the extended
12516          --  main source unit. The one exception is the 'e' entry for a
12517          --  package spec, where it is useful for a client to have the
12518          --  ending information to define scopes.
12519
12520          if Typ /= 'e' then
12521             return;
12522
12523          else
12524             Label_Ref := False;
12525
12526             --  For this case, we can ignore any parent references, but we
12527             --  need the package name itself for the 'e' entry.
12528
12529             if Nkind (Endl) = N_Designator then
12530                Endl := Identifier (Endl);
12531             end if;
12532          end if;
12533
12534       --  Reference is in extended main source unit
12535
12536       else
12537          Label_Ref := True;
12538
12539          --  For designator, generate references for the parent entries
12540
12541          if Nkind (Endl) = N_Designator then
12542
12543             --  Generate references for the prefix if the END line comes from
12544             --  source (otherwise we do not need these references) We climb the
12545             --  scope stack to find the expected entities.
12546
12547             if Comes_From_Source (Endl) then
12548                Nam  := Name (Endl);
12549                Scop := Current_Scope;
12550                while Nkind (Nam) = N_Selected_Component loop
12551                   Scop := Scope (Scop);
12552                   exit when No (Scop);
12553                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
12554                   Nam := Prefix (Nam);
12555                end loop;
12556
12557                if Present (Scop) then
12558                   Generate_Parent_Ref (Nam, Scope (Scop));
12559                end if;
12560             end if;
12561
12562             Endl := Identifier (Endl);
12563          end if;
12564       end if;
12565
12566       --  If the end label is not for the given entity, then either we have
12567       --  some previous error, or this is a generic instantiation for which
12568       --  we do not need to make a cross-reference in this case anyway. In
12569       --  either case we simply ignore the call.
12570
12571       if Chars (Ent) /= Chars (Endl) then
12572          return;
12573       end if;
12574
12575       --  If label was really there, then generate a normal reference and then
12576       --  adjust the location in the end label to point past the name (which
12577       --  should almost always be the semicolon).
12578
12579       Loc := Sloc (Endl);
12580
12581       if Comes_From_Source (Endl) then
12582
12583          --  If a label reference is required, then do the style check and
12584          --  generate an l-type cross-reference entry for the label
12585
12586          if Label_Ref then
12587             if Style_Check then
12588                Style.Check_Identifier (Endl, Ent);
12589             end if;
12590
12591             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
12592          end if;
12593
12594          --  Set the location to point past the label (normally this will
12595          --  mean the semicolon immediately following the label). This is
12596          --  done for the sake of the 'e' or 't' entry generated below.
12597
12598          Get_Decoded_Name_String (Chars (Endl));
12599          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
12600
12601       else
12602          --  In SPARK mode, no missing label is allowed for packages and
12603          --  subprogram bodies. Detect those cases by testing whether
12604          --  Process_End_Label was called for a body (Typ = 't') or a package.
12605
12606          if Restriction_Check_Required (SPARK)
12607            and then (Typ = 't' or else Ekind (Ent) = E_Package)
12608          then
12609             Error_Msg_Node_1 := Endl;
12610             Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
12611          end if;
12612       end if;
12613
12614       --  Now generate the e/t reference
12615
12616       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
12617
12618       --  Restore Sloc, in case modified above, since we have an identifier
12619       --  and the normal Sloc should be left set in the tree.
12620
12621       Set_Sloc (Endl, Loc);
12622    end Process_End_Label;
12623
12624    ------------------------------------
12625    -- References_Generic_Formal_Type --
12626    ------------------------------------
12627
12628    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
12629
12630       function Process (N : Node_Id) return Traverse_Result;
12631       --  Process one node in search for generic formal type
12632
12633       -------------
12634       -- Process --
12635       -------------
12636
12637       function Process (N : Node_Id) return Traverse_Result is
12638       begin
12639          if Nkind (N) in N_Has_Entity then
12640             declare
12641                E : constant Entity_Id := Entity (N);
12642             begin
12643                if Present (E) then
12644                   if Is_Generic_Type (E) then
12645                      return Abandon;
12646                   elsif Present (Etype (E))
12647                     and then Is_Generic_Type (Etype (E))
12648                   then
12649                      return Abandon;
12650                   end if;
12651                end if;
12652             end;
12653          end if;
12654
12655          return Atree.OK;
12656       end Process;
12657
12658       function Traverse is new Traverse_Func (Process);
12659       --  Traverse tree to look for generic type
12660
12661    begin
12662       if Inside_A_Generic then
12663          return Traverse (N) = Abandon;
12664       else
12665          return False;
12666       end if;
12667    end References_Generic_Formal_Type;
12668
12669    --------------------
12670    -- Remove_Homonym --
12671    --------------------
12672
12673    procedure Remove_Homonym (E : Entity_Id) is
12674       Prev  : Entity_Id := Empty;
12675       H     : Entity_Id;
12676
12677    begin
12678       if E = Current_Entity (E) then
12679          if Present (Homonym (E)) then
12680             Set_Current_Entity (Homonym (E));
12681          else
12682             Set_Name_Entity_Id (Chars (E), Empty);
12683          end if;
12684
12685       else
12686          H := Current_Entity (E);
12687          while Present (H) and then H /= E loop
12688             Prev := H;
12689             H    := Homonym (H);
12690          end loop;
12691
12692          --  If E is not on the homonym chain, nothing to do
12693
12694          if Present (H) then
12695             Set_Homonym (Prev, Homonym (E));
12696          end if;
12697       end if;
12698    end Remove_Homonym;
12699
12700    ---------------------
12701    -- Rep_To_Pos_Flag --
12702    ---------------------
12703
12704    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
12705    begin
12706       return New_Occurrence_Of
12707                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
12708    end Rep_To_Pos_Flag;
12709
12710    --------------------
12711    -- Require_Entity --
12712    --------------------
12713
12714    procedure Require_Entity (N : Node_Id) is
12715    begin
12716       if Is_Entity_Name (N) and then No (Entity (N)) then
12717          if Total_Errors_Detected /= 0 then
12718             Set_Entity (N, Any_Id);
12719          else
12720             raise Program_Error;
12721          end if;
12722       end if;
12723    end Require_Entity;
12724
12725    ------------------------------
12726    -- Requires_Transient_Scope --
12727    ------------------------------
12728
12729    --  A transient scope is required when variable-sized temporaries are
12730    --  allocated in the primary or secondary stack, or when finalization
12731    --  actions must be generated before the next instruction.
12732
12733    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
12734       Typ : constant Entity_Id := Underlying_Type (Id);
12735
12736    --  Start of processing for Requires_Transient_Scope
12737
12738    begin
12739       --  This is a private type which is not completed yet. This can only
12740       --  happen in a default expression (of a formal parameter or of a
12741       --  record component). Do not expand transient scope in this case
12742
12743       if No (Typ) then
12744          return False;
12745
12746       --  Do not expand transient scope for non-existent procedure return
12747
12748       elsif Typ = Standard_Void_Type then
12749          return False;
12750
12751       --  Elementary types do not require a transient scope
12752
12753       elsif Is_Elementary_Type (Typ) then
12754          return False;
12755
12756       --  Generally, indefinite subtypes require a transient scope, since the
12757       --  back end cannot generate temporaries, since this is not a valid type
12758       --  for declaring an object. It might be possible to relax this in the
12759       --  future, e.g. by declaring the maximum possible space for the type.
12760
12761       elsif Is_Indefinite_Subtype (Typ) then
12762          return True;
12763
12764       --  Functions returning tagged types may dispatch on result so their
12765       --  returned value is allocated on the secondary stack. Controlled
12766       --  type temporaries need finalization.
12767
12768       elsif Is_Tagged_Type (Typ)
12769         or else Has_Controlled_Component (Typ)
12770       then
12771          return not Is_Value_Type (Typ);
12772
12773       --  Record type
12774
12775       elsif Is_Record_Type (Typ) then
12776          declare
12777             Comp : Entity_Id;
12778          begin
12779             Comp := First_Entity (Typ);
12780             while Present (Comp) loop
12781                if Ekind (Comp) = E_Component
12782                   and then Requires_Transient_Scope (Etype (Comp))
12783                then
12784                   return True;
12785                else
12786                   Next_Entity (Comp);
12787                end if;
12788             end loop;
12789          end;
12790
12791          return False;
12792
12793       --  String literal types never require transient scope
12794
12795       elsif Ekind (Typ) = E_String_Literal_Subtype then
12796          return False;
12797
12798       --  Array type. Note that we already know that this is a constrained
12799       --  array, since unconstrained arrays will fail the indefinite test.
12800
12801       elsif Is_Array_Type (Typ) then
12802
12803          --  If component type requires a transient scope, the array does too
12804
12805          if Requires_Transient_Scope (Component_Type (Typ)) then
12806             return True;
12807
12808          --  Otherwise, we only need a transient scope if the size depends on
12809          --  the value of one or more discriminants.
12810
12811          else
12812             return Size_Depends_On_Discriminant (Typ);
12813          end if;
12814
12815       --  All other cases do not require a transient scope
12816
12817       else
12818          return False;
12819       end if;
12820    end Requires_Transient_Scope;
12821
12822    --------------------------
12823    -- Reset_Analyzed_Flags --
12824    --------------------------
12825
12826    procedure Reset_Analyzed_Flags (N : Node_Id) is
12827
12828       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
12829       --  Function used to reset Analyzed flags in tree. Note that we do
12830       --  not reset Analyzed flags in entities, since there is no need to
12831       --  reanalyze entities, and indeed, it is wrong to do so, since it
12832       --  can result in generating auxiliary stuff more than once.
12833
12834       --------------------
12835       -- Clear_Analyzed --
12836       --------------------
12837
12838       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
12839       begin
12840          if not Has_Extension (N) then
12841             Set_Analyzed (N, False);
12842          end if;
12843
12844          return OK;
12845       end Clear_Analyzed;
12846
12847       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
12848
12849    --  Start of processing for Reset_Analyzed_Flags
12850
12851    begin
12852       Reset_Analyzed (N);
12853    end Reset_Analyzed_Flags;
12854
12855    --------------------------------
12856    -- Returns_Unconstrained_Type --
12857    --------------------------------
12858
12859    function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
12860    begin
12861       return Ekind (Subp) = E_Function
12862         and then not Is_Scalar_Type (Etype (Subp))
12863         and then not Is_Access_Type (Etype (Subp))
12864         and then not Is_Constrained (Etype (Subp));
12865    end Returns_Unconstrained_Type;
12866
12867    ---------------------------
12868    -- Safe_To_Capture_Value --
12869    ---------------------------
12870
12871    function Safe_To_Capture_Value
12872      (N    : Node_Id;
12873       Ent  : Entity_Id;
12874       Cond : Boolean := False) return Boolean
12875    is
12876    begin
12877       --  The only entities for which we track constant values are variables
12878       --  which are not renamings, constants, out parameters, and in out
12879       --  parameters, so check if we have this case.
12880
12881       --  Note: it may seem odd to track constant values for constants, but in
12882       --  fact this routine is used for other purposes than simply capturing
12883       --  the value. In particular, the setting of Known[_Non]_Null.
12884
12885       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
12886             or else
12887           Ekind (Ent) = E_Constant
12888             or else
12889           Ekind (Ent) = E_Out_Parameter
12890             or else
12891           Ekind (Ent) = E_In_Out_Parameter
12892       then
12893          null;
12894
12895       --  For conditionals, we also allow loop parameters and all formals,
12896       --  including in parameters.
12897
12898       elsif Cond
12899         and then
12900           (Ekind (Ent) = E_Loop_Parameter
12901              or else
12902            Ekind (Ent) = E_In_Parameter)
12903       then
12904          null;
12905
12906       --  For all other cases, not just unsafe, but impossible to capture
12907       --  Current_Value, since the above are the only entities which have
12908       --  Current_Value fields.
12909
12910       else
12911          return False;
12912       end if;
12913
12914       --  Skip if volatile or aliased, since funny things might be going on in
12915       --  these cases which we cannot necessarily track. Also skip any variable
12916       --  for which an address clause is given, or whose address is taken. Also
12917       --  never capture value of library level variables (an attempt to do so
12918       --  can occur in the case of package elaboration code).
12919
12920       if Treat_As_Volatile (Ent)
12921         or else Is_Aliased (Ent)
12922         or else Present (Address_Clause (Ent))
12923         or else Address_Taken (Ent)
12924         or else (Is_Library_Level_Entity (Ent)
12925                    and then Ekind (Ent) = E_Variable)
12926       then
12927          return False;
12928       end if;
12929
12930       --  OK, all above conditions are met. We also require that the scope of
12931       --  the reference be the same as the scope of the entity, not counting
12932       --  packages and blocks and loops.
12933
12934       declare
12935          E_Scope : constant Entity_Id := Scope (Ent);
12936          R_Scope : Entity_Id;
12937
12938       begin
12939          R_Scope := Current_Scope;
12940          while R_Scope /= Standard_Standard loop
12941             exit when R_Scope = E_Scope;
12942
12943             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
12944                return False;
12945             else
12946                R_Scope := Scope (R_Scope);
12947             end if;
12948          end loop;
12949       end;
12950
12951       --  We also require that the reference does not appear in a context
12952       --  where it is not sure to be executed (i.e. a conditional context
12953       --  or an exception handler). We skip this if Cond is True, since the
12954       --  capturing of values from conditional tests handles this ok.
12955
12956       if Cond then
12957          return True;
12958       end if;
12959
12960       declare
12961          Desc : Node_Id;
12962          P    : Node_Id;
12963
12964       begin
12965          Desc := N;
12966
12967          --  Seems dubious that case expressions are not handled here ???
12968
12969          P := Parent (N);
12970          while Present (P) loop
12971             if         Nkind (P) = N_If_Statement
12972               or else  Nkind (P) = N_Case_Statement
12973               or else (Nkind (P) in N_Short_Circuit
12974                          and then Desc = Right_Opnd (P))
12975               or else (Nkind (P) = N_If_Expression
12976                          and then Desc /= First (Expressions (P)))
12977               or else  Nkind (P) = N_Exception_Handler
12978               or else  Nkind (P) = N_Selective_Accept
12979               or else  Nkind (P) = N_Conditional_Entry_Call
12980               or else  Nkind (P) = N_Timed_Entry_Call
12981               or else  Nkind (P) = N_Asynchronous_Select
12982             then
12983                return False;
12984             else
12985                Desc := P;
12986                P    := Parent (P);
12987             end if;
12988          end loop;
12989       end;
12990
12991       --  OK, looks safe to set value
12992
12993       return True;
12994    end Safe_To_Capture_Value;
12995
12996    ---------------
12997    -- Same_Name --
12998    ---------------
12999
13000    function Same_Name (N1, N2 : Node_Id) return Boolean is
13001       K1 : constant Node_Kind := Nkind (N1);
13002       K2 : constant Node_Kind := Nkind (N2);
13003
13004    begin
13005       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
13006         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
13007       then
13008          return Chars (N1) = Chars (N2);
13009
13010       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
13011         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
13012       then
13013          return Same_Name (Selector_Name (N1), Selector_Name (N2))
13014            and then Same_Name (Prefix (N1), Prefix (N2));
13015
13016       else
13017          return False;
13018       end if;
13019    end Same_Name;
13020
13021    -----------------
13022    -- Same_Object --
13023    -----------------
13024
13025    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
13026       N1 : constant Node_Id := Original_Node (Node1);
13027       N2 : constant Node_Id := Original_Node (Node2);
13028       --  We do the tests on original nodes, since we are most interested
13029       --  in the original source, not any expansion that got in the way.
13030
13031       K1 : constant Node_Kind := Nkind (N1);
13032       K2 : constant Node_Kind := Nkind (N2);
13033
13034    begin
13035       --  First case, both are entities with same entity
13036
13037       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
13038          declare
13039             EN1 : constant Entity_Id := Entity (N1);
13040             EN2 : constant Entity_Id := Entity (N2);
13041          begin
13042             if Present (EN1) and then Present (EN2)
13043               and then (Ekind_In (EN1, E_Variable, E_Constant)
13044                          or else Is_Formal (EN1))
13045               and then EN1 = EN2
13046             then
13047                return True;
13048             end if;
13049          end;
13050       end if;
13051
13052       --  Second case, selected component with same selector, same record
13053
13054       if K1 = N_Selected_Component
13055         and then K2 = N_Selected_Component
13056         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
13057       then
13058          return Same_Object (Prefix (N1), Prefix (N2));
13059
13060       --  Third case, indexed component with same subscripts, same array
13061
13062       elsif K1 = N_Indexed_Component
13063         and then K2 = N_Indexed_Component
13064         and then Same_Object (Prefix (N1), Prefix (N2))
13065       then
13066          declare
13067             E1, E2 : Node_Id;
13068          begin
13069             E1 := First (Expressions (N1));
13070             E2 := First (Expressions (N2));
13071             while Present (E1) loop
13072                if not Same_Value (E1, E2) then
13073                   return False;
13074                else
13075                   Next (E1);
13076                   Next (E2);
13077                end if;
13078             end loop;
13079
13080             return True;
13081          end;
13082
13083       --  Fourth case, slice of same array with same bounds
13084
13085       elsif K1 = N_Slice
13086         and then K2 = N_Slice
13087         and then Nkind (Discrete_Range (N1)) = N_Range
13088         and then Nkind (Discrete_Range (N2)) = N_Range
13089         and then Same_Value (Low_Bound (Discrete_Range (N1)),
13090                              Low_Bound (Discrete_Range (N2)))
13091         and then Same_Value (High_Bound (Discrete_Range (N1)),
13092                              High_Bound (Discrete_Range (N2)))
13093       then
13094          return Same_Name (Prefix (N1), Prefix (N2));
13095
13096       --  All other cases, not clearly the same object
13097
13098       else
13099          return False;
13100       end if;
13101    end Same_Object;
13102
13103    ---------------
13104    -- Same_Type --
13105    ---------------
13106
13107    function Same_Type (T1, T2 : Entity_Id) return Boolean is
13108    begin
13109       if T1 = T2 then
13110          return True;
13111
13112       elsif not Is_Constrained (T1)
13113         and then not Is_Constrained (T2)
13114         and then Base_Type (T1) = Base_Type (T2)
13115       then
13116          return True;
13117
13118       --  For now don't bother with case of identical constraints, to be
13119       --  fiddled with later on perhaps (this is only used for optimization
13120       --  purposes, so it is not critical to do a best possible job)
13121
13122       else
13123          return False;
13124       end if;
13125    end Same_Type;
13126
13127    ----------------
13128    -- Same_Value --
13129    ----------------
13130
13131    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
13132    begin
13133       if Compile_Time_Known_Value (Node1)
13134         and then Compile_Time_Known_Value (Node2)
13135         and then Expr_Value (Node1) = Expr_Value (Node2)
13136       then
13137          return True;
13138       elsif Same_Object (Node1, Node2) then
13139          return True;
13140       else
13141          return False;
13142       end if;
13143    end Same_Value;
13144
13145    ------------------------
13146    -- Scope_Is_Transient --
13147    ------------------------
13148
13149    function Scope_Is_Transient return Boolean is
13150    begin
13151       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
13152    end Scope_Is_Transient;
13153
13154    ------------------
13155    -- Scope_Within --
13156    ------------------
13157
13158    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
13159       Scop : Entity_Id;
13160
13161    begin
13162       Scop := Scope1;
13163       while Scop /= Standard_Standard loop
13164          Scop := Scope (Scop);
13165
13166          if Scop = Scope2 then
13167             return True;
13168          end if;
13169       end loop;
13170
13171       return False;
13172    end Scope_Within;
13173
13174    --------------------------
13175    -- Scope_Within_Or_Same --
13176    --------------------------
13177
13178    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
13179       Scop : Entity_Id;
13180
13181    begin
13182       Scop := Scope1;
13183       while Scop /= Standard_Standard loop
13184          if Scop = Scope2 then
13185             return True;
13186          else
13187             Scop := Scope (Scop);
13188          end if;
13189       end loop;
13190
13191       return False;
13192    end Scope_Within_Or_Same;
13193
13194    --------------------
13195    -- Set_Convention --
13196    --------------------
13197
13198    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
13199    begin
13200       Basic_Set_Convention (E, Val);
13201
13202       if Is_Type (E)
13203         and then Is_Access_Subprogram_Type (Base_Type (E))
13204         and then Has_Foreign_Convention (E)
13205       then
13206          Set_Can_Use_Internal_Rep (E, False);
13207       end if;
13208    end Set_Convention;
13209
13210    ------------------------
13211    -- Set_Current_Entity --
13212    ------------------------
13213
13214    --  The given entity is to be set as the currently visible definition of its
13215    --  associated name (i.e. the Node_Id associated with its name). All we have
13216    --  to do is to get the name from the identifier, and then set the
13217    --  associated Node_Id to point to the given entity.
13218
13219    procedure Set_Current_Entity (E : Entity_Id) is
13220    begin
13221       Set_Name_Entity_Id (Chars (E), E);
13222    end Set_Current_Entity;
13223
13224    ---------------------------
13225    -- Set_Debug_Info_Needed --
13226    ---------------------------
13227
13228    procedure Set_Debug_Info_Needed (T : Entity_Id) is
13229
13230       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
13231       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
13232       --  Used to set debug info in a related node if not set already
13233
13234       --------------------------------------
13235       -- Set_Debug_Info_Needed_If_Not_Set --
13236       --------------------------------------
13237
13238       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
13239       begin
13240          if Present (E)
13241            and then not Needs_Debug_Info (E)
13242          then
13243             Set_Debug_Info_Needed (E);
13244
13245             --  For a private type, indicate that the full view also needs
13246             --  debug information.
13247
13248             if Is_Type (E)
13249               and then Is_Private_Type (E)
13250               and then Present (Full_View (E))
13251             then
13252                Set_Debug_Info_Needed (Full_View (E));
13253             end if;
13254          end if;
13255       end Set_Debug_Info_Needed_If_Not_Set;
13256
13257    --  Start of processing for Set_Debug_Info_Needed
13258
13259    begin
13260       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
13261       --  indicates that Debug_Info_Needed is never required for the entity.
13262
13263       if No (T)
13264         or else Debug_Info_Off (T)
13265       then
13266          return;
13267       end if;
13268
13269       --  Set flag in entity itself. Note that we will go through the following
13270       --  circuitry even if the flag is already set on T. That's intentional,
13271       --  it makes sure that the flag will be set in subsidiary entities.
13272
13273       Set_Needs_Debug_Info (T);
13274
13275       --  Set flag on subsidiary entities if not set already
13276
13277       if Is_Object (T) then
13278          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
13279
13280       elsif Is_Type (T) then
13281          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
13282
13283          if Is_Record_Type (T) then
13284             declare
13285                Ent : Entity_Id := First_Entity (T);
13286             begin
13287                while Present (Ent) loop
13288                   Set_Debug_Info_Needed_If_Not_Set (Ent);
13289                   Next_Entity (Ent);
13290                end loop;
13291             end;
13292
13293             --  For a class wide subtype, we also need debug information
13294             --  for the equivalent type.
13295
13296             if Ekind (T) = E_Class_Wide_Subtype then
13297                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
13298             end if;
13299
13300          elsif Is_Array_Type (T) then
13301             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
13302
13303             declare
13304                Indx : Node_Id := First_Index (T);
13305             begin
13306                while Present (Indx) loop
13307                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
13308                   Indx := Next_Index (Indx);
13309                end loop;
13310             end;
13311
13312             --  For a packed array type, we also need debug information for
13313             --  the type used to represent the packed array. Conversely, we
13314             --  also need it for the former if we need it for the latter.
13315
13316             if Is_Packed (T) then
13317                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
13318             end if;
13319
13320             if Is_Packed_Array_Type (T) then
13321                Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
13322             end if;
13323
13324          elsif Is_Access_Type (T) then
13325             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
13326
13327          elsif Is_Private_Type (T) then
13328             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
13329
13330          elsif Is_Protected_Type (T) then
13331             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
13332          end if;
13333       end if;
13334    end Set_Debug_Info_Needed;
13335
13336    ---------------------------------
13337    -- Set_Entity_With_Style_Check --
13338    ---------------------------------
13339
13340    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
13341       Val_Actual : Entity_Id;
13342       Nod        : Node_Id;
13343
13344    begin
13345       --  Unconditionally set the entity
13346
13347       Set_Entity (N, Val);
13348
13349       --  Check for No_Implementation_Identifiers
13350
13351       if Restriction_Check_Required (No_Implementation_Identifiers) then
13352
13353          --  We have an implementation defined entity if it is marked as
13354          --  implementation defined, or is defined in a package marked as
13355          --  implementation defined. However, library packages themselves
13356          --  are excluded (we don't want to flag Interfaces itself, just
13357          --  the entities within it).
13358
13359          if (Is_Implementation_Defined (Val)
13360               and then not (Ekind_In (Val, E_Package, E_Generic_Package)
13361                               and then Is_Library_Level_Entity (Val)))
13362            or else Is_Implementation_Defined (Scope (Val))
13363          then
13364             Check_Restriction (No_Implementation_Identifiers, N);
13365          end if;
13366       end if;
13367
13368       --  Do the style check
13369
13370       if Style_Check
13371         and then not Suppress_Style_Checks (Val)
13372         and then not In_Instance
13373       then
13374          if Nkind (N) = N_Identifier then
13375             Nod := N;
13376          elsif Nkind (N) = N_Expanded_Name then
13377             Nod := Selector_Name (N);
13378          else
13379             return;
13380          end if;
13381
13382          --  A special situation arises for derived operations, where we want
13383          --  to do the check against the parent (since the Sloc of the derived
13384          --  operation points to the derived type declaration itself).
13385
13386          Val_Actual := Val;
13387          while not Comes_From_Source (Val_Actual)
13388            and then Nkind (Val_Actual) in N_Entity
13389            and then (Ekind (Val_Actual) = E_Enumeration_Literal
13390                       or else Is_Subprogram (Val_Actual)
13391                       or else Is_Generic_Subprogram (Val_Actual))
13392            and then Present (Alias (Val_Actual))
13393          loop
13394             Val_Actual := Alias (Val_Actual);
13395          end loop;
13396
13397          --  Renaming declarations for generic actuals do not come from source,
13398          --  and have a different name from that of the entity they rename, so
13399          --  there is no style check to perform here.
13400
13401          if Chars (Nod) = Chars (Val_Actual) then
13402             Style.Check_Identifier (Nod, Val_Actual);
13403          end if;
13404       end if;
13405
13406       Set_Entity (N, Val);
13407    end Set_Entity_With_Style_Check;
13408
13409    ------------------------
13410    -- Set_Name_Entity_Id --
13411    ------------------------
13412
13413    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
13414    begin
13415       Set_Name_Table_Info (Id, Int (Val));
13416    end Set_Name_Entity_Id;
13417
13418    ---------------------
13419    -- Set_Next_Actual --
13420    ---------------------
13421
13422    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
13423    begin
13424       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
13425          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
13426       end if;
13427    end Set_Next_Actual;
13428
13429    ----------------------------------
13430    -- Set_Optimize_Alignment_Flags --
13431    ----------------------------------
13432
13433    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
13434    begin
13435       if Optimize_Alignment = 'S' then
13436          Set_Optimize_Alignment_Space (E);
13437       elsif Optimize_Alignment = 'T' then
13438          Set_Optimize_Alignment_Time (E);
13439       end if;
13440    end Set_Optimize_Alignment_Flags;
13441
13442    -----------------------
13443    -- Set_Public_Status --
13444    -----------------------
13445
13446    procedure Set_Public_Status (Id : Entity_Id) is
13447       S : constant Entity_Id := Current_Scope;
13448
13449       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
13450       --  Determines if E is defined within handled statement sequence or
13451       --  an if statement, returns True if so, False otherwise.
13452
13453       ----------------------
13454       -- Within_HSS_Or_If --
13455       ----------------------
13456
13457       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
13458          N : Node_Id;
13459       begin
13460          N := Declaration_Node (E);
13461          loop
13462             N := Parent (N);
13463
13464             if No (N) then
13465                return False;
13466
13467             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
13468                                N_If_Statement)
13469             then
13470                return True;
13471             end if;
13472          end loop;
13473       end Within_HSS_Or_If;
13474
13475    --  Start of processing for Set_Public_Status
13476
13477    begin
13478       --  Everything in the scope of Standard is public
13479
13480       if S = Standard_Standard then
13481          Set_Is_Public (Id);
13482
13483       --  Entity is definitely not public if enclosing scope is not public
13484
13485       elsif not Is_Public (S) then
13486          return;
13487
13488       --  An object or function declaration that occurs in a handled sequence
13489       --  of statements or within an if statement is the declaration for a
13490       --  temporary object or local subprogram generated by the expander. It
13491       --  never needs to be made public and furthermore, making it public can
13492       --  cause back end problems.
13493
13494       elsif Nkind_In (Parent (Id), N_Object_Declaration,
13495                                    N_Function_Specification)
13496         and then Within_HSS_Or_If (Id)
13497       then
13498          return;
13499
13500       --  Entities in public packages or records are public
13501
13502       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
13503          Set_Is_Public (Id);
13504
13505       --  The bounds of an entry family declaration can generate object
13506       --  declarations that are visible to the back-end, e.g. in the
13507       --  the declaration of a composite type that contains tasks.
13508
13509       elsif Is_Concurrent_Type (S)
13510         and then not Has_Completion (S)
13511         and then Nkind (Parent (Id)) = N_Object_Declaration
13512       then
13513          Set_Is_Public (Id);
13514       end if;
13515    end Set_Public_Status;
13516
13517    -----------------------------
13518    -- Set_Referenced_Modified --
13519    -----------------------------
13520
13521    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
13522       Pref : Node_Id;
13523
13524    begin
13525       --  Deal with indexed or selected component where prefix is modified
13526
13527       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
13528          Pref := Prefix (N);
13529
13530          --  If prefix is access type, then it is the designated object that is
13531          --  being modified, which means we have no entity to set the flag on.
13532
13533          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
13534             return;
13535
13536             --  Otherwise chase the prefix
13537
13538          else
13539             Set_Referenced_Modified (Pref, Out_Param);
13540          end if;
13541
13542       --  Otherwise see if we have an entity name (only other case to process)
13543
13544       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
13545          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
13546          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
13547       end if;
13548    end Set_Referenced_Modified;
13549
13550    ----------------------------
13551    -- Set_Scope_Is_Transient --
13552    ----------------------------
13553
13554    procedure Set_Scope_Is_Transient (V : Boolean := True) is
13555    begin
13556       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
13557    end Set_Scope_Is_Transient;
13558
13559    -------------------
13560    -- Set_Size_Info --
13561    -------------------
13562
13563    procedure Set_Size_Info (T1, T2 : Entity_Id) is
13564    begin
13565       --  We copy Esize, but not RM_Size, since in general RM_Size is
13566       --  subtype specific and does not get inherited by all subtypes.
13567
13568       Set_Esize                     (T1, Esize                     (T2));
13569       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
13570
13571       if Is_Discrete_Or_Fixed_Point_Type (T1)
13572            and then
13573          Is_Discrete_Or_Fixed_Point_Type (T2)
13574       then
13575          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
13576       end if;
13577
13578       Set_Alignment                 (T1, Alignment                 (T2));
13579    end Set_Size_Info;
13580
13581    --------------------
13582    -- Static_Boolean --
13583    --------------------
13584
13585    function Static_Boolean (N : Node_Id) return Uint is
13586    begin
13587       Analyze_And_Resolve (N, Standard_Boolean);
13588
13589       if N = Error
13590         or else Error_Posted (N)
13591         or else Etype (N) = Any_Type
13592       then
13593          return No_Uint;
13594       end if;
13595
13596       if Is_Static_Expression (N) then
13597          if not Raises_Constraint_Error (N) then
13598             return Expr_Value (N);
13599          else
13600             return No_Uint;
13601          end if;
13602
13603       elsif Etype (N) = Any_Type then
13604          return No_Uint;
13605
13606       else
13607          Flag_Non_Static_Expr
13608            ("static boolean expression required here", N);
13609          return No_Uint;
13610       end if;
13611    end Static_Boolean;
13612
13613    --------------------
13614    -- Static_Integer --
13615    --------------------
13616
13617    function Static_Integer (N : Node_Id) return Uint is
13618    begin
13619       Analyze_And_Resolve (N, Any_Integer);
13620
13621       if N = Error
13622         or else Error_Posted (N)
13623         or else Etype (N) = Any_Type
13624       then
13625          return No_Uint;
13626       end if;
13627
13628       if Is_Static_Expression (N) then
13629          if not Raises_Constraint_Error (N) then
13630             return Expr_Value (N);
13631          else
13632             return No_Uint;
13633          end if;
13634
13635       elsif Etype (N) = Any_Type then
13636          return No_Uint;
13637
13638       else
13639          Flag_Non_Static_Expr
13640            ("static integer expression required here", N);
13641          return No_Uint;
13642       end if;
13643    end Static_Integer;
13644
13645    --------------------------
13646    -- Statically_Different --
13647    --------------------------
13648
13649    function Statically_Different (E1, E2 : Node_Id) return Boolean is
13650       R1 : constant Node_Id := Get_Referenced_Object (E1);
13651       R2 : constant Node_Id := Get_Referenced_Object (E2);
13652    begin
13653       return     Is_Entity_Name (R1)
13654         and then Is_Entity_Name (R2)
13655         and then Entity (R1) /= Entity (R2)
13656         and then not Is_Formal (Entity (R1))
13657         and then not Is_Formal (Entity (R2));
13658    end Statically_Different;
13659
13660    -----------------------------
13661    -- Subprogram_Access_Level --
13662    -----------------------------
13663
13664    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
13665    begin
13666       if Present (Alias (Subp)) then
13667          return Subprogram_Access_Level (Alias (Subp));
13668       else
13669          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
13670       end if;
13671    end Subprogram_Access_Level;
13672
13673    -------------------------------
13674    -- Support_Atomic_Primitives --
13675    -------------------------------
13676
13677    function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
13678       Size : Int;
13679
13680    begin
13681       --  Verify the alignment of Typ is known
13682
13683       if not Known_Alignment (Typ) then
13684          return False;
13685       end if;
13686
13687       if Known_Static_Esize (Typ) then
13688          Size := UI_To_Int (Esize (Typ));
13689
13690       --  If the Esize (Object_Size) is unknown at compile-time, look at the
13691       --  RM_Size (Value_Size) since it may have been set by an explicit rep
13692       --  item.
13693
13694       elsif Known_Static_RM_Size (Typ) then
13695          Size := UI_To_Int (RM_Size (Typ));
13696
13697       --  Otherwise, the size is considered to be unknown.
13698
13699       else
13700          return False;
13701       end if;
13702
13703       --  Check that the size of the component is 8, 16, 32 or 64 bits and that
13704       --  Typ is properly aligned.
13705
13706       case Size is
13707          when 8 | 16 | 32 | 64 =>
13708             return Size = UI_To_Int (Alignment (Typ)) * 8;
13709          when others           =>
13710             return False;
13711       end case;
13712    end Support_Atomic_Primitives;
13713
13714    -----------------
13715    -- Trace_Scope --
13716    -----------------
13717
13718    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
13719    begin
13720       if Debug_Flag_W then
13721          for J in 0 .. Scope_Stack.Last loop
13722             Write_Str ("  ");
13723          end loop;
13724
13725          Write_Str (Msg);
13726          Write_Name (Chars (E));
13727          Write_Str (" from ");
13728          Write_Location (Sloc (N));
13729          Write_Eol;
13730       end if;
13731    end Trace_Scope;
13732
13733    -----------------------
13734    -- Transfer_Entities --
13735    -----------------------
13736
13737    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
13738       Ent : Entity_Id := First_Entity (From);
13739
13740    begin
13741       if No (Ent) then
13742          return;
13743       end if;
13744
13745       if (Last_Entity (To)) = Empty then
13746          Set_First_Entity (To, Ent);
13747       else
13748          Set_Next_Entity (Last_Entity (To), Ent);
13749       end if;
13750
13751       Set_Last_Entity (To, Last_Entity (From));
13752
13753       while Present (Ent) loop
13754          Set_Scope (Ent, To);
13755
13756          if not Is_Public (Ent) then
13757             Set_Public_Status (Ent);
13758
13759             if Is_Public (Ent)
13760               and then Ekind (Ent) = E_Record_Subtype
13761
13762             then
13763                --  The components of the propagated Itype must be public
13764                --  as well.
13765
13766                declare
13767                   Comp : Entity_Id;
13768                begin
13769                   Comp := First_Entity (Ent);
13770                   while Present (Comp) loop
13771                      Set_Is_Public (Comp);
13772                      Next_Entity (Comp);
13773                   end loop;
13774                end;
13775             end if;
13776          end if;
13777
13778          Next_Entity (Ent);
13779       end loop;
13780
13781       Set_First_Entity (From, Empty);
13782       Set_Last_Entity (From, Empty);
13783    end Transfer_Entities;
13784
13785    -----------------------
13786    -- Type_Access_Level --
13787    -----------------------
13788
13789    function Type_Access_Level (Typ : Entity_Id) return Uint is
13790       Btyp : Entity_Id;
13791
13792    begin
13793       Btyp := Base_Type (Typ);
13794
13795       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
13796       --  simply use the level where the type is declared. This is true for
13797       --  stand-alone object declarations, and for anonymous access types
13798       --  associated with components the level is the same as that of the
13799       --  enclosing composite type. However, special treatment is needed for
13800       --  the cases of access parameters, return objects of an anonymous access
13801       --  type, and, in Ada 95, access discriminants of limited types.
13802
13803       if Ekind (Btyp) in Access_Kind then
13804          if Ekind (Btyp) = E_Anonymous_Access_Type then
13805
13806             --  If the type is a nonlocal anonymous access type (such as for
13807             --  an access parameter) we treat it as being declared at the
13808             --  library level to ensure that names such as X.all'access don't
13809             --  fail static accessibility checks.
13810
13811             if not Is_Local_Anonymous_Access (Typ) then
13812                return Scope_Depth (Standard_Standard);
13813
13814             --  If this is a return object, the accessibility level is that of
13815             --  the result subtype of the enclosing function. The test here is
13816             --  little complicated, because we have to account for extended
13817             --  return statements that have been rewritten as blocks, in which
13818             --  case we have to find and the Is_Return_Object attribute of the
13819             --  itype's associated object. It would be nice to find a way to
13820             --  simplify this test, but it doesn't seem worthwhile to add a new
13821             --  flag just for purposes of this test. ???
13822
13823             elsif Ekind (Scope (Btyp)) = E_Return_Statement
13824               or else
13825                 (Is_Itype (Btyp)
13826                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
13827                              N_Object_Declaration
13828                   and then Is_Return_Object
13829                              (Defining_Identifier
13830                                 (Associated_Node_For_Itype (Btyp))))
13831             then
13832                declare
13833                   Scop : Entity_Id;
13834
13835                begin
13836                   Scop := Scope (Scope (Btyp));
13837                   while Present (Scop) loop
13838                      exit when Ekind (Scop) = E_Function;
13839                      Scop := Scope (Scop);
13840                   end loop;
13841
13842                   --  Treat the return object's type as having the level of the
13843                   --  function's result subtype (as per RM05-6.5(5.3/2)).
13844
13845                   return Type_Access_Level (Etype (Scop));
13846                end;
13847             end if;
13848          end if;
13849
13850          Btyp := Root_Type (Btyp);
13851
13852          --  The accessibility level of anonymous access types associated with
13853          --  discriminants is that of the current instance of the type, and
13854          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
13855
13856          --  AI-402: access discriminants have accessibility based on the
13857          --  object rather than the type in Ada 2005, so the above paragraph
13858          --  doesn't apply.
13859
13860          --  ??? Needs completion with rules from AI-416
13861
13862          if Ada_Version <= Ada_95
13863            and then Ekind (Typ) = E_Anonymous_Access_Type
13864            and then Present (Associated_Node_For_Itype (Typ))
13865            and then Nkind (Associated_Node_For_Itype (Typ)) =
13866                                                  N_Discriminant_Specification
13867          then
13868             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
13869          end if;
13870       end if;
13871
13872       --  Return library level for a generic formal type. This is done because
13873       --  RM(10.3.2) says that "The statically deeper relationship does not
13874       --  apply to ... a descendant of a generic formal type". Rather than
13875       --  checking at each point where a static accessibility check is
13876       --  performed to see if we are dealing with a formal type, this rule is
13877       --  implemented by having Type_Access_Level and Deepest_Type_Access_Level
13878       --  return extreme values for a formal type; Deepest_Type_Access_Level
13879       --  returns Int'Last. By calling the appropriate function from among the
13880       --  two, we ensure that the static accessibility check will pass if we
13881       --  happen to run into a formal type. More specifically, we should call
13882       --  Deepest_Type_Access_Level instead of Type_Access_Level whenever the
13883       --  call occurs as part of a static accessibility check and the error
13884       --  case is the case where the type's level is too shallow (as opposed
13885       --  to too deep).
13886
13887       if Is_Generic_Type (Root_Type (Btyp)) then
13888          return Scope_Depth (Standard_Standard);
13889       end if;
13890
13891       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
13892    end Type_Access_Level;
13893
13894    ------------------------------------
13895    -- Type_Without_Stream_Operation  --
13896    ------------------------------------
13897
13898    function Type_Without_Stream_Operation
13899      (T  : Entity_Id;
13900       Op : TSS_Name_Type := TSS_Null) return Entity_Id
13901    is
13902       BT         : constant Entity_Id := Base_Type (T);
13903       Op_Missing : Boolean;
13904
13905    begin
13906       if not Restriction_Active (No_Default_Stream_Attributes) then
13907          return Empty;
13908       end if;
13909
13910       if Is_Elementary_Type (T) then
13911          if Op = TSS_Null then
13912             Op_Missing :=
13913               No (TSS (BT, TSS_Stream_Read))
13914                 or else No (TSS (BT, TSS_Stream_Write));
13915
13916          else
13917             Op_Missing := No (TSS (BT, Op));
13918          end if;
13919
13920          if Op_Missing then
13921             return T;
13922          else
13923             return Empty;
13924          end if;
13925
13926       elsif Is_Array_Type (T) then
13927          return Type_Without_Stream_Operation (Component_Type (T), Op);
13928
13929       elsif Is_Record_Type (T) then
13930          declare
13931             Comp  : Entity_Id;
13932             C_Typ : Entity_Id;
13933
13934          begin
13935             Comp := First_Component (T);
13936             while Present (Comp) loop
13937                C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
13938
13939                if Present (C_Typ) then
13940                   return C_Typ;
13941                end if;
13942
13943                Next_Component (Comp);
13944             end loop;
13945
13946             return Empty;
13947          end;
13948
13949       elsif Is_Private_Type (T)
13950         and then Present (Full_View (T))
13951       then
13952          return Type_Without_Stream_Operation (Full_View (T), Op);
13953       else
13954          return Empty;
13955       end if;
13956    end Type_Without_Stream_Operation;
13957
13958    ----------------------------
13959    -- Unique_Defining_Entity --
13960    ----------------------------
13961
13962    function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
13963    begin
13964       return Unique_Entity (Defining_Entity (N));
13965    end Unique_Defining_Entity;
13966
13967    -------------------
13968    -- Unique_Entity --
13969    -------------------
13970
13971    function Unique_Entity (E : Entity_Id) return Entity_Id is
13972       U : Entity_Id := E;
13973       P : Node_Id;
13974
13975    begin
13976       case Ekind (E) is
13977          when E_Constant =>
13978             if Present (Full_View (E)) then
13979                U := Full_View (E);
13980             end if;
13981
13982          when Type_Kind =>
13983             if Present (Full_View (E)) then
13984                U := Full_View (E);
13985             end if;
13986
13987          when E_Package_Body =>
13988             P := Parent (E);
13989
13990             if Nkind (P) = N_Defining_Program_Unit_Name then
13991                P := Parent (P);
13992             end if;
13993
13994             U := Corresponding_Spec (P);
13995
13996          when E_Subprogram_Body =>
13997             P := Parent (E);
13998
13999             if Nkind (P) = N_Defining_Program_Unit_Name then
14000                P := Parent (P);
14001             end if;
14002
14003             P := Parent (P);
14004
14005             if Nkind (P) = N_Subprogram_Body_Stub then
14006                if Present (Library_Unit (P)) then
14007
14008                   --  Get to the function or procedure (generic) entity through
14009                   --  the body entity.
14010
14011                   U :=
14012                     Unique_Entity (Defining_Entity (Get_Body_From_Stub (P)));
14013                end if;
14014             else
14015                U := Corresponding_Spec (P);
14016             end if;
14017
14018          when Formal_Kind =>
14019             if Present (Spec_Entity (E)) then
14020                U := Spec_Entity (E);
14021             end if;
14022
14023          when others =>
14024             null;
14025       end case;
14026
14027       return U;
14028    end Unique_Entity;
14029
14030    -----------------
14031    -- Unique_Name --
14032    -----------------
14033
14034    function Unique_Name (E : Entity_Id) return String is
14035
14036       --  Names of E_Subprogram_Body or E_Package_Body entities are not
14037       --  reliable, as they may not include the overloading suffix. Instead,
14038       --  when looking for the name of E or one of its enclosing scope, we get
14039       --  the name of the corresponding Unique_Entity.
14040
14041       function Get_Scoped_Name (E : Entity_Id) return String;
14042       --  Return the name of E prefixed by all the names of the scopes to which
14043       --  E belongs, except for Standard.
14044
14045       ---------------------
14046       -- Get_Scoped_Name --
14047       ---------------------
14048
14049       function Get_Scoped_Name (E : Entity_Id) return String is
14050          Name : constant String := Get_Name_String (Chars (E));
14051       begin
14052          if Has_Fully_Qualified_Name (E)
14053            or else Scope (E) = Standard_Standard
14054          then
14055             return Name;
14056          else
14057             return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
14058          end if;
14059       end Get_Scoped_Name;
14060
14061    --  Start of processing for Unique_Name
14062
14063    begin
14064       if E = Standard_Standard then
14065          return Get_Name_String (Name_Standard);
14066
14067       elsif Scope (E) = Standard_Standard
14068         and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
14069       then
14070          return Get_Name_String (Name_Standard) & "__" &
14071            Get_Name_String (Chars (E));
14072
14073       elsif Ekind (E) = E_Enumeration_Literal then
14074          return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
14075
14076       else
14077          return Get_Scoped_Name (Unique_Entity (E));
14078       end if;
14079    end Unique_Name;
14080
14081    ---------------------
14082    -- Unit_Is_Visible --
14083    ---------------------
14084
14085    function Unit_Is_Visible (U : Entity_Id) return Boolean is
14086       Curr        : constant Node_Id   := Cunit (Current_Sem_Unit);
14087       Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
14088
14089       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
14090       --  For a child unit, check whether unit appears in a with_clause
14091       --  of a parent.
14092
14093       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
14094       --  Scan the context clause of one compilation unit looking for a
14095       --  with_clause for the unit in question.
14096
14097       ----------------------------
14098       -- Unit_In_Parent_Context --
14099       ----------------------------
14100
14101       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
14102       begin
14103          if Unit_In_Context (Par_Unit) then
14104             return True;
14105
14106          elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
14107             return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
14108
14109          else
14110             return False;
14111          end if;
14112       end Unit_In_Parent_Context;
14113
14114       ---------------------
14115       -- Unit_In_Context --
14116       ---------------------
14117
14118       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
14119          Clause : Node_Id;
14120
14121       begin
14122          Clause := First (Context_Items (Comp_Unit));
14123          while Present (Clause) loop
14124             if Nkind (Clause) = N_With_Clause then
14125                if Library_Unit (Clause) = U then
14126                   return True;
14127
14128                --  The with_clause may denote a renaming of the unit we are
14129                --  looking for, eg. Text_IO which renames Ada.Text_IO.
14130
14131                elsif
14132                  Renamed_Entity (Entity (Name (Clause))) =
14133                                                 Defining_Entity (Unit (U))
14134                then
14135                   return True;
14136                end if;
14137             end if;
14138
14139             Next (Clause);
14140          end loop;
14141
14142          return False;
14143       end Unit_In_Context;
14144
14145    --  Start of processing for Unit_Is_Visible
14146
14147    begin
14148       --  The currrent unit is directly visible
14149
14150       if Curr = U then
14151          return True;
14152
14153       elsif Unit_In_Context (Curr) then
14154          return True;
14155
14156       --  If the current unit is a body, check the context of the spec
14157
14158       elsif Nkind (Unit (Curr)) = N_Package_Body
14159         or else
14160           (Nkind (Unit (Curr)) = N_Subprogram_Body
14161             and then not Acts_As_Spec (Unit (Curr)))
14162       then
14163          if Unit_In_Context (Library_Unit (Curr)) then
14164             return True;
14165          end if;
14166       end if;
14167
14168       --  If the spec is a child unit, examine the parents
14169
14170       if Is_Child_Unit (Curr_Entity) then
14171          if Nkind (Unit (Curr)) in N_Unit_Body then
14172             return
14173               Unit_In_Parent_Context
14174                 (Parent_Spec (Unit (Library_Unit (Curr))));
14175          else
14176             return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
14177          end if;
14178
14179       else
14180          return False;
14181       end if;
14182    end Unit_Is_Visible;
14183
14184    ------------------------------
14185    -- Universal_Interpretation --
14186    ------------------------------
14187
14188    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
14189       Index : Interp_Index;
14190       It    : Interp;
14191
14192    begin
14193       --  The argument may be a formal parameter of an operator or subprogram
14194       --  with multiple interpretations, or else an expression for an actual.
14195
14196       if Nkind (Opnd) = N_Defining_Identifier
14197         or else not Is_Overloaded (Opnd)
14198       then
14199          if Etype (Opnd) = Universal_Integer
14200            or else Etype (Opnd) = Universal_Real
14201          then
14202             return Etype (Opnd);
14203          else
14204             return Empty;
14205          end if;
14206
14207       else
14208          Get_First_Interp (Opnd, Index, It);
14209          while Present (It.Typ) loop
14210             if It.Typ = Universal_Integer
14211               or else It.Typ = Universal_Real
14212             then
14213                return It.Typ;
14214             end if;
14215
14216             Get_Next_Interp (Index, It);
14217          end loop;
14218
14219          return Empty;
14220       end if;
14221    end Universal_Interpretation;
14222
14223    ---------------
14224    -- Unqualify --
14225    ---------------
14226
14227    function Unqualify (Expr : Node_Id) return Node_Id is
14228    begin
14229       --  Recurse to handle unlikely case of multiple levels of qualification
14230
14231       if Nkind (Expr) = N_Qualified_Expression then
14232          return Unqualify (Expression (Expr));
14233
14234       --  Normal case, not a qualified expression
14235
14236       else
14237          return Expr;
14238       end if;
14239    end Unqualify;
14240
14241    -----------------------
14242    -- Visible_Ancestors --
14243    -----------------------
14244
14245    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
14246       List_1 : Elist_Id;
14247       List_2 : Elist_Id;
14248       Elmt   : Elmt_Id;
14249
14250    begin
14251       pragma Assert (Is_Record_Type (Typ)
14252         and then Is_Tagged_Type (Typ));
14253
14254       --  Collect all the parents and progenitors of Typ. If the full-view of
14255       --  private parents and progenitors is available then it is used to
14256       --  generate the list of visible ancestors; otherwise their partial
14257       --  view is added to the resulting list.
14258
14259       Collect_Parents
14260         (T               => Typ,
14261          List            => List_1,
14262          Use_Full_View   => True);
14263
14264       Collect_Interfaces
14265         (T               => Typ,
14266          Ifaces_List     => List_2,
14267          Exclude_Parents => True,
14268          Use_Full_View   => True);
14269
14270       --  Join the two lists. Avoid duplications because an interface may
14271       --  simultaneously be parent and progenitor of a type.
14272
14273       Elmt := First_Elmt (List_2);
14274       while Present (Elmt) loop
14275          Append_Unique_Elmt (Node (Elmt), List_1);
14276          Next_Elmt (Elmt);
14277       end loop;
14278
14279       return List_1;
14280    end Visible_Ancestors;
14281
14282    ----------------------
14283    -- Within_Init_Proc --
14284    ----------------------
14285
14286    function Within_Init_Proc return Boolean is
14287       S : Entity_Id;
14288
14289    begin
14290       S := Current_Scope;
14291       while not Is_Overloadable (S) loop
14292          if S = Standard_Standard then
14293             return False;
14294          else
14295             S := Scope (S);
14296          end if;
14297       end loop;
14298
14299       return Is_Init_Proc (S);
14300    end Within_Init_Proc;
14301
14302    ----------------
14303    -- Wrong_Type --
14304    ----------------
14305
14306    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
14307       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
14308       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
14309
14310       Matching_Field : Entity_Id;
14311       --  Entity to give a more precise suggestion on how to write a one-
14312       --  element positional aggregate.
14313
14314       function Has_One_Matching_Field return Boolean;
14315       --  Determines if Expec_Type is a record type with a single component or
14316       --  discriminant whose type matches the found type or is one dimensional
14317       --  array whose component type matches the found type. In the case of
14318       --  one discriminant, we ignore the variant parts. That's not accurate,
14319       --  but good enough for the warning.
14320
14321       ----------------------------
14322       -- Has_One_Matching_Field --
14323       ----------------------------
14324
14325       function Has_One_Matching_Field return Boolean is
14326          E : Entity_Id;
14327
14328       begin
14329          Matching_Field := Empty;
14330
14331          if Is_Array_Type (Expec_Type)
14332            and then Number_Dimensions (Expec_Type) = 1
14333            and then
14334              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
14335          then
14336             --  Use type name if available. This excludes multidimensional
14337             --  arrays and anonymous arrays.
14338
14339             if Comes_From_Source (Expec_Type) then
14340                Matching_Field := Expec_Type;
14341
14342             --  For an assignment, use name of target
14343
14344             elsif Nkind (Parent (Expr)) = N_Assignment_Statement
14345               and then Is_Entity_Name (Name (Parent (Expr)))
14346             then
14347                Matching_Field := Entity (Name (Parent (Expr)));
14348             end if;
14349
14350             return True;
14351
14352          elsif not Is_Record_Type (Expec_Type) then
14353             return False;
14354
14355          else
14356             E := First_Entity (Expec_Type);
14357             loop
14358                if No (E) then
14359                   return False;
14360
14361                elsif not Ekind_In (E, E_Discriminant, E_Component)
14362                  or else (Chars (E) = Name_uTag
14363                             or else
14364                           Chars (E) = Name_uParent)
14365                then
14366                   Next_Entity (E);
14367
14368                else
14369                   exit;
14370                end if;
14371             end loop;
14372
14373             if not Covers (Etype (E), Found_Type) then
14374                return False;
14375
14376             elsif Present (Next_Entity (E))
14377               and then (Ekind (E) = E_Component
14378                          or else Ekind (Next_Entity (E)) = E_Discriminant)
14379             then
14380                return False;
14381
14382             else
14383                Matching_Field := E;
14384                return True;
14385             end if;
14386          end if;
14387       end Has_One_Matching_Field;
14388
14389    --  Start of processing for Wrong_Type
14390
14391    begin
14392       --  Don't output message if either type is Any_Type, or if a message
14393       --  has already been posted for this node. We need to do the latter
14394       --  check explicitly (it is ordinarily done in Errout), because we
14395       --  are using ! to force the output of the error messages.
14396
14397       if Expec_Type = Any_Type
14398         or else Found_Type = Any_Type
14399         or else Error_Posted (Expr)
14400       then
14401          return;
14402
14403       --  If one of the types is a Taft-Amendment type and the other it its
14404       --  completion, it must be an illegal use of a TAT in the spec, for
14405       --  which an error was already emitted. Avoid cascaded errors.
14406
14407       elsif Is_Incomplete_Type (Expec_Type)
14408         and then Has_Completion_In_Body (Expec_Type)
14409         and then Full_View (Expec_Type) = Etype (Expr)
14410       then
14411          return;
14412
14413       elsif Is_Incomplete_Type (Etype (Expr))
14414         and then Has_Completion_In_Body (Etype (Expr))
14415         and then Full_View (Etype (Expr)) = Expec_Type
14416       then
14417          return;
14418
14419       --  In  an instance, there is an ongoing problem with completion of
14420       --  type derived from private types. Their structure is what Gigi
14421       --  expects, but the  Etype is the parent type rather than the
14422       --  derived private type itself. Do not flag error in this case. The
14423       --  private completion is an entity without a parent, like an Itype.
14424       --  Similarly, full and partial views may be incorrect in the instance.
14425       --  There is no simple way to insure that it is consistent ???
14426
14427       elsif In_Instance then
14428          if Etype (Etype (Expr)) = Etype (Expected_Type)
14429            and then
14430              (Has_Private_Declaration (Expected_Type)
14431                or else Has_Private_Declaration (Etype (Expr)))
14432            and then No (Parent (Expected_Type))
14433          then
14434             return;
14435          end if;
14436       end if;
14437
14438       --  An interesting special check. If the expression is parenthesized
14439       --  and its type corresponds to the type of the sole component of the
14440       --  expected record type, or to the component type of the expected one
14441       --  dimensional array type, then assume we have a bad aggregate attempt.
14442
14443       if Nkind (Expr) in N_Subexpr
14444         and then Paren_Count (Expr) /= 0
14445         and then Has_One_Matching_Field
14446       then
14447          Error_Msg_N ("positional aggregate cannot have one component", Expr);
14448          if Present (Matching_Field) then
14449             if Is_Array_Type (Expec_Type) then
14450                Error_Msg_NE
14451                  ("\write instead `&''First ='> ...`", Expr, Matching_Field);
14452
14453             else
14454                Error_Msg_NE
14455                  ("\write instead `& ='> ...`", Expr, Matching_Field);
14456             end if;
14457          end if;
14458
14459       --  Another special check, if we are looking for a pool-specific access
14460       --  type and we found an E_Access_Attribute_Type, then we have the case
14461       --  of an Access attribute being used in a context which needs a pool-
14462       --  specific type, which is never allowed. The one extra check we make
14463       --  is that the expected designated type covers the Found_Type.
14464
14465       elsif Is_Access_Type (Expec_Type)
14466         and then Ekind (Found_Type) = E_Access_Attribute_Type
14467         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
14468         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
14469         and then Covers
14470           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
14471       then
14472          Error_Msg_N -- CODEFIX
14473            ("result must be general access type!", Expr);
14474          Error_Msg_NE -- CODEFIX
14475            ("add ALL to }!", Expr, Expec_Type);
14476
14477       --  Another special check, if the expected type is an integer type,
14478       --  but the expression is of type System.Address, and the parent is
14479       --  an addition or subtraction operation whose left operand is the
14480       --  expression in question and whose right operand is of an integral
14481       --  type, then this is an attempt at address arithmetic, so give
14482       --  appropriate message.
14483
14484       elsif Is_Integer_Type (Expec_Type)
14485         and then Is_RTE (Found_Type, RE_Address)
14486         and then (Nkind (Parent (Expr)) = N_Op_Add
14487                     or else
14488                   Nkind (Parent (Expr)) = N_Op_Subtract)
14489         and then Expr = Left_Opnd (Parent (Expr))
14490         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
14491       then
14492          Error_Msg_N
14493            ("address arithmetic not predefined in package System",
14494             Parent (Expr));
14495          Error_Msg_N
14496            ("\possible missing with/use of System.Storage_Elements",
14497             Parent (Expr));
14498          return;
14499
14500       --  If the expected type is an anonymous access type, as for access
14501       --  parameters and discriminants, the error is on the designated types.
14502
14503       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
14504          if Comes_From_Source (Expec_Type) then
14505             Error_Msg_NE ("expected}!", Expr, Expec_Type);
14506          else
14507             Error_Msg_NE
14508               ("expected an access type with designated}",
14509                  Expr, Designated_Type (Expec_Type));
14510          end if;
14511
14512          if Is_Access_Type (Found_Type)
14513            and then not Comes_From_Source (Found_Type)
14514          then
14515             Error_Msg_NE
14516               ("\\found an access type with designated}!",
14517                 Expr, Designated_Type (Found_Type));
14518          else
14519             if From_With_Type (Found_Type) then
14520                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
14521                Error_Msg_Qual_Level := 99;
14522                Error_Msg_NE -- CODEFIX
14523                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
14524                Error_Msg_Qual_Level := 0;
14525             else
14526                Error_Msg_NE ("found}!", Expr, Found_Type);
14527             end if;
14528          end if;
14529
14530       --  Normal case of one type found, some other type expected
14531
14532       else
14533          --  If the names of the two types are the same, see if some number
14534          --  of levels of qualification will help. Don't try more than three
14535          --  levels, and if we get to standard, it's no use (and probably
14536          --  represents an error in the compiler) Also do not bother with
14537          --  internal scope names.
14538
14539          declare
14540             Expec_Scope : Entity_Id;
14541             Found_Scope : Entity_Id;
14542
14543          begin
14544             Expec_Scope := Expec_Type;
14545             Found_Scope := Found_Type;
14546
14547             for Levels in Int range 0 .. 3 loop
14548                if Chars (Expec_Scope) /= Chars (Found_Scope) then
14549                   Error_Msg_Qual_Level := Levels;
14550                   exit;
14551                end if;
14552
14553                Expec_Scope := Scope (Expec_Scope);
14554                Found_Scope := Scope (Found_Scope);
14555
14556                exit when Expec_Scope = Standard_Standard
14557                  or else Found_Scope = Standard_Standard
14558                  or else not Comes_From_Source (Expec_Scope)
14559                  or else not Comes_From_Source (Found_Scope);
14560             end loop;
14561          end;
14562
14563          if Is_Record_Type (Expec_Type)
14564            and then Present (Corresponding_Remote_Type (Expec_Type))
14565          then
14566             Error_Msg_NE ("expected}!", Expr,
14567                           Corresponding_Remote_Type (Expec_Type));
14568          else
14569             Error_Msg_NE ("expected}!", Expr, Expec_Type);
14570          end if;
14571
14572          if Is_Entity_Name (Expr)
14573            and then Is_Package_Or_Generic_Package (Entity (Expr))
14574          then
14575             Error_Msg_N ("\\found package name!", Expr);
14576
14577          elsif Is_Entity_Name (Expr)
14578            and then
14579              (Ekind (Entity (Expr)) = E_Procedure
14580                 or else
14581               Ekind (Entity (Expr)) = E_Generic_Procedure)
14582          then
14583             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
14584                Error_Msg_N
14585                  ("found procedure name, possibly missing Access attribute!",
14586                    Expr);
14587             else
14588                Error_Msg_N
14589                  ("\\found procedure name instead of function!", Expr);
14590             end if;
14591
14592          elsif Nkind (Expr) = N_Function_Call
14593            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
14594            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
14595            and then No (Parameter_Associations (Expr))
14596          then
14597             Error_Msg_N
14598               ("found function name, possibly missing Access attribute!",
14599                Expr);
14600
14601          --  Catch common error: a prefix or infix operator which is not
14602          --  directly visible because the type isn't.
14603
14604          elsif Nkind (Expr) in N_Op
14605             and then Is_Overloaded (Expr)
14606             and then not Is_Immediately_Visible (Expec_Type)
14607             and then not Is_Potentially_Use_Visible (Expec_Type)
14608             and then not In_Use (Expec_Type)
14609             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
14610          then
14611             Error_Msg_N
14612               ("operator of the type is not directly visible!", Expr);
14613
14614          elsif Ekind (Found_Type) = E_Void
14615            and then Present (Parent (Found_Type))
14616            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
14617          then
14618             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
14619
14620          else
14621             Error_Msg_NE ("\\found}!", Expr, Found_Type);
14622          end if;
14623
14624          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
14625          --  of the same modular type, and (M1 and M2) = 0 was intended.
14626
14627          if Expec_Type = Standard_Boolean
14628            and then Is_Modular_Integer_Type (Found_Type)
14629            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
14630            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
14631          then
14632             declare
14633                Op : constant Node_Id := Right_Opnd (Parent (Expr));
14634                L  : constant Node_Id := Left_Opnd (Op);
14635                R  : constant Node_Id := Right_Opnd (Op);
14636             begin
14637                --  The case for the message is when the left operand of the
14638                --  comparison is the same modular type, or when it is an
14639                --  integer literal (or other universal integer expression),
14640                --  which would have been typed as the modular type if the
14641                --  parens had been there.
14642
14643                if (Etype (L) = Found_Type
14644                      or else
14645                    Etype (L) = Universal_Integer)
14646                  and then Is_Integer_Type (Etype (R))
14647                then
14648                   Error_Msg_N
14649                     ("\\possible missing parens for modular operation", Expr);
14650                end if;
14651             end;
14652          end if;
14653
14654          --  Reset error message qualification indication
14655
14656          Error_Msg_Qual_Level := 0;
14657       end if;
14658    end Wrong_Type;
14659
14660 end Sem_Util;