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