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-2006, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Checks;   use Checks;
  30 with Debug;    use Debug;
  31 with Errout;   use Errout;
  32 with Elists;   use Elists;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Exp_Util; use Exp_Util;
  35 with Fname;    use Fname;
  36 with Freeze;   use Freeze;
  37 with Lib;      use Lib;
  38 with Lib.Xref; use Lib.Xref;
  39 with Namet;    use Namet;
  40 with Nlists;   use Nlists;
  41 with Nmake;    use Nmake;
  42 with Output;   use Output;
  43 with Opt;      use Opt;
  44 with Restrict; use Restrict;
  45 with Rident;   use Rident;
  46 with Rtsfind;  use Rtsfind;
  47 with Scans;    use Scans;
  48 with Scn;      use Scn;
  49 with Sem;      use Sem;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Eval; use Sem_Eval;
  52 with Sem_Res;  use Sem_Res;
  53 with Sem_Type; use Sem_Type;
  54 with Sinfo;    use Sinfo;
  55 with Sinput;   use Sinput;
  56 with Snames;   use Snames;
  57 with Stand;    use Stand;
  58 with Style;
  59 with Stringt;  use Stringt;
  60 with Targparm; use Targparm;
  61 with Tbuild;   use Tbuild;
  62 with Ttypes;   use Ttypes;
  63 with Uname;    use Uname;
  64
  65 package body Sem_Util is
  66
  67    -----------------------
  68    -- Local Subprograms --
  69    -----------------------
  70
  71    function Build_Component_Subtype
  72      (C   : List_Id;
  73       Loc : Source_Ptr;
  74       T   : Entity_Id) return Node_Id;
  75    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
  76    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
  77    --  Loc is the source location, T is the original subtype.
  78
  79    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
  80    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
  81    --  with discriminants whose default values are static, examine only the
  82    --  components in the selected variant to determine whether all of them
  83    --  have a default.
  84
  85    function Has_Null_Extension (T : Entity_Id) return Boolean;
  86    --  T is a derived tagged type. Check whether the type extension is null.
  87    --  If the parent type is fully initialized, T can be treated as such.
  88
  89    --------------------------------
  90    -- Add_Access_Type_To_Process --
  91    --------------------------------
  92
  93    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
  94       L : Elist_Id;
  95
  96    begin
  97       Ensure_Freeze_Node (E);
  98       L := Access_Types_To_Process (Freeze_Node (E));
  99
 100       if No (L) then
 101          L := New_Elmt_List;
 102          Set_Access_Types_To_Process (Freeze_Node (E), L);
 103       end if;
 104
 105       Append_Elmt (A, L);
 106    end Add_Access_Type_To_Process;
 107
 108    -----------------------
 109    -- Alignment_In_Bits --
 110    -----------------------
 111
 112    function Alignment_In_Bits (E : Entity_Id) return Uint is
 113    begin
 114       return Alignment (E) * System_Storage_Unit;
 115    end Alignment_In_Bits;
 116
 117    -----------------------------------------
 118    -- Apply_Compile_Time_Constraint_Error --
 119    -----------------------------------------
 120
 121    procedure Apply_Compile_Time_Constraint_Error
 122      (N      : Node_Id;
 123       Msg    : String;
 124       Reason : RT_Exception_Code;
 125       Ent    : Entity_Id  := Empty;
 126       Typ    : Entity_Id  := Empty;
 127       Loc    : Source_Ptr := No_Location;
 128       Rep    : Boolean    := True;
 129       Warn   : Boolean    := False)
 130    is
 131       Stat : constant Boolean := Is_Static_Expression (N);
 132       Rtyp : Entity_Id;
 133
 134    begin
 135       if No (Typ) then
 136          Rtyp := Etype (N);
 137       else
 138          Rtyp := Typ;
 139       end if;
 140
 141       Discard_Node
 142         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 143
 144       if not Rep then
 145          return;
 146       end if;
 147
 148       --  Now we replace the node by an N_Raise_Constraint_Error node
 149       --  This does not need reanalyzing, so set it as analyzed now.
 150
 151       Rewrite (N,
 152         Make_Raise_Constraint_Error (Sloc (N),
 153           Reason => Reason));
 154       Set_Analyzed (N, True);
 155       Set_Etype (N, Rtyp);
 156       Set_Raises_Constraint_Error (N);
 157
 158       --  If the original expression was marked as static, the result is
 159       --  still marked as static, but the Raises_Constraint_Error flag is
 160       --  always set so that further static evaluation is not attempted.
 161
 162       if Stat then
 163          Set_Is_Static_Expression (N);
 164       end if;
 165    end Apply_Compile_Time_Constraint_Error;
 166
 167    --------------------------
 168    -- Build_Actual_Subtype --
 169    --------------------------
 170
 171    function Build_Actual_Subtype
 172      (T : Entity_Id;
 173       N : Node_Or_Entity_Id) return Node_Id
 174    is
 175       Obj : Node_Id;
 176
 177       Loc         : constant Source_Ptr := Sloc (N);
 178       Constraints : List_Id;
 179       Decl        : Node_Id;
 180       Discr       : Entity_Id;
 181       Hi          : Node_Id;
 182       Lo          : Node_Id;
 183       Subt        : Entity_Id;
 184       Disc_Type   : Entity_Id;
 185
 186    begin
 187       if Nkind (N) = N_Defining_Identifier then
 188          Obj := New_Reference_To (N, Loc);
 189       else
 190          Obj := N;
 191       end if;
 192
 193       if Is_Array_Type (T) then
 194          Constraints := New_List;
 195
 196          for J in 1 .. Number_Dimensions (T) loop
 197
 198             --  Build an array subtype declaration with the nominal
 199             --  subtype and the bounds of the actual. Add the declaration
 200             --  in front of the local declarations for the subprogram, for
 201             --  analysis before any reference to the formal in the body.
 202
 203             Lo :=
 204               Make_Attribute_Reference (Loc,
 205                 Prefix         =>
 206                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 207                 Attribute_Name => Name_First,
 208                 Expressions    => New_List (
 209                   Make_Integer_Literal (Loc, J)));
 210
 211             Hi :=
 212               Make_Attribute_Reference (Loc,
 213                 Prefix         =>
 214                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 215                 Attribute_Name => Name_Last,
 216                 Expressions    => New_List (
 217                   Make_Integer_Literal (Loc, J)));
 218
 219             Append (Make_Range (Loc, Lo, Hi), Constraints);
 220          end loop;
 221
 222       --  If the type has unknown discriminants there is no constrained
 223       --  subtype to build. This is never called for a formal or for a
 224       --  lhs, so returning the type is ok ???
 225
 226       elsif Has_Unknown_Discriminants (T) then
 227          return T;
 228
 229       else
 230          Constraints := New_List;
 231
 232          if Is_Private_Type (T) and then No (Full_View (T)) then
 233
 234             --  Type is a generic derived type. Inherit discriminants from
 235             --  Parent type.
 236
 237             Disc_Type := Etype (Base_Type (T));
 238          else
 239             Disc_Type := T;
 240          end if;
 241
 242          Discr := First_Discriminant (Disc_Type);
 243
 244          while Present (Discr) loop
 245             Append_To (Constraints,
 246               Make_Selected_Component (Loc,
 247                 Prefix =>
 248                   Duplicate_Subexpr_No_Checks (Obj),
 249                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 250             Next_Discriminant (Discr);
 251          end loop;
 252       end if;
 253
 254       Subt :=
 255         Make_Defining_Identifier (Loc,
 256           Chars => New_Internal_Name ('S'));
 257       Set_Is_Internal (Subt);
 258
 259       Decl :=
 260         Make_Subtype_Declaration (Loc,
 261           Defining_Identifier => Subt,
 262           Subtype_Indication =>
 263             Make_Subtype_Indication (Loc,
 264               Subtype_Mark => New_Reference_To (T,  Loc),
 265               Constraint  =>
 266                 Make_Index_Or_Discriminant_Constraint (Loc,
 267                   Constraints => Constraints)));
 268
 269       Mark_Rewrite_Insertion (Decl);
 270       return Decl;
 271    end Build_Actual_Subtype;
 272
 273    ---------------------------------------
 274    -- Build_Actual_Subtype_Of_Component --
 275    ---------------------------------------
 276
 277    function Build_Actual_Subtype_Of_Component
 278      (T : Entity_Id;
 279       N : Node_Id) return Node_Id
 280    is
 281       Loc       : constant Source_Ptr := Sloc (N);
 282       P         : constant Node_Id    := Prefix (N);
 283       D         : Elmt_Id;
 284       Id        : Node_Id;
 285       Indx_Type : Entity_Id;
 286
 287       Deaccessed_T : Entity_Id;
 288       --  This is either a copy of T, or if T is an access type, then it is
 289       --  the directly designated type of this access type.
 290
 291       function Build_Actual_Array_Constraint return List_Id;
 292       --  If one or more of the bounds of the component depends on
 293       --  discriminants, build  actual constraint using the discriminants
 294       --  of the prefix.
 295
 296       function Build_Actual_Record_Constraint return List_Id;
 297       --  Similar to previous one, for discriminated components constrained
 298       --  by the discriminant of the enclosing object.
 299
 300       -----------------------------------
 301       -- Build_Actual_Array_Constraint --
 302       -----------------------------------
 303
 304       function Build_Actual_Array_Constraint return List_Id is
 305          Constraints : constant List_Id := New_List;
 306          Indx        : Node_Id;
 307          Hi          : Node_Id;
 308          Lo          : Node_Id;
 309          Old_Hi      : Node_Id;
 310          Old_Lo      : Node_Id;
 311
 312       begin
 313          Indx := First_Index (Deaccessed_T);
 314          while Present (Indx) loop
 315             Old_Lo := Type_Low_Bound  (Etype (Indx));
 316             Old_Hi := Type_High_Bound (Etype (Indx));
 317
 318             if Denotes_Discriminant (Old_Lo) then
 319                Lo :=
 320                  Make_Selected_Component (Loc,
 321                    Prefix => New_Copy_Tree (P),
 322                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 323
 324             else
 325                Lo := New_Copy_Tree (Old_Lo);
 326
 327                --  The new bound will be reanalyzed in the enclosing
 328                --  declaration. For literal bounds that come from a type
 329                --  declaration, the type of the context must be imposed, so
 330                --  insure that analysis will take place. For non-universal
 331                --  types this is not strictly necessary.
 332
 333                Set_Analyzed (Lo, False);
 334             end if;
 335
 336             if Denotes_Discriminant (Old_Hi) then
 337                Hi :=
 338                  Make_Selected_Component (Loc,
 339                    Prefix => New_Copy_Tree (P),
 340                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 341
 342             else
 343                Hi := New_Copy_Tree (Old_Hi);
 344                Set_Analyzed (Hi, False);
 345             end if;
 346
 347             Append (Make_Range (Loc, Lo, Hi), Constraints);
 348             Next_Index (Indx);
 349          end loop;
 350
 351          return Constraints;
 352       end Build_Actual_Array_Constraint;
 353
 354       ------------------------------------
 355       -- Build_Actual_Record_Constraint --
 356       ------------------------------------
 357
 358       function Build_Actual_Record_Constraint return List_Id is
 359          Constraints : constant List_Id := New_List;
 360          D           : Elmt_Id;
 361          D_Val       : Node_Id;
 362
 363       begin
 364          D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
 365          while Present (D) loop
 366
 367             if Denotes_Discriminant (Node (D)) then
 368                D_Val :=  Make_Selected_Component (Loc,
 369                  Prefix => New_Copy_Tree (P),
 370                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 371
 372             else
 373                D_Val := New_Copy_Tree (Node (D));
 374             end if;
 375
 376             Append (D_Val, Constraints);
 377             Next_Elmt (D);
 378          end loop;
 379
 380          return Constraints;
 381       end Build_Actual_Record_Constraint;
 382
 383    --  Start of processing for Build_Actual_Subtype_Of_Component
 384
 385    begin
 386       if In_Default_Expression then
 387          return Empty;
 388
 389       elsif Nkind (N) = N_Explicit_Dereference then
 390          if Is_Composite_Type (T)
 391            and then not Is_Constrained (T)
 392            and then not (Is_Class_Wide_Type (T)
 393                           and then Is_Constrained (Root_Type (T)))
 394            and then not Has_Unknown_Discriminants (T)
 395          then
 396             --  If the type of the dereference is already constrained, it
 397             --  is an actual subtype.
 398
 399             if Is_Array_Type (Etype (N))
 400               and then Is_Constrained (Etype (N))
 401             then
 402                return Empty;
 403             else
 404                Remove_Side_Effects (P);
 405                return Build_Actual_Subtype (T, N);
 406             end if;
 407          else
 408             return Empty;
 409          end if;
 410       end if;
 411
 412       if Ekind (T) = E_Access_Subtype then
 413          Deaccessed_T := Designated_Type (T);
 414       else
 415          Deaccessed_T := T;
 416       end if;
 417
 418       if Ekind (Deaccessed_T) = E_Array_Subtype then
 419          Id := First_Index (Deaccessed_T);
 420
 421          while Present (Id) loop
 422             Indx_Type := Underlying_Type (Etype (Id));
 423
 424             if Denotes_Discriminant (Type_Low_Bound  (Indx_Type)) or else
 425                Denotes_Discriminant (Type_High_Bound (Indx_Type))
 426             then
 427                Remove_Side_Effects (P);
 428                return
 429                  Build_Component_Subtype (
 430                    Build_Actual_Array_Constraint, Loc, Base_Type (T));
 431             end if;
 432
 433             Next_Index (Id);
 434          end loop;
 435
 436       elsif Is_Composite_Type (Deaccessed_T)
 437         and then Has_Discriminants (Deaccessed_T)
 438         and then not Has_Unknown_Discriminants (Deaccessed_T)
 439       then
 440          D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
 441          while Present (D) loop
 442
 443             if Denotes_Discriminant (Node (D)) then
 444                Remove_Side_Effects (P);
 445                return
 446                  Build_Component_Subtype (
 447                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
 448             end if;
 449
 450             Next_Elmt (D);
 451          end loop;
 452       end if;
 453
 454       --  If none of the above, the actual and nominal subtypes are the same
 455
 456       return Empty;
 457    end Build_Actual_Subtype_Of_Component;
 458
 459    -----------------------------
 460    -- Build_Component_Subtype --
 461    -----------------------------
 462
 463    function Build_Component_Subtype
 464      (C   : List_Id;
 465       Loc : Source_Ptr;
 466       T   : Entity_Id) return Node_Id
 467    is
 468       Subt : Entity_Id;
 469       Decl : Node_Id;
 470
 471    begin
 472       --  Unchecked_Union components do not require component subtypes
 473
 474       if Is_Unchecked_Union (T) then
 475          return Empty;
 476       end if;
 477
 478       Subt :=
 479         Make_Defining_Identifier (Loc,
 480           Chars => New_Internal_Name ('S'));
 481       Set_Is_Internal (Subt);
 482
 483       Decl :=
 484         Make_Subtype_Declaration (Loc,
 485           Defining_Identifier => Subt,
 486           Subtype_Indication =>
 487             Make_Subtype_Indication (Loc,
 488               Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
 489               Constraint  =>
 490                 Make_Index_Or_Discriminant_Constraint (Loc,
 491                   Constraints => C)));
 492
 493       Mark_Rewrite_Insertion (Decl);
 494       return Decl;
 495    end Build_Component_Subtype;
 496
 497    --------------------------------------------
 498    -- Build_Discriminal_Subtype_Of_Component --
 499    --------------------------------------------
 500
 501    function Build_Discriminal_Subtype_Of_Component
 502      (T : Entity_Id) return Node_Id
 503    is
 504       Loc : constant Source_Ptr := Sloc (T);
 505       D   : Elmt_Id;
 506       Id  : Node_Id;
 507
 508       function Build_Discriminal_Array_Constraint return List_Id;
 509       --  If one or more of the bounds of the component depends on
 510       --  discriminants, build  actual constraint using the discriminants
 511       --  of the prefix.
 512
 513       function Build_Discriminal_Record_Constraint return List_Id;
 514       --  Similar to previous one, for discriminated components constrained
 515       --  by the discriminant of the enclosing object.
 516
 517       ----------------------------------------
 518       -- Build_Discriminal_Array_Constraint --
 519       ----------------------------------------
 520
 521       function Build_Discriminal_Array_Constraint return List_Id is
 522          Constraints : constant List_Id := New_List;
 523          Indx        : Node_Id;
 524          Hi          : Node_Id;
 525          Lo          : Node_Id;
 526          Old_Hi      : Node_Id;
 527          Old_Lo      : Node_Id;
 528
 529       begin
 530          Indx := First_Index (T);
 531          while Present (Indx) loop
 532             Old_Lo := Type_Low_Bound  (Etype (Indx));
 533             Old_Hi := Type_High_Bound (Etype (Indx));
 534
 535             if Denotes_Discriminant (Old_Lo) then
 536                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
 537
 538             else
 539                Lo := New_Copy_Tree (Old_Lo);
 540             end if;
 541
 542             if Denotes_Discriminant (Old_Hi) then
 543                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
 544
 545             else
 546                Hi := New_Copy_Tree (Old_Hi);
 547             end if;
 548
 549             Append (Make_Range (Loc, Lo, Hi), Constraints);
 550             Next_Index (Indx);
 551          end loop;
 552
 553          return Constraints;
 554       end Build_Discriminal_Array_Constraint;
 555
 556       -----------------------------------------
 557       -- Build_Discriminal_Record_Constraint --
 558       -----------------------------------------
 559
 560       function Build_Discriminal_Record_Constraint return List_Id is
 561          Constraints : constant List_Id := New_List;
 562          D           : Elmt_Id;
 563          D_Val       : Node_Id;
 564
 565       begin
 566          D := First_Elmt (Discriminant_Constraint (T));
 567          while Present (D) loop
 568             if Denotes_Discriminant (Node (D)) then
 569                D_Val :=
 570                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
 571
 572             else
 573                D_Val := New_Copy_Tree (Node (D));
 574             end if;
 575
 576             Append (D_Val, Constraints);
 577             Next_Elmt (D);
 578          end loop;
 579
 580          return Constraints;
 581       end Build_Discriminal_Record_Constraint;
 582
 583    --  Start of processing for Build_Discriminal_Subtype_Of_Component
 584
 585    begin
 586       if Ekind (T) = E_Array_Subtype then
 587          Id := First_Index (T);
 588
 589          while Present (Id) loop
 590             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
 591                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
 592             then
 593                return Build_Component_Subtype
 594                  (Build_Discriminal_Array_Constraint, Loc, T);
 595             end if;
 596
 597             Next_Index (Id);
 598          end loop;
 599
 600       elsif Ekind (T) = E_Record_Subtype
 601         and then Has_Discriminants (T)
 602         and then not Has_Unknown_Discriminants (T)
 603       then
 604          D := First_Elmt (Discriminant_Constraint (T));
 605          while Present (D) loop
 606             if Denotes_Discriminant (Node (D)) then
 607                return Build_Component_Subtype
 608                  (Build_Discriminal_Record_Constraint, Loc, T);
 609             end if;
 610
 611             Next_Elmt (D);
 612          end loop;
 613       end if;
 614
 615       --  If none of the above, the actual and nominal subtypes are the same
 616
 617       return Empty;
 618    end Build_Discriminal_Subtype_Of_Component;
 619
 620    ------------------------------
 621    -- Build_Elaboration_Entity --
 622    ------------------------------
 623
 624    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
 625       Loc       : constant Source_Ptr       := Sloc (N);
 626       Unum      : constant Unit_Number_Type := Get_Source_Unit (Loc);
 627       Decl      : Node_Id;
 628       P         : Natural;
 629       Elab_Ent  : Entity_Id;
 630
 631    begin
 632       --  Ignore if already constructed
 633
 634       if Present (Elaboration_Entity (Spec_Id)) then
 635          return;
 636       end if;
 637
 638       --  Construct name of elaboration entity as xxx_E, where xxx
 639       --  is the unit name with dots replaced by double underscore.
 640       --  We have to manually construct this name, since it will
 641       --  be elaborated in the outer scope, and thus will not have
 642       --  the unit name automatically prepended.
 643
 644       Get_Name_String (Unit_Name (Unum));
 645
 646       --  Replace the %s by _E
 647
 648       Name_Buffer (Name_Len - 1 .. Name_Len) := "_E";
 649
 650       --  Replace dots by double underscore
 651
 652       P := 2;
 653       while P < Name_Len - 2 loop
 654          if Name_Buffer (P) = '.' then
 655             Name_Buffer (P + 2 .. Name_Len + 1) :=
 656               Name_Buffer (P + 1 .. Name_Len);
 657             Name_Len := Name_Len + 1;
 658             Name_Buffer (P) := '_';
 659             Name_Buffer (P + 1) := '_';
 660             P := P + 3;
 661          else
 662             P := P + 1;
 663          end if;
 664       end loop;
 665
 666       --  Create elaboration flag
 667
 668       Elab_Ent :=
 669         Make_Defining_Identifier (Loc, Chars => Name_Find);
 670       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
 671
 672       if No (Declarations (Aux_Decls_Node (N))) then
 673          Set_Declarations (Aux_Decls_Node (N), New_List);
 674       end if;
 675
 676       Decl :=
 677          Make_Object_Declaration (Loc,
 678            Defining_Identifier => Elab_Ent,
 679            Object_Definition   =>
 680              New_Occurrence_Of (Standard_Boolean, Loc),
 681            Expression          =>
 682              New_Occurrence_Of (Standard_False, Loc));
 683
 684       Append_To (Declarations (Aux_Decls_Node (N)), Decl);
 685       Analyze (Decl);
 686
 687       --  Reset True_Constant indication, since we will indeed
 688       --  assign a value to the variable in the binder main.
 689
 690       Set_Is_True_Constant (Elab_Ent, False);
 691       Set_Current_Value    (Elab_Ent, Empty);
 692
 693       --  We do not want any further qualification of the name (if we did
 694       --  not do this, we would pick up the name of the generic package
 695       --  in the case of a library level generic instantiation).
 696
 697       Set_Has_Qualified_Name       (Elab_Ent);
 698       Set_Has_Fully_Qualified_Name (Elab_Ent);
 699    end Build_Elaboration_Entity;
 700
 701    -----------------------------------
 702    -- Cannot_Raise_Constraint_Error --
 703    -----------------------------------
 704
 705    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
 706    begin
 707       if Compile_Time_Known_Value (Expr) then
 708          return True;
 709
 710       elsif Do_Range_Check (Expr) then
 711          return False;
 712
 713       elsif Raises_Constraint_Error (Expr) then
 714          return False;
 715
 716       else
 717          case Nkind (Expr) is
 718             when N_Identifier =>
 719                return True;
 720
 721             when N_Expanded_Name =>
 722                return True;
 723
 724             when N_Selected_Component =>
 725                return not Do_Discriminant_Check (Expr);
 726
 727             when N_Attribute_Reference =>
 728                if Do_Overflow_Check (Expr) then
 729                   return False;
 730
 731                elsif No (Expressions (Expr)) then
 732                   return True;
 733
 734                else
 735                   declare
 736                      N : Node_Id := First (Expressions (Expr));
 737
 738                   begin
 739                      while Present (N) loop
 740                         if Cannot_Raise_Constraint_Error (N) then
 741                            Next (N);
 742                         else
 743                            return False;
 744                         end if;
 745                      end loop;
 746
 747                      return True;
 748                   end;
 749                end if;
 750
 751             when N_Type_Conversion =>
 752                if Do_Overflow_Check (Expr)
 753                  or else Do_Length_Check (Expr)
 754                  or else Do_Tag_Check (Expr)
 755                then
 756                   return False;
 757                else
 758                   return
 759                     Cannot_Raise_Constraint_Error (Expression (Expr));
 760                end if;
 761
 762             when N_Unchecked_Type_Conversion =>
 763                return Cannot_Raise_Constraint_Error (Expression (Expr));
 764
 765             when N_Unary_Op =>
 766                if Do_Overflow_Check (Expr) then
 767                   return False;
 768                else
 769                   return
 770                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
 771                end if;
 772
 773             when N_Op_Divide |
 774                  N_Op_Mod    |
 775                  N_Op_Rem
 776             =>
 777                if Do_Division_Check (Expr)
 778                  or else Do_Overflow_Check (Expr)
 779                then
 780                   return False;
 781                else
 782                   return
 783                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
 784                       and then
 785                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
 786                end if;
 787
 788             when N_Op_Add                    |
 789                  N_Op_And                    |
 790                  N_Op_Concat                 |
 791                  N_Op_Eq                     |
 792                  N_Op_Expon                  |
 793                  N_Op_Ge                     |
 794                  N_Op_Gt                     |
 795                  N_Op_Le                     |
 796                  N_Op_Lt                     |
 797                  N_Op_Multiply               |
 798                  N_Op_Ne                     |
 799                  N_Op_Or                     |
 800                  N_Op_Rotate_Left            |
 801                  N_Op_Rotate_Right           |
 802                  N_Op_Shift_Left             |
 803                  N_Op_Shift_Right            |
 804                  N_Op_Shift_Right_Arithmetic |
 805                  N_Op_Subtract               |
 806                  N_Op_Xor
 807             =>
 808                if Do_Overflow_Check (Expr) then
 809                   return False;
 810                else
 811                   return
 812                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
 813                       and then
 814                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
 815                end if;
 816
 817             when others =>
 818                return False;
 819          end case;
 820       end if;
 821    end Cannot_Raise_Constraint_Error;
 822
 823    --------------------------
 824    -- Check_Fully_Declared --
 825    --------------------------
 826
 827    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
 828    begin
 829       if Ekind (T) = E_Incomplete_Type then
 830
 831          --  Ada 2005 (AI-50217): If the type is available through a limited
 832          --  with_clause, verify that its full view has been analyzed.
 833
 834          if From_With_Type (T)
 835            and then Present (Non_Limited_View (T))
 836            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
 837          then
 838             --  The non-limited view is fully declared
 839             null;
 840
 841          else
 842             Error_Msg_NE
 843               ("premature usage of incomplete}", N, First_Subtype (T));
 844          end if;
 845
 846       elsif Has_Private_Component (T)
 847         and then not Is_Generic_Type (Root_Type (T))
 848         and then not In_Default_Expression
 849       then
 850
 851          --  Special case: if T is the anonymous type created for a single
 852          --  task or protected object, use the name of the source object.
 853
 854          if Is_Concurrent_Type (T)
 855            and then not Comes_From_Source (T)
 856            and then Nkind (N) = N_Object_Declaration
 857          then
 858             Error_Msg_NE ("type of& has incomplete component", N,
 859               Defining_Identifier (N));
 860
 861          else
 862             Error_Msg_NE
 863               ("premature usage of incomplete}", N, First_Subtype (T));
 864          end if;
 865       end if;
 866    end Check_Fully_Declared;
 867
 868    -----------------------
 869    -- Check_Obsolescent --
 870    -----------------------
 871
 872    procedure Check_Obsolescent (Nam : Entity_Id; N : Node_Id) is
 873       W : Node_Id;
 874
 875    begin
 876       --  Note that we always allow obsolescent references in the compiler
 877       --  itself and the run time, since we assume that we know what we are
 878       --  doing in such cases. For example the calls in Ada.Characters.Handling
 879       --  to its own obsolescent subprograms are just fine.
 880
 881       if Is_Obsolescent (Nam) and then not GNAT_Mode then
 882          Check_Restriction (No_Obsolescent_Features, N);
 883
 884          if Warn_On_Obsolescent_Feature then
 885             if Is_Package_Or_Generic_Package (Nam) then
 886                Error_Msg_NE ("with of obsolescent package&?", N, Nam);
 887             else
 888                Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
 889             end if;
 890
 891             --  Output additional warning if present
 892
 893             W := Obsolescent_Warning (Nam);
 894
 895             if Present (W) then
 896                Name_Buffer (1) := '|';
 897                Name_Buffer (2) := '?';
 898                Name_Len := 2;
 899
 900                --  Add characters to message, and output message
 901
 902                for J in 1 .. String_Length (Strval (W)) loop
 903                   Add_Char_To_Name_Buffer (''');
 904                   Add_Char_To_Name_Buffer
 905                     (Get_Character (Get_String_Char (Strval (W), J)));
 906                end loop;
 907
 908                Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
 909             end if;
 910          end if;
 911       end if;
 912    end Check_Obsolescent;
 913
 914    ------------------------------------------
 915    -- Check_Potentially_Blocking_Operation --
 916    ------------------------------------------
 917
 918    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
 919       S   : Entity_Id;
 920
 921    begin
 922       --  N is one of the potentially blocking operations listed in 9.5.1(8).
 923       --  When pragma Detect_Blocking is active, the run time will raise
 924       --  Program_Error. Here we only issue a warning, since we generally
 925       --  support the use of potentially blocking operations in the absence
 926       --  of the pragma.
 927
 928       --  Indirect blocking through a subprogram call cannot be diagnosed
 929       --  statically without interprocedural analysis, so we do not attempt
 930       --  to do it here.
 931
 932       S := Scope (Current_Scope);
 933       while Present (S) and then S /= Standard_Standard loop
 934          if Is_Protected_Type (S) then
 935             Error_Msg_N
 936               ("potentially blocking operation in protected operation?", N);
 937
 938             return;
 939          end if;
 940
 941          S := Scope (S);
 942       end loop;
 943    end Check_Potentially_Blocking_Operation;
 944
 945    ---------------
 946    -- Check_VMS --
 947    ---------------
 948
 949    procedure Check_VMS (Construct : Node_Id) is
 950    begin
 951       if not OpenVMS_On_Target then
 952          Error_Msg_N
 953            ("this construct is allowed only in Open'V'M'S", Construct);
 954       end if;
 955    end Check_VMS;
 956
 957    ----------------------------------
 958    -- Collect_Primitive_Operations --
 959    ----------------------------------
 960
 961    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
 962       B_Type         : constant Entity_Id := Base_Type (T);
 963       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
 964       B_Scope        : Entity_Id          := Scope (B_Type);
 965       Op_List        : Elist_Id;
 966       Formal         : Entity_Id;
 967       Is_Prim        : Boolean;
 968       Formal_Derived : Boolean := False;
 969       Id             : Entity_Id;
 970
 971    begin
 972       --  For tagged types, the primitive operations are collected as they
 973       --  are declared, and held in an explicit list which is simply returned.
 974
 975       if Is_Tagged_Type (B_Type) then
 976          return Primitive_Operations (B_Type);
 977
 978       --  An untagged generic type that is a derived type inherits the
 979       --  primitive operations of its parent type. Other formal types only
 980       --  have predefined operators, which are not explicitly represented.
 981
 982       elsif Is_Generic_Type (B_Type) then
 983          if Nkind (B_Decl) = N_Formal_Type_Declaration
 984            and then Nkind (Formal_Type_Definition (B_Decl))
 985              = N_Formal_Derived_Type_Definition
 986          then
 987             Formal_Derived := True;
 988          else
 989             return New_Elmt_List;
 990          end if;
 991       end if;
 992
 993       Op_List := New_Elmt_List;
 994
 995       if B_Scope = Standard_Standard then
 996          if B_Type = Standard_String then
 997             Append_Elmt (Standard_Op_Concat, Op_List);
 998
 999          elsif B_Type = Standard_Wide_String then
1000             Append_Elmt (Standard_Op_Concatw, Op_List);
1001
1002          else
1003             null;
1004          end if;
1005
1006       elsif (Is_Package_Or_Generic_Package (B_Scope)
1007               and then
1008                 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
1009                                                             N_Package_Body)
1010         or else Is_Derived_Type (B_Type)
1011       then
1012          --  The primitive operations appear after the base type, except
1013          --  if the derivation happens within the private part of B_Scope
1014          --  and the type is a private type, in which case both the type
1015          --  and some primitive operations may appear before the base
1016          --  type, and the list of candidates starts after the type.
1017
1018          if In_Open_Scopes (B_Scope)
1019            and then Scope (T) = B_Scope
1020            and then In_Private_Part (B_Scope)
1021          then
1022             Id := Next_Entity (T);
1023          else
1024             Id := Next_Entity (B_Type);
1025          end if;
1026
1027          while Present (Id) loop
1028
1029             --  Note that generic formal subprograms are not
1030             --  considered to be primitive operations and thus
1031             --  are never inherited.
1032
1033             if Is_Overloadable (Id)
1034               and then Nkind (Parent (Parent (Id)))
1035                          not in N_Formal_Subprogram_Declaration
1036             then
1037                Is_Prim := False;
1038
1039                if Base_Type (Etype (Id)) = B_Type then
1040                   Is_Prim := True;
1041                else
1042                   Formal := First_Formal (Id);
1043                   while Present (Formal) loop
1044                      if Base_Type (Etype (Formal)) = B_Type then
1045                         Is_Prim := True;
1046                         exit;
1047
1048                      elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
1049                        and then Base_Type
1050                          (Designated_Type (Etype (Formal))) = B_Type
1051                      then
1052                         Is_Prim := True;
1053                         exit;
1054                      end if;
1055
1056                      Next_Formal (Formal);
1057                   end loop;
1058                end if;
1059
1060                --  For a formal derived type, the only primitives are the
1061                --  ones inherited from the parent type. Operations appearing
1062                --  in the package declaration are not primitive for it.
1063
1064                if Is_Prim
1065                  and then (not Formal_Derived
1066                             or else Present (Alias (Id)))
1067                then
1068                   Append_Elmt (Id, Op_List);
1069                end if;
1070             end if;
1071
1072             Next_Entity (Id);
1073
1074             --  For a type declared in System, some of its operations
1075             --  may appear in  the target-specific extension to System.
1076
1077             if No (Id)
1078               and then Chars (B_Scope) = Name_System
1079               and then Scope (B_Scope) = Standard_Standard
1080               and then Present_System_Aux
1081             then
1082                B_Scope := System_Aux_Id;
1083                Id := First_Entity (System_Aux_Id);
1084             end if;
1085          end loop;
1086       end if;
1087
1088       return Op_List;
1089    end Collect_Primitive_Operations;
1090
1091    -----------------------------------
1092    -- Compile_Time_Constraint_Error --
1093    -----------------------------------
1094
1095    function Compile_Time_Constraint_Error
1096      (N    : Node_Id;
1097       Msg  : String;
1098       Ent  : Entity_Id  := Empty;
1099       Loc  : Source_Ptr := No_Location;
1100       Warn : Boolean  := False) return Node_Id
1101    is
1102       Msgc : String (1 .. Msg'Length + 2);
1103       Msgl : Natural;
1104       Wmsg : Boolean;
1105       P    : Node_Id;
1106       OldP : Node_Id;
1107       Msgs : Boolean;
1108       Eloc : Source_Ptr;
1109
1110    begin
1111       --  A static constraint error in an instance body is not a fatal error.
1112       --  we choose to inhibit the message altogether, because there is no
1113       --  obvious node (for now) on which to post it. On the other hand the
1114       --  offending node must be replaced with a constraint_error in any case.
1115
1116       --  No messages are generated if we already posted an error on this node
1117
1118       if not Error_Posted (N) then
1119          if Loc /= No_Location then
1120             Eloc := Loc;
1121          else
1122             Eloc := Sloc (N);
1123          end if;
1124
1125          --  Make all such messages unconditional
1126
1127          Msgc (1 .. Msg'Length) := Msg;
1128          Msgc (Msg'Length + 1) := '!';
1129          Msgl := Msg'Length + 1;
1130
1131          --  Message is a warning, even in Ada 95 case
1132
1133          if Msg (Msg'Length) = '?' then
1134             Wmsg := True;
1135
1136          --  In Ada 83, all messages are warnings. In the private part and
1137          --  the body of an instance, constraint_checks are only warnings.
1138          --  We also make this a warning if the Warn parameter is set.
1139
1140          elsif Warn
1141            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
1142          then
1143             Msgl := Msgl + 1;
1144             Msgc (Msgl) := '?';
1145             Wmsg := True;
1146
1147          elsif In_Instance_Not_Visible then
1148             Msgl := Msgl + 1;
1149             Msgc (Msgl) := '?';
1150             Wmsg := True;
1151
1152          --  Otherwise we have a real error message (Ada 95 static case)
1153
1154          else
1155             Wmsg := False;
1156          end if;
1157
1158          --  Should we generate a warning? The answer is not quite yes. The
1159          --  very annoying exception occurs in the case of a short circuit
1160          --  operator where the left operand is static and decisive. Climb
1161          --  parents to see if that is the case we have here. Conditional
1162          --  expressions with decisive conditions are a similar situation.
1163
1164          Msgs := True;
1165          P := N;
1166          loop
1167             OldP := P;
1168             P := Parent (P);
1169
1170             --  And then with False as left operand
1171
1172             if Nkind (P) = N_And_Then
1173               and then Compile_Time_Known_Value (Left_Opnd (P))
1174               and then Is_False (Expr_Value (Left_Opnd (P)))
1175             then
1176                Msgs := False;
1177                exit;
1178
1179             --  OR ELSE with True as left operand
1180
1181             elsif Nkind (P) = N_Or_Else
1182               and then Compile_Time_Known_Value (Left_Opnd (P))
1183               and then Is_True (Expr_Value (Left_Opnd (P)))
1184             then
1185                Msgs := False;
1186                exit;
1187
1188             --  Conditional expression
1189
1190             elsif Nkind (P) = N_Conditional_Expression then
1191                declare
1192                   Cond : constant Node_Id := First (Expressions (P));
1193                   Texp : constant Node_Id := Next (Cond);
1194                   Fexp : constant Node_Id := Next (Texp);
1195
1196                begin
1197                   if Compile_Time_Known_Value (Cond) then
1198
1199                      --  Condition is True and we are in the right operand
1200
1201                      if Is_True (Expr_Value (Cond))
1202                        and then OldP = Fexp
1203                      then
1204                         Msgs := False;
1205                         exit;
1206
1207                      --  Condition is False and we are in the left operand
1208
1209                      elsif Is_False (Expr_Value (Cond))
1210                        and then OldP = Texp
1211                      then
1212                         Msgs := False;
1213                         exit;
1214                      end if;
1215                   end if;
1216                end;
1217
1218             --  Special case for component association in aggregates, where
1219             --  we want to keep climbing up to the parent aggregate.
1220
1221             elsif Nkind (P) = N_Component_Association
1222               and then Nkind (Parent (P)) = N_Aggregate
1223             then
1224                null;
1225
1226             --  Keep going if within subexpression
1227
1228             else
1229                exit when Nkind (P) not in N_Subexpr;
1230             end if;
1231          end loop;
1232
1233          if Msgs then
1234             if Present (Ent) then
1235                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
1236             else
1237                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
1238             end if;
1239
1240             if Wmsg then
1241                if Inside_Init_Proc then
1242                   Error_Msg_NEL
1243                     ("\?& will be raised for objects of this type",
1244                      N, Standard_Constraint_Error, Eloc);
1245                else
1246                   Error_Msg_NEL
1247                     ("\?& will be raised at run time",
1248                      N, Standard_Constraint_Error, Eloc);
1249                end if;
1250             else
1251                Error_Msg_NEL
1252                  ("\static expression raises&!",
1253                   N, Standard_Constraint_Error, Eloc);
1254             end if;
1255          end if;
1256       end if;
1257
1258       return N;
1259    end Compile_Time_Constraint_Error;
1260
1261    -----------------------
1262    -- Conditional_Delay --
1263    -----------------------
1264
1265    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
1266    begin
1267       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
1268          Set_Has_Delayed_Freeze (New_Ent);
1269       end if;
1270    end Conditional_Delay;
1271
1272    --------------------
1273    -- Current_Entity --
1274    --------------------
1275
1276    --  The currently visible definition for a given identifier is the
1277    --  one most chained at the start of the visibility chain, i.e. the
1278    --  one that is referenced by the Node_Id value of the name of the
1279    --  given identifier.
1280
1281    function Current_Entity (N : Node_Id) return Entity_Id is
1282    begin
1283       return Get_Name_Entity_Id (Chars (N));
1284    end Current_Entity;
1285
1286    -----------------------------
1287    -- Current_Entity_In_Scope --
1288    -----------------------------
1289
1290    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
1291       E  : Entity_Id;
1292       CS : constant Entity_Id := Current_Scope;
1293
1294       Transient_Case : constant Boolean := Scope_Is_Transient;
1295
1296    begin
1297       E := Get_Name_Entity_Id (Chars (N));
1298
1299       while Present (E)
1300         and then Scope (E) /= CS
1301         and then (not Transient_Case or else Scope (E) /= Scope (CS))
1302       loop
1303          E := Homonym (E);
1304       end loop;
1305
1306       return E;
1307    end Current_Entity_In_Scope;
1308
1309    -------------------
1310    -- Current_Scope --
1311    -------------------
1312
1313    function Current_Scope return Entity_Id is
1314    begin
1315       if Scope_Stack.Last = -1 then
1316          return Standard_Standard;
1317       else
1318          declare
1319             C : constant Entity_Id :=
1320                   Scope_Stack.Table (Scope_Stack.Last).Entity;
1321          begin
1322             if Present (C) then
1323                return C;
1324             else
1325                return Standard_Standard;
1326             end if;
1327          end;
1328       end if;
1329    end Current_Scope;
1330
1331    ------------------------
1332    -- Current_Subprogram --
1333    ------------------------
1334
1335    function Current_Subprogram return Entity_Id is
1336       Scop : constant Entity_Id := Current_Scope;
1337
1338    begin
1339       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
1340          return Scop;
1341       else
1342          return Enclosing_Subprogram (Scop);
1343       end if;
1344    end Current_Subprogram;
1345
1346    ---------------------
1347    -- Defining_Entity --
1348    ---------------------
1349
1350    function Defining_Entity (N : Node_Id) return Entity_Id is
1351       K   : constant Node_Kind := Nkind (N);
1352       Err : Entity_Id := Empty;
1353
1354    begin
1355       case K is
1356          when
1357            N_Subprogram_Declaration                 |
1358            N_Abstract_Subprogram_Declaration        |
1359            N_Subprogram_Body                        |
1360            N_Package_Declaration                    |
1361            N_Subprogram_Renaming_Declaration        |
1362            N_Subprogram_Body_Stub                   |
1363            N_Generic_Subprogram_Declaration         |
1364            N_Generic_Package_Declaration            |
1365            N_Formal_Subprogram_Declaration
1366          =>
1367             return Defining_Entity (Specification (N));
1368
1369          when
1370            N_Component_Declaration                  |
1371            N_Defining_Program_Unit_Name             |
1372            N_Discriminant_Specification             |
1373            N_Entry_Body                             |
1374            N_Entry_Declaration                      |
1375            N_Entry_Index_Specification              |
1376            N_Exception_Declaration                  |
1377            N_Exception_Renaming_Declaration         |
1378            N_Formal_Object_Declaration              |
1379            N_Formal_Package_Declaration             |
1380            N_Formal_Type_Declaration                |
1381            N_Full_Type_Declaration                  |
1382            N_Implicit_Label_Declaration             |
1383            N_Incomplete_Type_Declaration            |
1384            N_Loop_Parameter_Specification           |
1385            N_Number_Declaration                     |
1386            N_Object_Declaration                     |
1387            N_Object_Renaming_Declaration            |
1388            N_Package_Body_Stub                      |
1389            N_Parameter_Specification                |
1390            N_Private_Extension_Declaration          |
1391            N_Private_Type_Declaration               |
1392            N_Protected_Body                         |
1393            N_Protected_Body_Stub                    |
1394            N_Protected_Type_Declaration             |
1395            N_Single_Protected_Declaration           |
1396            N_Single_Task_Declaration                |
1397            N_Subtype_Declaration                    |
1398            N_Task_Body                              |
1399            N_Task_Body_Stub                         |
1400            N_Task_Type_Declaration
1401          =>
1402             return Defining_Identifier (N);
1403
1404          when N_Subunit =>
1405             return Defining_Entity (Proper_Body (N));
1406
1407          when
1408            N_Function_Instantiation                 |
1409            N_Function_Specification                 |
1410            N_Generic_Function_Renaming_Declaration  |
1411            N_Generic_Package_Renaming_Declaration   |
1412            N_Generic_Procedure_Renaming_Declaration |
1413            N_Package_Body                           |
1414            N_Package_Instantiation                  |
1415            N_Package_Renaming_Declaration           |
1416            N_Package_Specification                  |
1417            N_Procedure_Instantiation                |
1418            N_Procedure_Specification
1419          =>
1420             declare
1421                Nam : constant Node_Id := Defining_Unit_Name (N);
1422
1423             begin
1424                if Nkind (Nam) in N_Entity then
1425                   return Nam;
1426
1427                --  For Error, make up a name and attach to declaration
1428                --  so we can continue semantic analysis
1429
1430                elsif Nam = Error then
1431                   Err :=
1432                     Make_Defining_Identifier (Sloc (N),
1433                       Chars => New_Internal_Name ('T'));
1434                   Set_Defining_Unit_Name (N, Err);
1435
1436                   return Err;
1437                --  If not an entity, get defining identifier
1438
1439                else
1440                   return Defining_Identifier (Nam);
1441                end if;
1442             end;
1443
1444          when N_Block_Statement =>
1445             return Entity (Identifier (N));
1446
1447          when others =>
1448             raise Program_Error;
1449
1450       end case;
1451    end Defining_Entity;
1452
1453    --------------------------
1454    -- Denotes_Discriminant --
1455    --------------------------
1456
1457    function Denotes_Discriminant
1458      (N               : Node_Id;
1459       Check_Protected : Boolean := False) return Boolean
1460    is
1461       E : Entity_Id;
1462    begin
1463       if not Is_Entity_Name (N)
1464         or else No (Entity (N))
1465       then
1466          return False;
1467       else
1468          E := Entity (N);
1469       end if;
1470
1471       --  If we are checking for a protected type, the discriminant may have
1472       --  been rewritten as the corresponding discriminal of the original type
1473       --  or of the corresponding concurrent record, depending on whether we
1474       --  are in the spec or body of the protected type.
1475
1476       return Ekind (E) = E_Discriminant
1477         or else
1478           (Check_Protected
1479             and then Ekind (E) = E_In_Parameter
1480             and then Present (Discriminal_Link (E))
1481             and then
1482               (Is_Protected_Type (Scope (Discriminal_Link (E)))
1483                 or else
1484                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
1485
1486    end Denotes_Discriminant;
1487
1488    -----------------------------
1489    -- Depends_On_Discriminant --
1490    -----------------------------
1491
1492    function Depends_On_Discriminant (N : Node_Id) return Boolean is
1493       L : Node_Id;
1494       H : Node_Id;
1495
1496    begin
1497       Get_Index_Bounds (N, L, H);
1498       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
1499    end Depends_On_Discriminant;
1500
1501    -------------------------
1502    -- Designate_Same_Unit --
1503    -------------------------
1504
1505    function Designate_Same_Unit
1506      (Name1 : Node_Id;
1507       Name2 : Node_Id) return Boolean
1508    is
1509       K1 : constant Node_Kind := Nkind (Name1);
1510       K2 : constant Node_Kind := Nkind (Name2);
1511
1512       function Prefix_Node (N : Node_Id) return Node_Id;
1513       --  Returns the parent unit name node of a defining program unit name
1514       --  or the prefix if N is a selected component or an expanded name.
1515
1516       function Select_Node (N : Node_Id) return Node_Id;
1517       --  Returns the defining identifier node of a defining program unit
1518       --  name or  the selector node if N is a selected component or an
1519       --  expanded name.
1520
1521       -----------------
1522       -- Prefix_Node --
1523       -----------------
1524
1525       function Prefix_Node (N : Node_Id) return Node_Id is
1526       begin
1527          if Nkind (N) = N_Defining_Program_Unit_Name then
1528             return Name (N);
1529
1530          else
1531             return Prefix (N);
1532          end if;
1533       end Prefix_Node;
1534
1535       -----------------
1536       -- Select_Node --
1537       -----------------
1538
1539       function Select_Node (N : Node_Id) return Node_Id is
1540       begin
1541          if Nkind (N) = N_Defining_Program_Unit_Name then
1542             return Defining_Identifier (N);
1543
1544          else
1545             return Selector_Name (N);
1546          end if;
1547       end Select_Node;
1548
1549    --  Start of processing for Designate_Next_Unit
1550
1551    begin
1552       if (K1 = N_Identifier or else
1553           K1 = N_Defining_Identifier)
1554         and then
1555          (K2 = N_Identifier or else
1556           K2 = N_Defining_Identifier)
1557       then
1558          return Chars (Name1) = Chars (Name2);
1559
1560       elsif
1561          (K1 = N_Expanded_Name      or else
1562           K1 = N_Selected_Component or else
1563           K1 = N_Defining_Program_Unit_Name)
1564         and then
1565          (K2 = N_Expanded_Name      or else
1566           K2 = N_Selected_Component or else
1567           K2 = N_Defining_Program_Unit_Name)
1568       then
1569          return
1570            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
1571              and then
1572                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
1573
1574       else
1575          return False;
1576       end if;
1577    end Designate_Same_Unit;
1578
1579    ----------------------------
1580    -- Enclosing_Generic_Body --
1581    ----------------------------
1582
1583    function Enclosing_Generic_Body
1584      (N : Node_Id) return Node_Id
1585    is
1586       P    : Node_Id;
1587       Decl : Node_Id;
1588       Spec : Node_Id;
1589
1590    begin
1591       P := Parent (N);
1592       while Present (P) loop
1593          if Nkind (P) = N_Package_Body
1594            or else Nkind (P) = N_Subprogram_Body
1595          then
1596             Spec := Corresponding_Spec (P);
1597
1598             if Present (Spec) then
1599                Decl := Unit_Declaration_Node (Spec);
1600
1601                if Nkind (Decl) = N_Generic_Package_Declaration
1602                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
1603                then
1604                   return P;
1605                end if;
1606             end if;
1607          end if;
1608
1609          P := Parent (P);
1610       end loop;
1611
1612       return Empty;
1613    end Enclosing_Generic_Body;
1614
1615    ----------------------------
1616    -- Enclosing_Generic_Unit --
1617    ----------------------------
1618
1619    function Enclosing_Generic_Unit
1620      (N : Node_Id) return Node_Id
1621    is
1622       P    : Node_Id;
1623       Decl : Node_Id;
1624       Spec : Node_Id;
1625
1626    begin
1627       P := Parent (N);
1628       while Present (P) loop
1629          if Nkind (P) = N_Generic_Package_Declaration
1630            or else Nkind (P) = N_Generic_Subprogram_Declaration
1631          then
1632             return P;
1633
1634          elsif Nkind (P) = N_Package_Body
1635            or else Nkind (P) = N_Subprogram_Body
1636          then
1637             Spec := Corresponding_Spec (P);
1638
1639             if Present (Spec) then
1640                Decl := Unit_Declaration_Node (Spec);
1641
1642                if Nkind (Decl) = N_Generic_Package_Declaration
1643                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
1644                then
1645                   return Decl;
1646                end if;
1647             end if;
1648          end if;
1649
1650          P := Parent (P);
1651       end loop;
1652
1653       return Empty;
1654    end Enclosing_Generic_Unit;
1655
1656    -------------------------------
1657    -- Enclosing_Lib_Unit_Entity --
1658    -------------------------------
1659
1660    function Enclosing_Lib_Unit_Entity return Entity_Id is
1661       Unit_Entity : Entity_Id := Current_Scope;
1662
1663    begin
1664       --  Look for enclosing library unit entity by following scope links.
1665       --  Equivalent to, but faster than indexing through the scope stack.
1666
1667       while (Present (Scope (Unit_Entity))
1668         and then Scope (Unit_Entity) /= Standard_Standard)
1669         and not Is_Child_Unit (Unit_Entity)
1670       loop
1671          Unit_Entity := Scope (Unit_Entity);
1672       end loop;
1673
1674       return Unit_Entity;
1675    end Enclosing_Lib_Unit_Entity;
1676
1677    -----------------------------
1678    -- Enclosing_Lib_Unit_Node --
1679    -----------------------------
1680
1681    function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
1682       Current_Node : Node_Id := N;
1683
1684    begin
1685       while Present (Current_Node)
1686         and then Nkind (Current_Node) /= N_Compilation_Unit
1687       loop
1688          Current_Node := Parent (Current_Node);
1689       end loop;
1690
1691       if Nkind (Current_Node) /= N_Compilation_Unit then
1692          return Empty;
1693       end if;
1694
1695       return Current_Node;
1696    end Enclosing_Lib_Unit_Node;
1697
1698    --------------------------
1699    -- Enclosing_Subprogram --
1700    --------------------------
1701
1702    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
1703       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
1704
1705    begin
1706       if Dynamic_Scope = Standard_Standard then
1707          return Empty;
1708
1709       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
1710          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
1711
1712       elsif Ekind (Dynamic_Scope) = E_Block then
1713          return Enclosing_Subprogram (Dynamic_Scope);
1714
1715       elsif Ekind (Dynamic_Scope) = E_Task_Type then
1716          return Get_Task_Body_Procedure (Dynamic_Scope);
1717
1718       elsif Convention (Dynamic_Scope) = Convention_Protected then
1719          return Protected_Body_Subprogram (Dynamic_Scope);
1720
1721       else
1722          return Dynamic_Scope;
1723       end if;
1724    end Enclosing_Subprogram;
1725
1726    ------------------------
1727    -- Ensure_Freeze_Node --
1728    ------------------------
1729
1730    procedure Ensure_Freeze_Node (E : Entity_Id) is
1731       FN : Node_Id;
1732
1733    begin
1734       if No (Freeze_Node (E)) then
1735          FN := Make_Freeze_Entity (Sloc (E));
1736          Set_Has_Delayed_Freeze (E);
1737          Set_Freeze_Node (E, FN);
1738          Set_Access_Types_To_Process (FN, No_Elist);
1739          Set_TSS_Elist (FN, No_Elist);
1740          Set_Entity (FN, E);
1741       end if;
1742    end Ensure_Freeze_Node;
1743
1744    ----------------
1745    -- Enter_Name --
1746    ----------------
1747
1748    procedure Enter_Name (Def_Id : Entity_Id) is
1749       C : constant Entity_Id := Current_Entity (Def_Id);
1750       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
1751       S : constant Entity_Id := Current_Scope;
1752
1753       function Is_Private_Component_Renaming (N : Node_Id) return Boolean;
1754       --  Recognize a renaming declaration that is introduced for private
1755       --  components of a protected type. We treat these as weak declarations
1756       --  so that they are overridden by entities with the same name that
1757       --  come from source, such as formals or local variables of a given
1758       --  protected declaration.
1759
1760       -----------------------------------
1761       -- Is_Private_Component_Renaming --
1762       -----------------------------------
1763
1764       function Is_Private_Component_Renaming (N : Node_Id) return Boolean is
1765       begin
1766          return not Comes_From_Source (N)
1767            and then not Comes_From_Source (Current_Scope)
1768            and then Nkind (N) = N_Object_Renaming_Declaration;
1769       end Is_Private_Component_Renaming;
1770
1771    --  Start of processing for Enter_Name
1772
1773    begin
1774       Generate_Definition (Def_Id);
1775
1776       --  Add new name to current scope declarations. Check for duplicate
1777       --  declaration, which may or may not be a genuine error.
1778
1779       if Present (E) then
1780
1781          --  Case of previous entity entered because of a missing declaration
1782          --  or else a bad subtype indication. Best is to use the new entity,
1783          --  and make the previous one invisible.
1784
1785          if Etype (E) = Any_Type then
1786             Set_Is_Immediately_Visible (E, False);
1787
1788          --  Case of renaming declaration constructed for package instances.
1789          --  if there is an explicit declaration with the same identifier,
1790          --  the renaming is not immediately visible any longer, but remains
1791          --  visible through selected component notation.
1792
1793          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
1794            and then not Comes_From_Source (E)
1795          then
1796             Set_Is_Immediately_Visible (E, False);
1797
1798          --  The new entity may be the package renaming, which has the same
1799          --  same name as a generic formal which has been seen already.
1800
1801          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
1802             and then not Comes_From_Source (Def_Id)
1803          then
1804             Set_Is_Immediately_Visible (E, False);
1805
1806          --  For a fat pointer corresponding to a remote access to subprogram,
1807          --  we use the same identifier as the RAS type, so that the proper
1808          --  name appears in the stub. This type is only retrieved through
1809          --  the RAS type and never by visibility, and is not added to the
1810          --  visibility list (see below).
1811
1812          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
1813            and then Present (Corresponding_Remote_Type (Def_Id))
1814          then
1815             null;
1816
1817          --  A controller component for a type extension overrides the
1818          --  inherited component.
1819
1820          elsif Chars (E) = Name_uController then
1821             null;
1822
1823          --  Case of an implicit operation or derived literal. The new entity
1824          --  hides the implicit one,  which is removed from all visibility,
1825          --  i.e. the entity list of its scope, and homonym chain of its name.
1826
1827          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
1828            or else Is_Internal (E)
1829          then
1830             declare
1831                Prev     : Entity_Id;
1832                Prev_Vis : Entity_Id;
1833                Decl     : constant Node_Id := Parent (E);
1834
1835             begin
1836                --  If E is an implicit declaration, it cannot be the first
1837                --  entity in the scope.
1838
1839                Prev := First_Entity (Current_Scope);
1840
1841                while Present (Prev)
1842                  and then Next_Entity (Prev) /= E
1843                loop
1844                   Next_Entity (Prev);
1845                end loop;
1846
1847                if No (Prev) then
1848
1849                   --  If E is not on the entity chain of the current scope,
1850                   --  it is an implicit declaration in the generic formal
1851                   --  part of a generic subprogram. When analyzing the body,
1852                   --  the generic formals are visible but not on the entity
1853                   --  chain of the subprogram. The new entity will become
1854                   --  the visible one in the body.
1855
1856                   pragma Assert
1857                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
1858                   null;
1859
1860                else
1861                   Set_Next_Entity (Prev, Next_Entity (E));
1862
1863                   if No (Next_Entity (Prev)) then
1864                      Set_Last_Entity (Current_Scope, Prev);
1865                   end if;
1866
1867                   if E = Current_Entity (E) then
1868                      Prev_Vis := Empty;
1869
1870                   else
1871                      Prev_Vis := Current_Entity (E);
1872                      while Homonym (Prev_Vis) /= E loop
1873                         Prev_Vis := Homonym (Prev_Vis);
1874                      end loop;
1875                   end if;
1876
1877                   if Present (Prev_Vis)  then
1878
1879                      --  Skip E in the visibility chain
1880
1881                      Set_Homonym (Prev_Vis, Homonym (E));
1882
1883                   else
1884                      Set_Name_Entity_Id (Chars (E), Homonym (E));
1885                   end if;
1886                end if;
1887             end;
1888
1889          --  This section of code could use a comment ???
1890
1891          elsif Present (Etype (E))
1892            and then Is_Concurrent_Type (Etype (E))
1893            and then E = Def_Id
1894          then
1895             return;
1896
1897          elsif Is_Private_Component_Renaming (Parent (Def_Id)) then
1898             return;
1899
1900          --  In the body or private part of an instance, a type extension
1901          --  may introduce a component with the same name as that of an
1902          --  actual. The legality rule is not enforced, but the semantics
1903          --  of the full type with two components of the same name are not
1904          --  clear at this point ???
1905
1906          elsif In_Instance_Not_Visible  then
1907             null;
1908
1909          --  When compiling a package body, some child units may have become
1910          --  visible. They cannot conflict with local entities that hide them.
1911
1912          elsif Is_Child_Unit (E)
1913            and then In_Open_Scopes (Scope (E))
1914            and then not Is_Immediately_Visible (E)
1915          then
1916             null;
1917
1918          --  Conversely, with front-end inlining we may compile the parent
1919          --  body first, and a child unit subsequently. The context is now
1920          --  the parent spec, and body entities are not visible.
1921
1922          elsif Is_Child_Unit (Def_Id)
1923            and then Is_Package_Body_Entity (E)
1924            and then not In_Package_Body (Current_Scope)
1925          then
1926             null;
1927
1928          --  Case of genuine duplicate declaration
1929
1930          else
1931             Error_Msg_Sloc := Sloc (E);
1932
1933             --  If the previous declaration is an incomplete type declaration
1934             --  this may be an attempt to complete it with a private type.
1935             --  The following avoids confusing cascaded errors.
1936
1937             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
1938               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
1939             then
1940                Error_Msg_N
1941                  ("incomplete type cannot be completed" &
1942                         " with a private declaration",
1943                     Parent (Def_Id));
1944                Set_Is_Immediately_Visible (E, False);
1945                Set_Full_View (E, Def_Id);
1946
1947             elsif Ekind (E) = E_Discriminant
1948               and then Present (Scope (Def_Id))
1949               and then Scope (Def_Id) /= Current_Scope
1950             then
1951                --  An inherited component of a record conflicts with
1952                --  a new discriminant. The discriminant is inserted first
1953                --  in the scope, but the error should be posted on it, not
1954                --  on the component.
1955
1956                Error_Msg_Sloc := Sloc (Def_Id);
1957                Error_Msg_N ("& conflicts with declaration#", E);
1958                return;
1959
1960             --  If the name of the unit appears in its own context clause,
1961             --  a dummy package with the name has already been created, and
1962             --  the error emitted. Try to continue quietly.
1963
1964             elsif Error_Posted (E)
1965               and then Sloc (E) = No_Location
1966               and then Nkind (Parent (E)) = N_Package_Specification
1967               and then Current_Scope = Standard_Standard
1968             then
1969                Set_Scope (Def_Id, Current_Scope);
1970                return;
1971
1972             else
1973                Error_Msg_N ("& conflicts with declaration#", Def_Id);
1974
1975                --  Avoid cascaded messages with duplicate components in
1976                --  derived types.
1977
1978                if Ekind (E) = E_Component
1979                  or else Ekind (E) = E_Discriminant
1980                then
1981                   return;
1982                end if;
1983             end if;
1984
1985             if Nkind (Parent (Parent (Def_Id)))
1986                  = N_Generic_Subprogram_Declaration
1987               and then Def_Id =
1988                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
1989             then
1990                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
1991             end if;
1992
1993             --  If entity is in standard, then we are in trouble, because
1994             --  it means that we have a library package with a duplicated
1995             --  name. That's hard to recover from, so abort!
1996
1997             if S = Standard_Standard then
1998                raise Unrecoverable_Error;
1999
2000             --  Otherwise we continue with the declaration. Having two
2001             --  identical declarations should not cause us too much trouble!
2002
2003             else
2004                null;
2005             end if;
2006          end if;
2007       end if;
2008
2009       --  If we fall through, declaration is OK , or OK enough to continue
2010
2011       --  If Def_Id is a discriminant or a record component we are in the
2012       --  midst of inheriting components in a derived record definition.
2013       --  Preserve their Ekind and Etype.
2014
2015       if Ekind (Def_Id) = E_Discriminant
2016         or else Ekind (Def_Id) = E_Component
2017       then
2018          null;
2019
2020       --  If a type is already set, leave it alone (happens whey a type
2021       --  declaration is reanalyzed following a call to the optimizer)
2022
2023       elsif Present (Etype (Def_Id)) then
2024          null;
2025
2026       --  Otherwise, the kind E_Void insures that premature uses of the entity
2027       --  will be detected. Any_Type insures that no cascaded errors will occur
2028
2029       else
2030          Set_Ekind (Def_Id, E_Void);
2031          Set_Etype (Def_Id, Any_Type);
2032       end if;
2033
2034       --  Inherited discriminants and components in derived record types are
2035       --  immediately visible. Itypes are not.
2036
2037       if Ekind (Def_Id) = E_Discriminant
2038         or else Ekind (Def_Id) = E_Component
2039         or else (No (Corresponding_Remote_Type (Def_Id))
2040                  and then not Is_Itype (Def_Id))
2041       then
2042          Set_Is_Immediately_Visible (Def_Id);
2043          Set_Current_Entity         (Def_Id);
2044       end if;
2045
2046       Set_Homonym       (Def_Id, C);
2047       Append_Entity     (Def_Id, S);
2048       Set_Public_Status (Def_Id);
2049
2050       --  Warn if new entity hides an old one
2051
2052       if Warn_On_Hiding
2053         and then Present (C)
2054         and then Length_Of_Name (Chars (C)) /= 1
2055         and then Comes_From_Source (C)
2056         and then Comes_From_Source (Def_Id)
2057         and then In_Extended_Main_Source_Unit (Def_Id)
2058       then
2059          Error_Msg_Sloc := Sloc (C);
2060          Error_Msg_N ("declaration hides &#?", Def_Id);
2061       end if;
2062    end Enter_Name;
2063
2064    --------------------------
2065    -- Explain_Limited_Type --
2066    --------------------------
2067
2068    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
2069       C : Entity_Id;
2070
2071    begin
2072       --  For array, component type must be limited
2073
2074       if Is_Array_Type (T) then
2075          Error_Msg_Node_2 := T;
2076          Error_Msg_NE
2077            ("component type& of type& is limited", N, Component_Type (T));
2078          Explain_Limited_Type (Component_Type (T), N);
2079
2080       elsif Is_Record_Type (T) then
2081
2082          --  No need for extra messages if explicit limited record
2083
2084          if Is_Limited_Record (Base_Type (T)) then
2085             return;
2086          end if;
2087
2088          --  Otherwise find a limited component. Check only components that
2089          --  come from source, or inherited components that appear in the
2090          --  source of the ancestor.
2091
2092          C := First_Component (T);
2093          while Present (C) loop
2094             if Is_Limited_Type (Etype (C))
2095               and then
2096                 (Comes_From_Source (C)
2097                    or else
2098                      (Present (Original_Record_Component (C))
2099                        and then
2100                          Comes_From_Source (Original_Record_Component (C))))
2101             then
2102                Error_Msg_Node_2 := T;
2103                Error_Msg_NE ("\component& of type& has limited type", N, C);
2104                Explain_Limited_Type (Etype (C), N);
2105                return;
2106             end if;
2107
2108             Next_Component (C);
2109          end loop;
2110
2111          --  The type may be declared explicitly limited, even if no component
2112          --  of it is limited, in which case we fall out of the loop.
2113          return;
2114       end if;
2115    end Explain_Limited_Type;
2116
2117    -------------------------------------
2118    -- Find_Corresponding_Discriminant --
2119    -------------------------------------
2120
2121    function Find_Corresponding_Discriminant
2122      (Id  : Node_Id;
2123       Typ : Entity_Id) return Entity_Id
2124    is
2125       Par_Disc : Entity_Id;
2126       Old_Disc : Entity_Id;
2127       New_Disc : Entity_Id;
2128
2129    begin
2130       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
2131
2132       --  The original type may currently be private, and the discriminant
2133       --  only appear on its full view.
2134
2135       if Is_Private_Type (Scope (Par_Disc))
2136         and then not Has_Discriminants (Scope (Par_Disc))
2137         and then Present (Full_View (Scope (Par_Disc)))
2138       then
2139          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
2140       else
2141          Old_Disc := First_Discriminant (Scope (Par_Disc));
2142       end if;
2143
2144       if Is_Class_Wide_Type (Typ) then
2145          New_Disc := First_Discriminant (Root_Type (Typ));
2146       else
2147          New_Disc := First_Discriminant (Typ);
2148       end if;
2149
2150       while Present (Old_Disc) and then Present (New_Disc) loop
2151          if Old_Disc = Par_Disc  then
2152             return New_Disc;
2153          else
2154             Next_Discriminant (Old_Disc);
2155             Next_Discriminant (New_Disc);
2156          end if;
2157       end loop;
2158
2159       --  Should always find it
2160
2161       raise Program_Error;
2162    end Find_Corresponding_Discriminant;
2163
2164    -----------------------------
2165    -- Find_Static_Alternative --
2166    -----------------------------
2167
2168    function Find_Static_Alternative (N : Node_Id) return Node_Id is
2169       Expr   : constant Node_Id := Expression (N);
2170       Val    : constant Uint    := Expr_Value (Expr);
2171       Alt    : Node_Id;
2172       Choice : Node_Id;
2173
2174    begin
2175       Alt := First (Alternatives (N));
2176
2177       Search : loop
2178          if Nkind (Alt) /= N_Pragma then
2179             Choice := First (Discrete_Choices (Alt));
2180
2181             while Present (Choice) loop
2182
2183                --  Others choice, always matches
2184
2185                if Nkind (Choice) = N_Others_Choice then
2186                   exit Search;
2187
2188                --  Range, check if value is in the range
2189
2190                elsif Nkind (Choice) = N_Range then
2191                   exit Search when
2192                     Val >= Expr_Value (Low_Bound (Choice))
2193                       and then
2194                     Val <= Expr_Value (High_Bound (Choice));
2195
2196                --  Choice is a subtype name. Note that we know it must
2197                --  be a static subtype, since otherwise it would have
2198                --  been diagnosed as illegal.
2199
2200                elsif Is_Entity_Name (Choice)
2201                  and then Is_Type (Entity (Choice))
2202                then
2203                   exit Search when Is_In_Range (Expr, Etype (Choice));
2204
2205                --  Choice is a subtype indication
2206
2207                elsif Nkind (Choice) = N_Subtype_Indication then
2208                   declare
2209                      C : constant Node_Id := Constraint (Choice);
2210                      R : constant Node_Id := Range_Expression (C);
2211
2212                   begin
2213                      exit Search when
2214                        Val >= Expr_Value (Low_Bound (R))
2215                          and then
2216                        Val <= Expr_Value (High_Bound (R));
2217                   end;
2218
2219                --  Choice is a simple expression
2220
2221                else
2222                   exit Search when Val = Expr_Value (Choice);
2223                end if;
2224
2225                Next (Choice);
2226             end loop;
2227          end if;
2228
2229          Next (Alt);
2230          pragma Assert (Present (Alt));
2231       end loop Search;
2232
2233       --  The above loop *must* terminate by finding a match, since
2234       --  we know the case statement is valid, and the value of the
2235       --  expression is known at compile time. When we fall out of
2236       --  the loop, Alt points to the alternative that we know will
2237       --  be selected at run time.
2238
2239       return Alt;
2240    end Find_Static_Alternative;
2241
2242    ------------------
2243    -- First_Actual --
2244    ------------------
2245
2246    function First_Actual (Node : Node_Id) return Node_Id is
2247       N : Node_Id;
2248
2249    begin
2250       if No (Parameter_Associations (Node)) then
2251          return Empty;
2252       end if;
2253
2254       N := First (Parameter_Associations (Node));
2255
2256       if Nkind (N) = N_Parameter_Association then
2257          return First_Named_Actual (Node);
2258       else
2259          return N;
2260       end if;
2261    end First_Actual;
2262
2263    -------------------------
2264    -- Full_Qualified_Name --
2265    -------------------------
2266
2267    function Full_Qualified_Name (E : Entity_Id) return String_Id is
2268       Res : String_Id;
2269       pragma Warnings (Off, Res);
2270
2271       function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
2272       --  Compute recursively the qualified name without NUL at the end
2273
2274       ----------------------------------
2275       -- Internal_Full_Qualified_Name --
2276       ----------------------------------
2277
2278       function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
2279          Ent         : Entity_Id := E;
2280          Parent_Name : String_Id := No_String;
2281
2282       begin
2283          --  Deals properly with child units
2284
2285          if Nkind (Ent) = N_Defining_Program_Unit_Name then
2286             Ent := Defining_Identifier (Ent);
2287          end if;
2288
2289          --  Compute qualification recursively (only "Standard" has no scope)
2290
2291          if Present (Scope (Scope (Ent))) then
2292             Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
2293          end if;
2294
2295          --  Every entity should have a name except some expanded blocks
2296          --  don't bother about those.
2297
2298          if Chars (Ent) = No_Name then
2299             return Parent_Name;
2300          end if;
2301
2302          --  Add a period between Name and qualification
2303
2304          if Parent_Name /= No_String then
2305             Start_String (Parent_Name);
2306             Store_String_Char (Get_Char_Code ('.'));
2307
2308          else
2309             Start_String;
2310          end if;
2311
2312          --  Generates the entity name in upper case
2313
2314          Get_Decoded_Name_String (Chars (Ent));
2315          Set_All_Upper_Case;
2316          Store_String_Chars (Name_Buffer (1 .. Name_Len));
2317          return End_String;
2318       end Internal_Full_Qualified_Name;
2319
2320    --  Start of processing for Full_Qualified_Name
2321
2322    begin
2323       Res := Internal_Full_Qualified_Name (E);
2324       Store_String_Char (Get_Char_Code (ASCII.nul));
2325       return End_String;
2326    end Full_Qualified_Name;
2327
2328    -----------------------
2329    -- Gather_Components --
2330    -----------------------
2331
2332    procedure Gather_Components
2333      (Typ           : Entity_Id;
2334       Comp_List     : Node_Id;
2335       Governed_By   : List_Id;
2336       Into          : Elist_Id;
2337       Report_Errors : out Boolean)
2338    is
2339       Assoc           : Node_Id;
2340       Variant         : Node_Id;
2341       Discrete_Choice : Node_Id;
2342       Comp_Item       : Node_Id;
2343
2344       Discrim       : Entity_Id;
2345       Discrim_Name  : Node_Id;
2346       Discrim_Value : Node_Id;
2347
2348    begin
2349       Report_Errors := False;
2350
2351       if No (Comp_List) or else Null_Present (Comp_List) then
2352          return;
2353
2354       elsif Present (Component_Items (Comp_List)) then
2355          Comp_Item := First (Component_Items (Comp_List));
2356
2357       else
2358          Comp_Item := Empty;
2359       end if;
2360
2361       while Present (Comp_Item) loop
2362
2363          --  Skip the tag of a tagged record, the interface tags, as well
2364          --  as all items that are not user components (anonymous types,
2365          --  rep clauses, Parent field, controller field).
2366
2367          if Nkind (Comp_Item) = N_Component_Declaration then
2368             declare
2369                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
2370             begin
2371                if not Is_Tag (Comp)
2372                  and then Chars (Comp) /= Name_uParent
2373                  and then Chars (Comp) /= Name_uController
2374                then
2375                   Append_Elmt (Comp, Into);
2376                end if;
2377             end;
2378          end if;
2379
2380          Next (Comp_Item);
2381       end loop;
2382
2383       if No (Variant_Part (Comp_List)) then
2384          return;
2385       else
2386          Discrim_Name := Name (Variant_Part (Comp_List));
2387          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
2388       end if;
2389
2390       --  Look for the discriminant that governs this variant part.
2391       --  The discriminant *must* be in the Governed_By List
2392
2393       Assoc := First (Governed_By);
2394       Find_Constraint : loop
2395          Discrim := First (Choices (Assoc));
2396          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
2397            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
2398                       and then
2399                     Chars (Corresponding_Discriminant (Entity (Discrim)))
2400                          = Chars  (Discrim_Name))
2401            or else Chars (Original_Record_Component (Entity (Discrim)))
2402                          = Chars (Discrim_Name);
2403
2404          if No (Next (Assoc)) then
2405             if not Is_Constrained (Typ)
2406               and then Is_Derived_Type (Typ)
2407               and then Present (Stored_Constraint (Typ))
2408             then
2409
2410                --  If the type is a tagged type with inherited discriminants,
2411                --  use the stored constraint on the parent in order to find
2412                --  the values of discriminants that are otherwise hidden by an
2413                --  explicit constraint. Renamed discriminants are handled in
2414                --  the code above.
2415
2416                --  If several parent discriminants are renamed by a single
2417                --  discriminant of the derived type, the call to obtain the
2418                --  Corresponding_Discriminant field only retrieves the last
2419                --  of them. We recover the constraint on the others from the
2420                --  Stored_Constraint as well.
2421
2422                declare
2423                   D : Entity_Id;
2424                   C : Elmt_Id;
2425
2426                begin
2427                   D := First_Discriminant (Etype (Typ));
2428                   C := First_Elmt (Stored_Constraint (Typ));
2429
2430                   while Present (D)
2431                     and then Present (C)
2432                   loop
2433                      if Chars (Discrim_Name) = Chars (D) then
2434                         if Is_Entity_Name (Node (C))
2435                           and then Entity (Node (C)) = Entity (Discrim)
2436                         then
2437                            --  D is renamed by Discrim, whose value is
2438                            --  given in Assoc.
2439
2440                            null;
2441
2442                         else
2443                            Assoc :=
2444                              Make_Component_Association (Sloc (Typ),
2445                                New_List
2446                                  (New_Occurrence_Of (D, Sloc (Typ))),
2447                                   Duplicate_Subexpr_No_Checks (Node (C)));
2448                         end if;
2449                         exit Find_Constraint;
2450                      end if;
2451
2452                      D := Next_Discriminant (D);
2453                      Next_Elmt (C);
2454                   end loop;
2455                end;
2456             end if;
2457          end if;
2458
2459          if No (Next (Assoc)) then
2460             Error_Msg_NE (" missing value for discriminant&",
2461               First (Governed_By), Discrim_Name);
2462             Report_Errors := True;
2463             return;
2464          end if;
2465
2466          Next (Assoc);
2467       end loop Find_Constraint;
2468
2469       Discrim_Value := Expression (Assoc);
2470
2471       if not Is_OK_Static_Expression (Discrim_Value) then
2472          Error_Msg_FE
2473            ("value for discriminant & must be static!",
2474             Discrim_Value, Discrim);
2475          Why_Not_Static (Discrim_Value);
2476          Report_Errors := True;
2477          return;
2478       end if;
2479
2480       Search_For_Discriminant_Value : declare
2481          Low  : Node_Id;
2482          High : Node_Id;
2483
2484          UI_High          : Uint;
2485          UI_Low           : Uint;
2486          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
2487
2488       begin
2489          Find_Discrete_Value : while Present (Variant) loop
2490             Discrete_Choice := First (Discrete_Choices (Variant));
2491             while Present (Discrete_Choice) loop
2492
2493                exit Find_Discrete_Value when
2494                  Nkind (Discrete_Choice) = N_Others_Choice;
2495
2496                Get_Index_Bounds (Discrete_Choice, Low, High);
2497
2498                UI_Low  := Expr_Value (Low);
2499                UI_High := Expr_Value (High);
2500
2501                exit Find_Discrete_Value when
2502                  UI_Low <= UI_Discrim_Value
2503                    and then
2504                  UI_High >= UI_Discrim_Value;
2505
2506                Next (Discrete_Choice);
2507             end loop;
2508
2509             Next_Non_Pragma (Variant);
2510          end loop Find_Discrete_Value;
2511       end Search_For_Discriminant_Value;
2512
2513       if No (Variant) then
2514          Error_Msg_NE
2515            ("value of discriminant & is out of range", Discrim_Value, Discrim);
2516          Report_Errors := True;
2517          return;
2518       end  if;
2519
2520       --  If we have found the corresponding choice, recursively add its
2521       --  components to the Into list.
2522
2523       Gather_Components (Empty,
2524         Component_List (Variant), Governed_By, Into, Report_Errors);
2525    end Gather_Components;
2526
2527    ------------------------
2528    -- Get_Actual_Subtype --
2529    ------------------------
2530
2531    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
2532       Typ  : constant Entity_Id := Etype (N);
2533       Utyp : Entity_Id := Underlying_Type (Typ);
2534       Decl : Node_Id;
2535       Atyp : Entity_Id;
2536
2537    begin
2538       if No (Utyp) then
2539          Utyp := Typ;
2540       end if;
2541
2542       --  If what we have is an identifier that references a subprogram
2543       --  formal, or a variable or constant object, then we get the actual
2544       --  subtype from the referenced entity if one has been built.
2545
2546       if Nkind (N) = N_Identifier
2547         and then
2548           (Is_Formal (Entity (N))
2549             or else Ekind (Entity (N)) = E_Constant
2550             or else Ekind (Entity (N)) = E_Variable)
2551         and then Present (Actual_Subtype (Entity (N)))
2552       then
2553          return Actual_Subtype (Entity (N));
2554
2555       --  Actual subtype of unchecked union is always itself. We never need
2556       --  the "real" actual subtype. If we did, we couldn't get it anyway
2557       --  because the discriminant is not available. The restrictions on
2558       --  Unchecked_Union are designed to make sure that this is OK.
2559
2560       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
2561          return Typ;
2562
2563       --  Here for the unconstrained case, we must find actual subtype
2564       --  No actual subtype is available, so we must build it on the fly.
2565
2566       --  Checking the type, not the underlying type, for constrainedness
2567       --  seems to be necessary. Maybe all the tests should be on the type???
2568
2569       elsif (not Is_Constrained (Typ))
2570            and then (Is_Array_Type (Utyp)
2571                       or else (Is_Record_Type (Utyp)
2572                                 and then Has_Discriminants (Utyp)))
2573            and then not Has_Unknown_Discriminants (Utyp)
2574            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
2575       then
2576          --  Nothing to do if in default expression
2577
2578          if In_Default_Expression then
2579             return Typ;
2580
2581          elsif Is_Private_Type (Typ)
2582            and then not Has_Discriminants (Typ)
2583          then
2584             --  If the type has no discriminants, there is no subtype to
2585             --  build, even if the underlying type is discriminated.
2586
2587             return Typ;
2588
2589          --  Else build the actual subtype
2590
2591          else
2592             Decl := Build_Actual_Subtype (Typ, N);
2593             Atyp := Defining_Identifier (Decl);
2594
2595             --  If Build_Actual_Subtype generated a new declaration then use it
2596
2597             if Atyp /= Typ then
2598
2599                --  The actual subtype is an Itype, so analyze the declaration,
2600                --  but do not attach it to the tree, to get the type defined.
2601
2602                Set_Parent (Decl, N);
2603                Set_Is_Itype (Atyp);
2604                Analyze (Decl, Suppress => All_Checks);
2605                Set_Associated_Node_For_Itype (Atyp, N);
2606                Set_Has_Delayed_Freeze (Atyp, False);
2607
2608                --  We need to freeze the actual subtype immediately. This is
2609                --  needed, because otherwise this Itype will not get frozen
2610                --  at all, and it is always safe to freeze on creation because
2611                --  any associated types must be frozen at this point.
2612
2613                Freeze_Itype (Atyp, N);
2614                return Atyp;
2615
2616             --  Otherwise we did not build a declaration, so return original
2617
2618             else
2619                return Typ;
2620             end if;
2621          end if;
2622
2623       --  For all remaining cases, the actual subtype is the same as
2624       --  the nominal type.
2625
2626       else
2627          return Typ;
2628       end if;
2629    end Get_Actual_Subtype;
2630
2631    -------------------------------------
2632    -- Get_Actual_Subtype_If_Available --
2633    -------------------------------------
2634
2635    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
2636       Typ  : constant Entity_Id := Etype (N);
2637
2638    begin
2639       --  If what we have is an identifier that references a subprogram
2640       --  formal, or a variable or constant object, then we get the actual
2641       --  subtype from the referenced entity if one has been built.
2642
2643       if Nkind (N) = N_Identifier
2644         and then
2645           (Is_Formal (Entity (N))
2646             or else Ekind (Entity (N)) = E_Constant
2647             or else Ekind (Entity (N)) = E_Variable)
2648         and then Present (Actual_Subtype (Entity (N)))
2649       then
2650          return Actual_Subtype (Entity (N));
2651
2652       --  Otherwise the Etype of N is returned unchanged
2653
2654       else
2655          return Typ;
2656       end if;
2657    end Get_Actual_Subtype_If_Available;
2658
2659    -------------------------------
2660    -- Get_Default_External_Name --
2661    -------------------------------
2662
2663    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
2664    begin
2665       Get_Decoded_Name_String (Chars (E));
2666
2667       if Opt.External_Name_Imp_Casing = Uppercase then
2668          Set_Casing (All_Upper_Case);
2669       else
2670          Set_Casing (All_Lower_Case);
2671       end if;
2672
2673       return
2674         Make_String_Literal (Sloc (E),
2675           Strval => String_From_Name_Buffer);
2676    end Get_Default_External_Name;
2677
2678    ---------------------------
2679    -- Get_Enum_Lit_From_Pos --
2680    ---------------------------
2681
2682    function Get_Enum_Lit_From_Pos
2683      (T   : Entity_Id;
2684       Pos : Uint;
2685       Loc : Source_Ptr) return Node_Id
2686    is
2687       Lit : Node_Id;
2688
2689    begin
2690       --  In the case where the literal is of type Character, Wide_Character
2691       --  or Wide_Wide_Character or of a type derived from them, there needs
2692       --  to be some special handling since there is no explicit chain of
2693       --  literals to search. Instead, an N_Character_Literal node is created
2694       --  with the appropriate Char_Code and Chars fields.
2695
2696       if Root_Type (T) = Standard_Character
2697         or else Root_Type (T) = Standard_Wide_Character
2698         or else Root_Type (T) = Standard_Wide_Wide_Character
2699       then
2700          Set_Character_Literal_Name (UI_To_CC (Pos));
2701          return
2702            Make_Character_Literal (Loc,
2703              Chars              => Name_Find,
2704              Char_Literal_Value => Pos);
2705
2706       --  For all other cases, we have a complete table of literals, and
2707       --  we simply iterate through the chain of literal until the one
2708       --  with the desired position value is found.
2709       --
2710
2711       else
2712          Lit := First_Literal (Base_Type (T));
2713          for J in 1 .. UI_To_Int (Pos) loop
2714             Next_Literal (Lit);
2715          end loop;
2716
2717          return New_Occurrence_Of (Lit, Loc);
2718       end if;
2719    end Get_Enum_Lit_From_Pos;
2720
2721    ------------------------
2722    -- Get_Generic_Entity --
2723    ------------------------
2724
2725    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
2726       Ent : constant Entity_Id := Entity (Name (N));
2727    begin
2728       if Present (Renamed_Object (Ent)) then
2729          return Renamed_Object (Ent);
2730       else
2731          return Ent;
2732       end if;
2733    end Get_Generic_Entity;
2734
2735    ----------------------
2736    -- Get_Index_Bounds --
2737    ----------------------
2738
2739    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
2740       Kind : constant Node_Kind := Nkind (N);
2741       R    : Node_Id;
2742
2743    begin
2744       if Kind = N_Range then
2745          L := Low_Bound (N);
2746          H := High_Bound (N);
2747
2748       elsif Kind = N_Subtype_Indication then
2749          R := Range_Expression (Constraint (N));
2750
2751          if R = Error then
2752             L := Error;
2753             H := Error;
2754             return;
2755
2756          else
2757             L := Low_Bound  (Range_Expression (Constraint (N)));
2758             H := High_Bound (Range_Expression (Constraint (N)));
2759          end if;
2760
2761       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
2762          if Error_Posted (Scalar_Range (Entity (N))) then
2763             L := Error;
2764             H := Error;
2765
2766          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
2767             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
2768
2769          else
2770             L := Low_Bound  (Scalar_Range (Entity (N)));
2771             H := High_Bound (Scalar_Range (Entity (N)));
2772          end if;
2773
2774       else
2775          --  N is an expression, indicating a range with one value
2776
2777          L := N;
2778          H := N;
2779       end if;
2780    end Get_Index_Bounds;
2781
2782    ----------------------------------
2783    -- Get_Library_Unit_Name_string --
2784    ----------------------------------
2785
2786    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
2787       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
2788
2789    begin
2790       Get_Unit_Name_String (Unit_Name_Id);
2791
2792       --  Remove seven last character (" (spec)" or " (body)")
2793
2794       Name_Len := Name_Len - 7;
2795       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
2796    end Get_Library_Unit_Name_String;
2797
2798    ------------------------
2799    -- Get_Name_Entity_Id --
2800    ------------------------
2801
2802    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
2803    begin
2804       return Entity_Id (Get_Name_Table_Info (Id));
2805    end Get_Name_Entity_Id;
2806
2807    ---------------------------
2808    -- Get_Referenced_Object --
2809    ---------------------------
2810
2811    function Get_Referenced_Object (N : Node_Id) return Node_Id is
2812       R   : Node_Id := N;
2813
2814    begin
2815       while Is_Entity_Name (R)
2816         and then Present (Renamed_Object (Entity (R)))
2817       loop
2818          R := Renamed_Object (Entity (R));
2819       end loop;
2820
2821       return R;
2822    end Get_Referenced_Object;
2823
2824    -------------------------
2825    -- Get_Subprogram_Body --
2826    -------------------------
2827
2828    function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
2829       Decl : Node_Id;
2830
2831    begin
2832       Decl := Unit_Declaration_Node (E);
2833
2834       if Nkind (Decl) = N_Subprogram_Body then
2835          return Decl;
2836
2837       --  The below comment is bad, because it is possible for
2838       --  Nkind (Decl) to be an N_Subprogram_Body_Stub ???
2839
2840       else           --  Nkind (Decl) = N_Subprogram_Declaration
2841
2842          if Present (Corresponding_Body (Decl)) then
2843             return Unit_Declaration_Node (Corresponding_Body (Decl));
2844
2845          --  Imported subprogram case
2846
2847          else
2848             return Empty;
2849          end if;
2850       end if;
2851    end Get_Subprogram_Body;
2852
2853    -----------------------------
2854    -- Get_Task_Body_Procedure --
2855    -----------------------------
2856
2857    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
2858    begin
2859       --  Note: A task type may be the completion of a private type with
2860       --  discriminants. when performing elaboration checks on a task
2861       --  declaration, the current view of the type may be the private one,
2862       --  and the procedure that holds the body of the task is held in its
2863       --  underlying type.
2864
2865       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
2866    end Get_Task_Body_Procedure;
2867
2868    -----------------------
2869    -- Has_Access_Values --
2870    -----------------------
2871
2872    function Has_Access_Values (T : Entity_Id) return Boolean is
2873       Typ : constant Entity_Id := Underlying_Type (T);
2874
2875    begin
2876       --  Case of a private type which is not completed yet. This can only
2877       --  happen in the case of a generic format type appearing directly, or
2878       --  as a component of the type to which this function is being applied
2879       --  at the top level. Return False in this case, since we certainly do
2880       --  not know that the type contains access types.
2881
2882       if No (Typ) then
2883          return False;
2884
2885       elsif Is_Access_Type (Typ) then
2886          return True;
2887
2888       elsif Is_Array_Type (Typ) then
2889          return Has_Access_Values (Component_Type (Typ));
2890
2891       elsif Is_Record_Type (Typ) then
2892          declare
2893             Comp : Entity_Id;
2894
2895          begin
2896             Comp := First_Entity (Typ);
2897             while Present (Comp) loop
2898                if (Ekind (Comp) = E_Component
2899                      or else
2900                    Ekind (Comp) = E_Discriminant)
2901                  and then Has_Access_Values (Etype (Comp))
2902                then
2903                   return True;
2904                end if;
2905
2906                Next_Entity (Comp);
2907             end loop;
2908          end;
2909
2910          return False;
2911
2912       else
2913          return False;
2914       end if;
2915    end Has_Access_Values;
2916
2917    ----------------------
2918    -- Has_Declarations --
2919    ----------------------
2920
2921    function Has_Declarations (N : Node_Id) return Boolean is
2922       K : constant Node_Kind := Nkind (N);
2923    begin
2924       return    K = N_Accept_Statement
2925         or else K = N_Block_Statement
2926         or else K = N_Compilation_Unit_Aux
2927         or else K = N_Entry_Body
2928         or else K = N_Package_Body
2929         or else K = N_Protected_Body
2930         or else K = N_Subprogram_Body
2931         or else K = N_Task_Body
2932         or else K = N_Package_Specification;
2933    end Has_Declarations;
2934
2935    -------------------------------------------
2936    -- Has_Discriminant_Dependent_Constraint --
2937    -------------------------------------------
2938
2939    function Has_Discriminant_Dependent_Constraint
2940      (Comp : Entity_Id) return Boolean
2941    is
2942       Comp_Decl  : constant Node_Id := Parent (Comp);
2943       Subt_Indic : constant Node_Id :=
2944                      Subtype_Indication (Component_Definition (Comp_Decl));
2945       Constr     : Node_Id;
2946       Assn       : Node_Id;
2947
2948    begin
2949       if Nkind (Subt_Indic) = N_Subtype_Indication then
2950          Constr := Constraint (Subt_Indic);
2951
2952          if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
2953             Assn := First (Constraints (Constr));
2954             while Present (Assn) loop
2955                case Nkind (Assn) is
2956                   when N_Subtype_Indication |
2957                        N_Range              |
2958                        N_Identifier
2959                   =>
2960                      if Depends_On_Discriminant (Assn) then
2961                         return True;
2962                      end if;
2963
2964                   when N_Discriminant_Association =>
2965                      if Depends_On_Discriminant (Expression (Assn)) then
2966                         return True;
2967                      end if;
2968
2969                   when others =>
2970                      null;
2971
2972                end case;
2973
2974                Next (Assn);
2975             end loop;
2976          end if;
2977       end if;
2978
2979       return False;
2980    end Has_Discriminant_Dependent_Constraint;
2981
2982    --------------------
2983    -- Has_Infinities --
2984    --------------------
2985
2986    function Has_Infinities (E : Entity_Id) return Boolean is
2987    begin
2988       return
2989         Is_Floating_Point_Type (E)
2990           and then Nkind (Scalar_Range (E)) = N_Range
2991           and then Includes_Infinities (Scalar_Range (E));
2992    end Has_Infinities;
2993
2994    ------------------------
2995    -- Has_Null_Extension --
2996    ------------------------
2997
2998    function Has_Null_Extension (T : Entity_Id) return Boolean is
2999       B     : constant Entity_Id := Base_Type (T);
3000       Comps : Node_Id;
3001       Ext   : Node_Id;
3002
3003    begin
3004       if Nkind (Parent (B)) = N_Full_Type_Declaration
3005         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
3006       then
3007          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
3008
3009          if Present (Ext) then
3010             if Null_Present (Ext) then
3011                return True;
3012             else
3013                Comps := Component_List (Ext);
3014
3015                --  The null component list is rewritten during analysis to
3016                --  include the parent component. Any other component indicates
3017                --  that the extension was not originally null.
3018
3019                return Null_Present (Comps)
3020                  or else No (Next (First (Component_Items (Comps))));
3021             end if;
3022          else
3023             return False;
3024          end if;
3025
3026       else
3027          return False;
3028       end if;
3029    end Has_Null_Extension;
3030
3031    ---------------------------
3032    -- Has_Private_Component --
3033    ---------------------------
3034
3035    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
3036       Btype     : Entity_Id := Base_Type (Type_Id);
3037       Component : Entity_Id;
3038
3039    begin
3040       if Error_Posted (Type_Id)
3041         or else Error_Posted (Btype)
3042       then
3043          return False;
3044       end if;
3045
3046       if Is_Class_Wide_Type (Btype) then
3047          Btype := Root_Type (Btype);
3048       end if;
3049
3050       if Is_Private_Type (Btype) then
3051          declare
3052             UT : constant Entity_Id := Underlying_Type (Btype);
3053          begin
3054             if No (UT) then
3055
3056                if No (Full_View (Btype)) then
3057                   return not Is_Generic_Type (Btype)
3058                     and then not Is_Generic_Type (Root_Type (Btype));
3059
3060                else
3061                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
3062                end if;
3063
3064             else
3065                return not Is_Frozen (UT) and then Has_Private_Component (UT);
3066             end if;
3067          end;
3068       elsif Is_Array_Type (Btype) then
3069          return Has_Private_Component (Component_Type (Btype));
3070
3071       elsif Is_Record_Type (Btype) then
3072
3073          Component := First_Component (Btype);
3074          while Present (Component) loop
3075
3076             if Has_Private_Component (Etype (Component)) then
3077                return True;
3078             end if;
3079
3080             Next_Component (Component);
3081          end loop;
3082
3083          return False;
3084
3085       elsif Is_Protected_Type (Btype)
3086         and then Present (Corresponding_Record_Type (Btype))
3087       then
3088          return Has_Private_Component (Corresponding_Record_Type (Btype));
3089
3090       else
3091          return False;
3092       end if;
3093    end Has_Private_Component;
3094
3095    ----------------
3096    -- Has_Stream --
3097    ----------------
3098
3099    function Has_Stream (T : Entity_Id) return Boolean is
3100       E : Entity_Id;
3101
3102    begin
3103       if No (T) then
3104          return False;
3105
3106       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
3107          return True;
3108
3109       elsif Is_Array_Type (T) then
3110          return Has_Stream (Component_Type (T));
3111
3112       elsif Is_Record_Type (T) then
3113          E := First_Component (T);
3114          while Present (E) loop
3115             if Has_Stream (Etype (E)) then
3116                return True;
3117             else
3118                Next_Component (E);
3119             end if;
3120          end loop;
3121
3122          return False;
3123
3124       elsif Is_Private_Type (T) then
3125          return Has_Stream (Underlying_Type (T));
3126
3127       else
3128          return False;
3129       end if;
3130    end Has_Stream;
3131
3132    --------------------------
3133    -- Has_Tagged_Component --
3134    --------------------------
3135
3136    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
3137       Comp : Entity_Id;
3138
3139    begin
3140       if Is_Private_Type (Typ)
3141         and then Present (Underlying_Type (Typ))
3142       then
3143          return Has_Tagged_Component (Underlying_Type (Typ));
3144
3145       elsif Is_Array_Type (Typ) then
3146          return Has_Tagged_Component (Component_Type (Typ));
3147
3148       elsif Is_Tagged_Type (Typ) then
3149          return True;
3150
3151       elsif Is_Record_Type (Typ) then
3152          Comp := First_Component (Typ);
3153
3154          while Present (Comp) loop
3155             if Has_Tagged_Component (Etype (Comp)) then
3156                return True;
3157             end if;
3158
3159             Comp := Next_Component (Typ);
3160          end loop;
3161
3162          return False;
3163
3164       else
3165          return False;
3166       end if;
3167    end Has_Tagged_Component;
3168
3169    -----------------
3170    -- In_Instance --
3171    -----------------
3172
3173    function In_Instance return Boolean is
3174       S : Entity_Id := Current_Scope;
3175
3176    begin
3177       while Present (S)
3178         and then S /= Standard_Standard
3179       loop
3180          if (Ekind (S) = E_Function
3181               or else Ekind (S) = E_Package
3182               or else Ekind (S) = E_Procedure)
3183            and then Is_Generic_Instance (S)
3184          then
3185             return True;
3186          end if;
3187
3188          S := Scope (S);
3189       end loop;
3190
3191       return False;
3192    end In_Instance;
3193
3194    ----------------------
3195    -- In_Instance_Body --
3196    ----------------------
3197
3198    function In_Instance_Body return Boolean is
3199       S : Entity_Id := Current_Scope;
3200
3201    begin
3202       while Present (S)
3203         and then S /= Standard_Standard
3204       loop
3205          if (Ekind (S) = E_Function
3206               or else Ekind (S) = E_Procedure)
3207            and then Is_Generic_Instance (S)
3208          then
3209             return True;
3210
3211          elsif Ekind (S) = E_Package
3212            and then In_Package_Body (S)
3213            and then Is_Generic_Instance (S)
3214          then
3215             return True;
3216          end if;
3217
3218          S := Scope (S);
3219       end loop;
3220
3221       return False;
3222    end In_Instance_Body;
3223
3224    -----------------------------
3225    -- In_Instance_Not_Visible --
3226    -----------------------------
3227
3228    function In_Instance_Not_Visible return Boolean is
3229       S : Entity_Id := Current_Scope;
3230
3231    begin
3232       while Present (S)
3233         and then S /= Standard_Standard
3234       loop
3235          if (Ekind (S) = E_Function
3236               or else Ekind (S) = E_Procedure)
3237            and then Is_Generic_Instance (S)
3238          then
3239             return True;
3240
3241          elsif Ekind (S) = E_Package
3242            and then (In_Package_Body (S) or else In_Private_Part (S))
3243            and then Is_Generic_Instance (S)
3244          then
3245             return True;
3246          end if;
3247
3248          S := Scope (S);
3249       end loop;
3250
3251       return False;
3252    end In_Instance_Not_Visible;
3253
3254    ------------------------------
3255    -- In_Instance_Visible_Part --
3256    ------------------------------
3257
3258    function In_Instance_Visible_Part return Boolean is
3259       S : Entity_Id := Current_Scope;
3260
3261    begin
3262       while Present (S)
3263         and then S /= Standard_Standard
3264       loop
3265          if Ekind (S) = E_Package
3266            and then Is_Generic_Instance (S)
3267            and then not In_Package_Body (S)
3268            and then not In_Private_Part (S)
3269          then
3270             return True;
3271          end if;
3272
3273          S := Scope (S);
3274       end loop;
3275
3276       return False;
3277    end In_Instance_Visible_Part;
3278
3279    ----------------------
3280    -- In_Packiage_Body --
3281    ----------------------
3282
3283    function In_Package_Body return Boolean is
3284       S : Entity_Id := Current_Scope;
3285
3286    begin
3287       while Present (S)
3288         and then S /= Standard_Standard
3289       loop
3290          if Ekind (S) = E_Package
3291            and then In_Package_Body (S)
3292          then
3293             return True;
3294          else
3295             S := Scope (S);
3296          end if;
3297       end loop;
3298
3299       return False;
3300    end In_Package_Body;
3301
3302    --------------------------------------
3303    -- In_Subprogram_Or_Concurrent_Unit --
3304    --------------------------------------
3305
3306    function In_Subprogram_Or_Concurrent_Unit return Boolean is
3307       E : Entity_Id;
3308       K : Entity_Kind;
3309
3310    begin
3311       --  Use scope chain to check successively outer scopes
3312
3313       E := Current_Scope;
3314       loop
3315          K := Ekind (E);
3316
3317          if K in Subprogram_Kind
3318            or else K in Concurrent_Kind
3319            or else K in Generic_Subprogram_Kind
3320          then
3321             return True;
3322
3323          elsif E = Standard_Standard then
3324             return False;
3325          end if;
3326
3327          E := Scope (E);
3328       end loop;
3329    end In_Subprogram_Or_Concurrent_Unit;
3330
3331    ---------------------
3332    -- In_Visible_Part --
3333    ---------------------
3334
3335    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
3336    begin
3337       return
3338         Is_Package_Or_Generic_Package (Scope_Id)
3339           and then In_Open_Scopes (Scope_Id)
3340           and then not In_Package_Body (Scope_Id)
3341           and then not In_Private_Part (Scope_Id);
3342    end In_Visible_Part;
3343
3344    ---------------------------------
3345    -- Insert_Explicit_Dereference --
3346    ---------------------------------
3347
3348    procedure Insert_Explicit_Dereference (N : Node_Id) is
3349       New_Prefix : constant Node_Id := Relocate_Node (N);
3350       Ent        : Entity_Id := Empty;
3351       Pref       : Node_Id;
3352       I          : Interp_Index;
3353       It         : Interp;
3354       T          : Entity_Id;
3355
3356    begin
3357       Save_Interps (N, New_Prefix);
3358       Rewrite (N,
3359         Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
3360
3361       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
3362
3363       if Is_Overloaded (New_Prefix) then
3364
3365          --  The deference is also overloaded, and its interpretations are the
3366          --  designated types of the interpretations of the original node.
3367
3368          Set_Etype (N, Any_Type);
3369          Get_First_Interp (New_Prefix, I, It);
3370
3371          while Present (It.Nam) loop
3372             T := It.Typ;
3373
3374             if Is_Access_Type (T) then
3375                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
3376             end if;
3377
3378             Get_Next_Interp (I, It);
3379          end loop;
3380
3381          End_Interp_List;
3382
3383       else
3384          --  Prefix is unambiguous: mark the original prefix (which might
3385          --  Come_From_Source) as a reference, since the new (relocated) one
3386          --  won't be taken into account.
3387
3388          if Is_Entity_Name (New_Prefix) then
3389             Ent := Entity (New_Prefix);
3390
3391          --  For a retrieval of a subcomponent of some composite object,
3392          --  retrieve the ultimate entity if there is one.
3393
3394          elsif Nkind (New_Prefix) = N_Selected_Component
3395            or else Nkind (New_Prefix) = N_Indexed_Component
3396          then
3397             Pref := Prefix (New_Prefix);
3398
3399             while Present (Pref)
3400               and then
3401                 (Nkind (Pref) = N_Selected_Component
3402                   or else Nkind (Pref) = N_Indexed_Component)
3403             loop
3404                Pref := Prefix (Pref);
3405             end loop;
3406
3407             if Present (Pref) and then Is_Entity_Name (Pref) then
3408                Ent := Entity (Pref);
3409             end if;
3410          end if;
3411
3412          if Present (Ent) then
3413             Generate_Reference (Ent, New_Prefix);
3414          end if;
3415       end if;
3416    end Insert_Explicit_Dereference;
3417
3418    -------------------
3419    -- Is_AAMP_Float --
3420    -------------------
3421
3422    function Is_AAMP_Float (E : Entity_Id) return Boolean is
3423    begin
3424       pragma Assert (Is_Type (E));
3425
3426       return AAMP_On_Target
3427          and then Is_Floating_Point_Type (E)
3428          and then E = Base_Type (E);
3429    end Is_AAMP_Float;
3430
3431    -------------------------
3432    -- Is_Actual_Parameter --
3433    -------------------------
3434
3435    function Is_Actual_Parameter (N : Node_Id) return Boolean is
3436       PK : constant Node_Kind := Nkind (Parent (N));
3437
3438    begin
3439       case PK is
3440          when N_Parameter_Association =>
3441             return N = Explicit_Actual_Parameter (Parent (N));
3442
3443          when N_Function_Call | N_Procedure_Call_Statement =>
3444             return Is_List_Member (N)
3445               and then
3446                 List_Containing (N) = Parameter_Associations (Parent (N));
3447
3448          when others =>
3449             return False;
3450       end case;
3451    end Is_Actual_Parameter;
3452
3453    ---------------------
3454    -- Is_Aliased_View --
3455    ---------------------
3456
3457    function Is_Aliased_View (Obj : Node_Id) return Boolean is
3458       E : Entity_Id;
3459
3460    begin
3461       if Is_Entity_Name (Obj) then
3462
3463          E := Entity (Obj);
3464
3465          return
3466            (Is_Object (E)
3467              and then
3468                (Is_Aliased (E)
3469                   or else (Present (Renamed_Object (E))
3470                              and then Is_Aliased_View (Renamed_Object (E)))))
3471
3472            or else ((Is_Formal (E)
3473                       or else Ekind (E) = E_Generic_In_Out_Parameter
3474                       or else Ekind (E) = E_Generic_In_Parameter)
3475                     and then Is_Tagged_Type (Etype (E)))
3476
3477            or else ((Ekind (E) = E_Task_Type
3478                       or else Ekind (E) = E_Protected_Type)
3479                     and then In_Open_Scopes (E))
3480
3481             --  Current instance of type
3482
3483            or else (Is_Type (E) and then E = Current_Scope)
3484            or else (Is_Incomplete_Or_Private_Type (E)
3485                      and then Full_View (E) = Current_Scope);
3486
3487       elsif Nkind (Obj) = N_Selected_Component then
3488          return Is_Aliased (Entity (Selector_Name (Obj)));
3489
3490       elsif Nkind (Obj) = N_Indexed_Component then
3491          return Has_Aliased_Components (Etype (Prefix (Obj)))
3492            or else
3493              (Is_Access_Type (Etype (Prefix (Obj)))
3494                and then
3495               Has_Aliased_Components
3496                 (Designated_Type (Etype (Prefix (Obj)))));
3497
3498       elsif Nkind (Obj) = N_Unchecked_Type_Conversion
3499         or else Nkind (Obj) = N_Type_Conversion
3500       then
3501          return Is_Tagged_Type (Etype (Obj))
3502            and then Is_Aliased_View (Expression (Obj));
3503
3504       elsif Nkind (Obj) = N_Explicit_Dereference then
3505          return Nkind (Original_Node (Obj)) /= N_Function_Call;
3506
3507       else
3508          return False;
3509       end if;
3510    end Is_Aliased_View;
3511
3512    -------------------------
3513    -- Is_Ancestor_Package --
3514    -------------------------
3515
3516    function Is_Ancestor_Package
3517      (E1  : Entity_Id;
3518       E2  : Entity_Id) return Boolean
3519    is
3520       Par : Entity_Id;
3521
3522    begin
3523       Par := E2;
3524       while Present (Par)
3525         and then Par /= Standard_Standard
3526       loop
3527          if Par = E1 then
3528             return True;
3529          end if;
3530
3531          Par := Scope (Par);
3532       end loop;
3533
3534       return False;
3535    end Is_Ancestor_Package;
3536
3537    ----------------------
3538    -- Is_Atomic_Object --
3539    ----------------------
3540
3541    function Is_Atomic_Object (N : Node_Id) return Boolean is
3542
3543       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
3544       --  Determines if given object has atomic components
3545
3546       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
3547       --  If prefix is an implicit dereference, examine designated type
3548
3549       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
3550       begin
3551          if Is_Access_Type (Etype (N)) then
3552             return
3553               Has_Atomic_Components (Designated_Type (Etype (N)));
3554          else
3555             return Object_Has_Atomic_Components (N);
3556          end if;
3557       end Is_Atomic_Prefix;
3558
3559       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
3560       begin
3561          if Has_Atomic_Components (Etype (N))
3562            or else Is_Atomic (Etype (N))
3563          then
3564             return True;
3565
3566          elsif Is_Entity_Name (N)
3567            and then (Has_Atomic_Components (Entity (N))
3568                       or else Is_Atomic (Entity (N)))
3569          then
3570             return True;
3571
3572          elsif Nkind (N) = N_Indexed_Component
3573            or else Nkind (N) = N_Selected_Component
3574          then
3575             return Is_Atomic_Prefix (Prefix (N));
3576
3577          else
3578             return False;
3579          end if;
3580       end Object_Has_Atomic_Components;
3581
3582    --  Start of processing for Is_Atomic_Object
3583
3584    begin
3585       if Is_Atomic (Etype (N))
3586         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
3587       then
3588          return True;
3589
3590       elsif Nkind (N) = N_Indexed_Component
3591         or else Nkind (N) = N_Selected_Component
3592       then
3593          return Is_Atomic_Prefix (Prefix (N));
3594
3595       else
3596          return False;
3597       end if;
3598    end Is_Atomic_Object;
3599
3600    --------------------------------------
3601    -- Is_Controlling_Limited_Procedure --
3602    --------------------------------------
3603
3604    function Is_Controlling_Limited_Procedure
3605      (Proc_Nam : Entity_Id) return Boolean
3606    is
3607       Param_Typ : Entity_Id := Empty;
3608
3609    begin
3610       if Ekind (Proc_Nam) = E_Procedure
3611         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
3612       then
3613          Param_Typ := Etype (Parameter_Type (First (
3614                         Parameter_Specifications (Parent (Proc_Nam)))));
3615
3616       --  In this case where an Itype was created, the procedure call has been
3617       --  rewritten.
3618
3619       elsif Present (Associated_Node_For_Itype (Proc_Nam))
3620         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
3621         and then
3622           Present (Parameter_Associations
3623                      (Associated_Node_For_Itype (Proc_Nam)))
3624       then
3625          Param_Typ :=
3626            Etype (First (Parameter_Associations
3627                           (Associated_Node_For_Itype (Proc_Nam))));
3628       end if;
3629
3630       if Present (Param_Typ) then
3631          return
3632            Is_Interface (Param_Typ)
3633              and then Is_Limited_Record (Param_Typ);
3634       end if;
3635
3636       return False;
3637    end Is_Controlling_Limited_Procedure;
3638
3639    ----------------------------------------------
3640    -- Is_Dependent_Component_Of_Mutable_Object --
3641    ----------------------------------------------
3642
3643    function Is_Dependent_Component_Of_Mutable_Object
3644      (Object : Node_Id) return   Boolean
3645    is
3646       P           : Node_Id;
3647       Prefix_Type : Entity_Id;
3648       P_Aliased   : Boolean := False;
3649       Comp        : Entity_Id;
3650
3651       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
3652       --  Returns True if and only if Comp is declared within a variant part
3653
3654       --------------------------------
3655       -- Is_Declared_Within_Variant --
3656       --------------------------------
3657
3658       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
3659          Comp_Decl : constant Node_Id   := Parent (Comp);
3660          Comp_List : constant Node_Id   := Parent (Comp_Decl);
3661       begin
3662          return Nkind (Parent (Comp_List)) = N_Variant;
3663       end Is_Declared_Within_Variant;
3664
3665    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
3666
3667    begin
3668       if Is_Variable (Object) then
3669
3670          if Nkind (Object) = N_Selected_Component then
3671             P := Prefix (Object);
3672             Prefix_Type := Etype (P);
3673
3674             if Is_Entity_Name (P) then
3675
3676                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
3677                   Prefix_Type := Base_Type (Prefix_Type);
3678                end if;
3679
3680                if Is_Aliased (Entity (P)) then
3681                   P_Aliased := True;
3682                end if;
3683
3684             --  A discriminant check on a selected component may be
3685             --  expanded into a dereference when removing side-effects.
3686             --  Recover the original node and its type, which may be
3687             --  unconstrained.
3688
3689             elsif Nkind (P) = N_Explicit_Dereference
3690               and then not (Comes_From_Source (P))
3691             then
3692                P := Original_Node (P);
3693                Prefix_Type := Etype (P);
3694
3695             else
3696                --  Check for prefix being an aliased component ???
3697                null;
3698
3699             end if;
3700
3701             --  A heap object is constrained by its initial value
3702
3703             --  Ada 2005 AI-363:if the designated type is a type with a
3704             --  constrained partial view, the resulting heap object is not
3705             --  constrained, and a renaming of the component is now unsafe.
3706
3707             if Is_Access_Type (Prefix_Type)
3708               and then
3709                  not Has_Constrained_Partial_View
3710                    (Designated_Type (Prefix_Type))
3711             then
3712                return False;
3713
3714             elsif Nkind (P) = N_Explicit_Dereference
3715               and then not Has_Constrained_Partial_View (Prefix_Type)
3716             then
3717                return False;
3718             end if;
3719
3720             Comp :=
3721               Original_Record_Component (Entity (Selector_Name (Object)));
3722
3723             --  As per AI-0017, the renaming is illegal in a generic body,
3724             --  even if the subtype is indefinite.
3725
3726             if not Is_Constrained (Prefix_Type)
3727               and then (not Is_Indefinite_Subtype (Prefix_Type)
3728                          or else
3729                           (Is_Generic_Type (Prefix_Type)
3730                             and then Ekind (Current_Scope) = E_Generic_Package
3731                             and then In_Package_Body (Current_Scope)))
3732
3733               and then (Is_Declared_Within_Variant (Comp)
3734                           or else Has_Discriminant_Dependent_Constraint (Comp))
3735               and then not P_Aliased
3736             then
3737                return True;
3738
3739             else
3740                return
3741                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
3742
3743             end if;
3744
3745          elsif Nkind (Object) = N_Indexed_Component
3746            or else Nkind (Object) = N_Slice
3747          then
3748             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
3749
3750          --  A type conversion that Is_Variable is a view conversion:
3751          --  go back to the denoted object.
3752
3753          elsif Nkind (Object) = N_Type_Conversion then
3754             return
3755               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
3756          end if;
3757       end if;
3758
3759       return False;
3760    end Is_Dependent_Component_Of_Mutable_Object;
3761
3762    ---------------------
3763    -- Is_Dereferenced --
3764    ---------------------
3765
3766    function Is_Dereferenced (N : Node_Id) return Boolean is
3767       P : constant Node_Id := Parent (N);
3768    begin
3769       return
3770          (Nkind (P) = N_Selected_Component
3771             or else
3772           Nkind (P) = N_Explicit_Dereference
3773             or else
3774           Nkind (P) = N_Indexed_Component
3775             or else
3776           Nkind (P) = N_Slice)
3777         and then Prefix (P) = N;
3778    end Is_Dereferenced;
3779
3780    ----------------------
3781    -- Is_Descendent_Of --
3782    ----------------------
3783
3784    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
3785       T    : Entity_Id;
3786       Etyp : Entity_Id;
3787
3788    begin
3789       pragma Assert (Nkind (T1) in N_Entity);
3790       pragma Assert (Nkind (T2) in N_Entity);
3791
3792       T := Base_Type (T1);
3793
3794       --  Immediate return if the types match
3795
3796       if T = T2 then
3797          return True;
3798
3799       --  Comment needed here ???
3800
3801       elsif Ekind (T) = E_Class_Wide_Type then
3802          return Etype (T) = T2;
3803
3804       --  All other cases
3805
3806       else
3807          loop
3808             Etyp := Etype (T);
3809
3810             --  Done if we found the type we are looking for
3811
3812             if Etyp = T2 then
3813                return True;
3814
3815             --  Done if no more derivations to check
3816
3817             elsif T = T1
3818               or else T = Etyp
3819             then
3820                return False;
3821
3822             --  Following test catches error cases resulting from prev errors
3823
3824             elsif No (Etyp) then
3825                return False;
3826
3827             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
3828                return False;
3829
3830             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
3831                return False;
3832             end if;
3833
3834             T := Base_Type (Etyp);
3835          end loop;
3836       end if;
3837
3838       raise Program_Error;
3839    end Is_Descendent_Of;
3840
3841    ------------------------------
3842    -- Is_Descendent_Of_Address --
3843    ------------------------------
3844
3845    function Is_Descendent_Of_Address (T1 : Entity_Id) return Boolean is
3846    begin
3847       --  If Address has not been loaded, answer must be False
3848
3849       if not RTU_Loaded (System) then
3850          return False;
3851
3852       --  Otherwise we can get the entity we are interested in without
3853       --  causing an unwanted dependency on System, and do the test.
3854
3855       else
3856          return Is_Descendent_Of (T1, Base_Type (RTE (RE_Address)));
3857       end if;
3858    end Is_Descendent_Of_Address;
3859
3860    --------------
3861    -- Is_False --
3862    --------------
3863
3864    function Is_False (U : Uint) return Boolean is
3865    begin
3866       return (U = 0);
3867    end Is_False;
3868
3869    ---------------------------
3870    -- Is_Fixed_Model_Number --
3871    ---------------------------
3872
3873    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
3874       S : constant Ureal := Small_Value (T);
3875       M : Urealp.Save_Mark;
3876       R : Boolean;
3877    begin
3878       M := Urealp.Mark;
3879       R := (U = UR_Trunc (U / S) * S);
3880       Urealp.Release (M);
3881       return R;
3882    end Is_Fixed_Model_Number;
3883
3884    -------------------------------
3885    -- Is_Fully_Initialized_Type --
3886    -------------------------------
3887
3888    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
3889    begin
3890       if Is_Scalar_Type (Typ) then
3891          return False;
3892
3893       elsif Is_Access_Type (Typ) then
3894          return True;
3895
3896       elsif Is_Array_Type (Typ) then
3897          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
3898             return True;
3899          end if;
3900
3901          --  An interesting case, if we have a constrained type one of whose
3902          --  bounds is known to be null, then there are no elements to be
3903          --  initialized, so all the elements are initialized!
3904
3905          if Is_Constrained (Typ) then
3906             declare
3907                Indx     : Node_Id;
3908                Indx_Typ : Entity_Id;
3909                Lbd, Hbd : Node_Id;
3910
3911             begin
3912                Indx := First_Index (Typ);
3913                while Present (Indx) loop
3914
3915                   if Etype (Indx) = Any_Type then
3916                      return False;
3917
3918                   --  If index is a range, use directly
3919
3920                   elsif Nkind (Indx) = N_Range then
3921                      Lbd := Low_Bound  (Indx);
3922                      Hbd := High_Bound (Indx);
3923
3924                   else
3925                      Indx_Typ := Etype (Indx);
3926
3927                      if Is_Private_Type (Indx_Typ)  then
3928                         Indx_Typ := Full_View (Indx_Typ);
3929                      end if;
3930
3931                      if No (Indx_Typ) then
3932                         return False;
3933                      else
3934                         Lbd := Type_Low_Bound  (Indx_Typ);
3935                         Hbd := Type_High_Bound (Indx_Typ);
3936                      end if;
3937                   end if;
3938
3939                   if Compile_Time_Known_Value (Lbd)
3940                     and then Compile_Time_Known_Value (Hbd)
3941                   then
3942                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
3943                         return True;
3944                      end if;
3945                   end if;
3946
3947                   Next_Index (Indx);
3948                end loop;
3949             end;
3950          end if;
3951
3952          --  If no null indexes, then type is not fully initialized
3953
3954          return False;
3955
3956       --  Record types
3957
3958       elsif Is_Record_Type (Typ) then
3959          if Has_Discriminants (Typ)
3960            and then
3961              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
3962            and then Is_Fully_Initialized_Variant (Typ)
3963          then
3964             return True;
3965          end if;
3966
3967          --  Controlled records are considered to be fully initialized if
3968          --  there is a user defined Initialize routine. This may not be
3969          --  entirely correct, but as the spec notes, we are guessing here
3970          --  what is best from the point of view of issuing warnings.
3971
3972          if Is_Controlled (Typ) then
3973             declare
3974                Utyp : constant Entity_Id := Underlying_Type (Typ);
3975
3976             begin
3977                if Present (Utyp) then
3978                   declare
3979                      Init : constant Entity_Id :=
3980                               (Find_Prim_Op
3981                                  (Underlying_Type (Typ), Name_Initialize));
3982
3983                   begin
3984                      if Present (Init)
3985                        and then Comes_From_Source (Init)
3986                        and then not
3987                          Is_Predefined_File_Name
3988                            (File_Name (Get_Source_File_Index (Sloc (Init))))
3989                      then
3990                         return True;
3991
3992                      elsif Has_Null_Extension (Typ)
3993                         and then
3994                           Is_Fully_Initialized_Type
3995                             (Etype (Base_Type (Typ)))
3996                      then
3997                         return True;
3998                      end if;
3999                   end;
4000                end if;
4001             end;
4002          end if;
4003
4004          --  Otherwise see if all record components are initialized
4005
4006          declare
4007             Ent : Entity_Id;
4008
4009          begin
4010             Ent := First_Entity (Typ);
4011
4012             while Present (Ent) loop
4013                if Chars (Ent) = Name_uController then
4014                   null;
4015
4016                elsif Ekind (Ent) = E_Component
4017                  and then (No (Parent (Ent))
4018                              or else No (Expression (Parent (Ent))))
4019                  and then not Is_Fully_Initialized_Type (Etype (Ent))
4020                then
4021                   return False;
4022                end if;
4023
4024                Next_Entity (Ent);
4025             end loop;
4026          end;
4027
4028          --  No uninitialized components, so type is fully initialized.
4029          --  Note that this catches the case of no components as well.
4030
4031          return True;
4032
4033       elsif Is_Concurrent_Type (Typ) then
4034          return True;
4035
4036       elsif Is_Private_Type (Typ) then
4037          declare
4038             U : constant Entity_Id := Underlying_Type (Typ);
4039
4040          begin
4041             if No (U) then
4042                return False;
4043             else
4044                return Is_Fully_Initialized_Type (U);
4045             end if;
4046          end;
4047
4048       else
4049          return False;
4050       end if;
4051    end Is_Fully_Initialized_Type;
4052
4053    ----------------------------------
4054    -- Is_Fully_Initialized_Variant --
4055    ----------------------------------
4056
4057    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
4058       Loc           : constant Source_Ptr := Sloc (Typ);
4059       Constraints   : constant List_Id    := New_List;
4060       Components    : constant Elist_Id   := New_Elmt_List;
4061       Comp_Elmt     : Elmt_Id;
4062       Comp_Id       : Node_Id;
4063       Comp_List     : Node_Id;
4064       Discr         : Entity_Id;
4065       Discr_Val     : Node_Id;
4066       Report_Errors : Boolean;
4067
4068    begin
4069       if Serious_Errors_Detected > 0 then
4070          return False;
4071       end if;
4072
4073       if Is_Record_Type (Typ)
4074         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
4075         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
4076       then
4077          Comp_List := Component_List (Type_Definition (Parent (Typ)));
4078          Discr := First_Discriminant (Typ);
4079
4080          while Present (Discr) loop
4081             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
4082                Discr_Val := Expression (Parent (Discr));
4083
4084                if Present (Discr_Val)
4085                  and then Is_OK_Static_Expression (Discr_Val)
4086                then
4087                   Append_To (Constraints,
4088                     Make_Component_Association (Loc,
4089                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
4090                       Expression => New_Copy (Discr_Val)));
4091                else
4092                   return False;
4093                end if;
4094             else
4095                return False;
4096             end if;
4097
4098             Next_Discriminant (Discr);
4099          end loop;
4100
4101          Gather_Components
4102            (Typ           => Typ,
4103             Comp_List     => Comp_List,
4104             Governed_By   => Constraints,
4105             Into          => Components,
4106             Report_Errors => Report_Errors);
4107
4108          --  Check that each component present is fully initialized
4109
4110          Comp_Elmt := First_Elmt (Components);
4111
4112          while Present (Comp_Elmt) loop
4113             Comp_Id := Node (Comp_Elmt);
4114
4115             if Ekind (Comp_Id) = E_Component
4116               and then (No (Parent (Comp_Id))
4117                          or else No (Expression (Parent (Comp_Id))))
4118               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
4119             then
4120                return False;
4121             end if;
4122
4123             Next_Elmt (Comp_Elmt);
4124          end loop;
4125
4126          return True;
4127
4128       elsif Is_Private_Type (Typ) then
4129          declare
4130             U : constant Entity_Id := Underlying_Type (Typ);
4131
4132          begin
4133             if No (U) then
4134                return False;
4135             else
4136                return Is_Fully_Initialized_Variant (U);
4137             end if;
4138          end;
4139       else
4140          return False;
4141       end if;
4142    end Is_Fully_Initialized_Variant;
4143
4144    ----------------------------
4145    -- Is_Inherited_Operation --
4146    ----------------------------
4147
4148    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
4149       Kind : constant Node_Kind := Nkind (Parent (E));
4150    begin
4151       pragma Assert (Is_Overloadable (E));
4152       return Kind = N_Full_Type_Declaration
4153         or else Kind = N_Private_Extension_Declaration
4154         or else Kind = N_Subtype_Declaration
4155         or else (Ekind (E) = E_Enumeration_Literal
4156                   and then Is_Derived_Type (Etype (E)));
4157    end Is_Inherited_Operation;
4158
4159    -----------------------------
4160    -- Is_Library_Level_Entity --
4161    -----------------------------
4162
4163    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
4164    begin
4165       --  The following is a small optimization, and it also handles
4166       --  properly discriminals, which in task bodies might appear in
4167       --  expressions before the corresponding procedure has been
4168       --  created, and which therefore do not have an assigned scope.
4169
4170       if Ekind (E) in Formal_Kind then
4171          return False;
4172       end if;
4173
4174       --  Normal test is simply that the enclosing dynamic scope is Standard
4175
4176       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
4177    end Is_Library_Level_Entity;
4178
4179    ---------------------------------
4180    -- Is_Local_Variable_Reference --
4181    ---------------------------------
4182
4183    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
4184    begin
4185       if not Is_Entity_Name (Expr) then
4186          return False;
4187
4188       else
4189          declare
4190             Ent : constant Entity_Id := Entity (Expr);
4191             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
4192          begin
4193             if Ekind (Ent) /= E_Variable
4194                  and then
4195                Ekind (Ent) /= E_In_Out_Parameter
4196             then
4197                return False;
4198             else
4199                return Present (Sub) and then Sub = Current_Subprogram;
4200             end if;
4201          end;
4202       end if;
4203    end Is_Local_Variable_Reference;
4204
4205    ---------------
4206    -- Is_Lvalue --
4207    ---------------
4208
4209    function Is_Lvalue (N : Node_Id) return Boolean is
4210       P : constant Node_Id := Parent (N);
4211
4212    begin
4213       case Nkind (P) is
4214
4215          --  Test left side of assignment
4216
4217          when N_Assignment_Statement =>
4218             return N = Name (P);
4219
4220          --  Test prefix of component or attribute
4221
4222          when N_Attribute_Reference  |
4223               N_Expanded_Name        |
4224               N_Explicit_Dereference |
4225               N_Indexed_Component    |
4226               N_Reference            |
4227               N_Selected_Component   |
4228               N_Slice                =>
4229             return N = Prefix (P);
4230
4231          --  Test subprogram parameter (we really should check the
4232          --  parameter mode, but it is not worth the trouble)
4233
4234          when N_Function_Call            |
4235               N_Procedure_Call_Statement |
4236               N_Accept_Statement         |
4237               N_Parameter_Association    =>
4238             return True;
4239
4240          --  Test for appearing in a conversion that itself appears
4241          --  in an lvalue context, since this should be an lvalue.
4242
4243          when N_Type_Conversion =>
4244             return Is_Lvalue (P);
4245
4246          --  Test for appearence in object renaming declaration
4247
4248          when N_Object_Renaming_Declaration =>
4249             return True;
4250
4251          --  All other references are definitely not Lvalues
4252
4253          when others =>
4254             return False;
4255
4256       end case;
4257    end Is_Lvalue;
4258
4259    -------------------------
4260    -- Is_Object_Reference --
4261    -------------------------
4262
4263    function Is_Object_Reference (N : Node_Id) return Boolean is
4264    begin
4265       if Is_Entity_Name (N) then
4266          return Is_Object (Entity (N));
4267
4268       else
4269          case Nkind (N) is
4270             when N_Indexed_Component | N_Slice =>
4271                return
4272                  Is_Object_Reference (Prefix (N))
4273                    or else Is_Access_Type (Etype (Prefix (N)));
4274
4275             --  In Ada95, a function call is a constant object; a procedure
4276             --  call is not.
4277
4278             when N_Function_Call =>
4279                return Etype (N) /= Standard_Void_Type;
4280
4281             --  A reference to the stream attribute Input is a function call
4282
4283             when N_Attribute_Reference =>
4284                return Attribute_Name (N) = Name_Input;
4285
4286             when N_Selected_Component =>
4287                return
4288                  Is_Object_Reference (Selector_Name (N))
4289                    and then
4290                      (Is_Object_Reference (Prefix (N))
4291                         or else Is_Access_Type (Etype (Prefix (N))));
4292
4293             when N_Explicit_Dereference =>
4294                return True;
4295
4296             --  A view conversion of a tagged object is an object reference
4297
4298             when N_Type_Conversion =>
4299                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
4300                  and then Is_Tagged_Type (Etype (Expression (N)))
4301                  and then Is_Object_Reference (Expression (N));
4302
4303             --  An unchecked type conversion is considered to be an object if
4304             --  the operand is an object (this construction arises only as a
4305             --  result of expansion activities).
4306
4307             when N_Unchecked_Type_Conversion =>
4308                return True;
4309
4310             when others =>
4311                return False;
4312          end case;
4313       end if;
4314    end Is_Object_Reference;
4315
4316    -----------------------------------
4317    -- Is_OK_Variable_For_Out_Formal --
4318    -----------------------------------
4319
4320    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
4321    begin
4322       Note_Possible_Modification (AV);
4323
4324       --  We must reject parenthesized variable names. The check for
4325       --  Comes_From_Source is present because there are currently
4326       --  cases where the compiler violates this rule (e.g. passing
4327       --  a task object to its controlled Initialize routine).
4328
4329       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
4330          return False;
4331
4332       --  A variable is always allowed
4333
4334       elsif Is_Variable (AV) then
4335          return True;
4336
4337       --  Unchecked conversions are allowed only if they come from the
4338       --  generated code, which sometimes uses unchecked conversions for out
4339       --  parameters in cases where code generation is unaffected. We tell
4340       --  source unchecked conversions by seeing if they are rewrites of an
4341       --  original Unchecked_Conversion function call, or of an explicit
4342       --  conversion of a function call.
4343
4344       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
4345          if Nkind (Original_Node (AV)) = N_Function_Call then
4346             return False;
4347
4348          elsif Comes_From_Source (AV)
4349            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
4350          then
4351             return False;
4352
4353          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
4354             return Is_OK_Variable_For_Out_Formal (Expression (AV));
4355
4356          else
4357             return True;
4358          end if;
4359
4360       --  Normal type conversions are allowed if argument is a variable
4361
4362       elsif Nkind (AV) = N_Type_Conversion then
4363          if Is_Variable (Expression (AV))
4364            and then Paren_Count (Expression (AV)) = 0
4365          then
4366             Note_Possible_Modification (Expression (AV));
4367             return True;
4368
4369          --  We also allow a non-parenthesized expression that raises
4370          --  constraint error if it rewrites what used to be a variable
4371
4372          elsif Raises_Constraint_Error (Expression (AV))
4373             and then Paren_Count (Expression (AV)) = 0
4374             and then Is_Variable (Original_Node (Expression (AV)))
4375          then
4376             return True;
4377
4378          --  Type conversion of something other than a variable
4379
4380          else
4381             return False;
4382          end if;
4383
4384       --  If this node is rewritten, then test the original form, if that is
4385       --  OK, then we consider the rewritten node OK (for example, if the
4386       --  original node is a conversion, then Is_Variable will not be true
4387       --  but we still want to allow the conversion if it converts a variable).
4388
4389       elsif Original_Node (AV) /= AV then
4390          return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
4391
4392       --  All other non-variables are rejected
4393
4394       else
4395          return False;
4396       end if;
4397    end Is_OK_Variable_For_Out_Formal;
4398
4399    -----------------------------------
4400    -- Is_Partially_Initialized_Type --
4401    -----------------------------------
4402
4403    function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
4404    begin
4405       if Is_Scalar_Type (Typ) then
4406          return False;
4407
4408       elsif Is_Access_Type (Typ) then
4409          return True;
4410
4411       elsif Is_Array_Type (Typ) then
4412
4413          --  If component type is partially initialized, so is array type
4414
4415          if Is_Partially_Initialized_Type (Component_Type (Typ)) then
4416             return True;
4417
4418          --  Otherwise we are only partially initialized if we are fully
4419          --  initialized (this is the empty array case, no point in us
4420          --  duplicating that code here).
4421
4422          else
4423             return Is_Fully_Initialized_Type (Typ);
4424          end if;
4425
4426       elsif Is_Record_Type (Typ) then
4427
4428          --  A discriminated type is always partially initialized
4429
4430          if Has_Discriminants (Typ) then
4431             return True;
4432
4433          --  A tagged type is always partially initialized
4434
4435          elsif Is_Tagged_Type (Typ) then
4436             return True;
4437
4438          --  Case of non-discriminated record
4439
4440          else
4441             declare
4442                Ent : Entity_Id;
4443
4444                Component_Present : Boolean := False;
4445                --  Set True if at least one component is present. If no
4446                --  components are present, then record type is fully
4447                --  initialized (another odd case, like the null array).
4448
4449             begin
4450                --  Loop through components
4451
4452                Ent := First_Entity (Typ);
4453                while Present (Ent) loop
4454                   if Ekind (Ent) = E_Component then
4455                      Component_Present := True;
4456
4457                      --  If a component has an initialization expression then
4458                      --  the enclosing record type is partially initialized
4459
4460                      if Present (Parent (Ent))
4461                        and then Present (Expression (Parent (Ent)))
4462                      then
4463                         return True;
4464
4465                      --  If a component is of a type which is itself partially
4466                      --  initialized, then the enclosing record type is also.
4467
4468                      elsif Is_Partially_Initialized_Type (Etype (Ent)) then
4469                         return True;
4470                      end if;
4471                   end if;
4472
4473                   Next_Entity (Ent);
4474                end loop;
4475
4476                --  No initialized components found. If we found any components
4477                --  they were all uninitialized so the result is false.
4478
4479                if Component_Present then
4480                   return False;
4481
4482                --  But if we found no components, then all the components are
4483                --  initialized so we consider the type to be initialized.
4484
4485                else
4486                   return True;
4487                end if;
4488             end;
4489          end if;
4490
4491       --  Concurrent types are always fully initialized
4492
4493       elsif Is_Concurrent_Type (Typ) then
4494          return True;
4495
4496       --  For a private type, go to underlying type. If there is no underlying
4497       --  type then just assume this partially initialized. Not clear if this
4498       --  can happen in a non-error case, but no harm in testing for this.
4499
4500       elsif Is_Private_Type (Typ) then
4501          declare
4502             U : constant Entity_Id := Underlying_Type (Typ);
4503          begin
4504             if No (U) then
4505                return True;
4506             else
4507                return Is_Partially_Initialized_Type (U);
4508             end if;
4509          end;
4510
4511       --  For any other type (are there any?) assume partially initialized
4512
4513       else
4514          return True;
4515       end if;
4516    end Is_Partially_Initialized_Type;
4517
4518    ------------------------------------
4519    -- Is_Potentially_Persistent_Type --
4520    ------------------------------------
4521
4522    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
4523       Comp : Entity_Id;
4524       Indx : Node_Id;
4525
4526    begin
4527       --  For private type, test corrresponding full type
4528
4529       if Is_Private_Type (T) then
4530          return Is_Potentially_Persistent_Type (Full_View (T));
4531
4532       --  Scalar types are potentially persistent
4533
4534       elsif Is_Scalar_Type (T) then
4535          return True;
4536
4537       --  Record type is potentially persistent if not tagged and the types of
4538       --  all it components are potentially persistent, and no component has
4539       --  an initialization expression.
4540
4541       elsif Is_Record_Type (T)
4542         and then not Is_Tagged_Type (T)
4543         and then not Is_Partially_Initialized_Type (T)
4544       then
4545          Comp := First_Component (T);
4546          while Present (Comp) loop
4547             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
4548                return False;
4549             else
4550                Next_Entity (Comp);
4551             end if;
4552          end loop;
4553
4554          return True;
4555
4556       --  Array type is potentially persistent if its component type is
4557       --  potentially persistent and if all its constraints are static.
4558
4559       elsif Is_Array_Type (T) then
4560          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
4561             return False;
4562          end if;
4563
4564          Indx := First_Index (T);
4565          while Present (Indx) loop
4566             if not Is_OK_Static_Subtype (Etype (Indx)) then
4567                return False;
4568             else
4569                Next_Index (Indx);
4570             end if;
4571          end loop;
4572
4573          return True;
4574
4575       --  All other types are not potentially persistent
4576
4577       else
4578          return False;
4579       end if;
4580    end Is_Potentially_Persistent_Type;
4581
4582    -----------------------------
4583    -- Is_RCI_Pkg_Spec_Or_Body --
4584    -----------------------------
4585
4586    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
4587
4588       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
4589       --  Return True if the unit of Cunit is an RCI package declaration
4590
4591       ---------------------------
4592       -- Is_RCI_Pkg_Decl_Cunit --
4593       ---------------------------
4594
4595       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
4596          The_Unit : constant Node_Id := Unit (Cunit);
4597
4598       begin
4599          if Nkind (The_Unit) /= N_Package_Declaration then
4600             return False;
4601          end if;
4602
4603          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
4604       end Is_RCI_Pkg_Decl_Cunit;
4605
4606    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
4607
4608    begin
4609       return Is_RCI_Pkg_Decl_Cunit (Cunit)
4610         or else
4611          (Nkind (Unit (Cunit)) = N_Package_Body
4612            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
4613    end Is_RCI_Pkg_Spec_Or_Body;
4614
4615    -----------------------------------------
4616    -- Is_Remote_Access_To_Class_Wide_Type --
4617    -----------------------------------------
4618
4619    function Is_Remote_Access_To_Class_Wide_Type
4620      (E : Entity_Id) return Boolean
4621    is
4622       D : Entity_Id;
4623
4624       function Comes_From_Limited_Private_Type_Declaration
4625         (E : Entity_Id) return Boolean;
4626       --  Check that the type is declared by a limited type declaration,
4627       --  or else is derived from a Remote_Type ancestor through private
4628       --  extensions.
4629
4630       -------------------------------------------------
4631       -- Comes_From_Limited_Private_Type_Declaration --
4632       -------------------------------------------------
4633
4634       function Comes_From_Limited_Private_Type_Declaration
4635         (E : Entity_Id) return Boolean
4636       is
4637          N : constant Node_Id := Declaration_Node (E);
4638
4639       begin
4640          if Nkind (N) = N_Private_Type_Declaration
4641            and then Limited_Present (N)
4642          then
4643             return True;
4644          end if;
4645
4646          if Nkind (N) = N_Private_Extension_Declaration then
4647             return
4648               Comes_From_Limited_Private_Type_Declaration (Etype (E))
4649                 or else
4650                  (Is_Remote_Types (Etype (E))
4651                     and then Is_Limited_Record (Etype (E))
4652                     and then Has_Private_Declaration (Etype (E)));
4653          end if;
4654
4655          return False;
4656       end Comes_From_Limited_Private_Type_Declaration;
4657
4658    --  Start of processing for Is_Remote_Access_To_Class_Wide_Type
4659
4660    begin
4661       if not (Is_Remote_Call_Interface (E)
4662                or else Is_Remote_Types (E))
4663         or else Ekind (E) /= E_General_Access_Type
4664       then
4665          return False;
4666       end if;
4667
4668       D := Designated_Type (E);
4669
4670       if Ekind (D) /= E_Class_Wide_Type then
4671          return False;
4672       end if;
4673
4674       return Comes_From_Limited_Private_Type_Declaration
4675                (Defining_Identifier (Parent (D)));
4676    end Is_Remote_Access_To_Class_Wide_Type;
4677
4678    -----------------------------------------
4679    -- Is_Remote_Access_To_Subprogram_Type --
4680    -----------------------------------------
4681
4682    function Is_Remote_Access_To_Subprogram_Type
4683      (E : Entity_Id) return Boolean
4684    is
4685    begin
4686       return (Ekind (E) = E_Access_Subprogram_Type
4687                 or else (Ekind (E) = E_Record_Type
4688                            and then Present (Corresponding_Remote_Type (E))))
4689         and then (Is_Remote_Call_Interface (E)
4690                    or else Is_Remote_Types (E));
4691    end Is_Remote_Access_To_Subprogram_Type;
4692
4693    --------------------
4694    -- Is_Remote_Call --
4695    --------------------
4696
4697    function Is_Remote_Call (N : Node_Id) return Boolean is
4698    begin
4699       if Nkind (N) /= N_Procedure_Call_Statement
4700         and then Nkind (N) /= N_Function_Call
4701       then
4702          --  An entry call cannot be remote
4703
4704          return False;
4705
4706       elsif Nkind (Name (N)) in N_Has_Entity
4707         and then Is_Remote_Call_Interface (Entity (Name (N)))
4708       then
4709          --  A subprogram declared in the spec of a RCI package is remote
4710
4711          return True;
4712
4713       elsif Nkind (Name (N)) = N_Explicit_Dereference
4714         and then Is_Remote_Access_To_Subprogram_Type
4715                    (Etype (Prefix (Name (N))))
4716       then
4717          --  The dereference of a RAS is a remote call
4718
4719          return True;
4720
4721       elsif Present (Controlling_Argument (N))
4722         and then Is_Remote_Access_To_Class_Wide_Type
4723           (Etype (Controlling_Argument (N)))
4724       then
4725          --  Any primitive operation call with a controlling argument of
4726          --  a RACW type is a remote call.
4727
4728          return True;
4729       end if;
4730
4731       --  All other calls are local calls
4732
4733       return False;
4734    end Is_Remote_Call;
4735
4736    ----------------------
4737    -- Is_Renamed_Entry --
4738    ----------------------
4739
4740    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
4741       Orig_Node : Node_Id := Empty;
4742       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
4743
4744       function Is_Entry (Nam : Node_Id) return Boolean;
4745       --  Determine whether Nam is an entry. Traverse selectors
4746       --  if there are nested selected components.
4747
4748       --------------
4749       -- Is_Entry --
4750       --------------
4751
4752       function Is_Entry (Nam : Node_Id) return Boolean is
4753       begin
4754          if Nkind (Nam) = N_Selected_Component then
4755             return Is_Entry (Selector_Name (Nam));
4756          end if;
4757
4758          return Ekind (Entity (Nam)) = E_Entry;
4759       end Is_Entry;
4760
4761    --  Start of processing for Is_Renamed_Entry
4762
4763    begin
4764       if Present (Alias (Proc_Nam)) then
4765          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
4766       end if;
4767
4768       --  Look for a rewritten subprogram renaming declaration
4769
4770       if Nkind (Subp_Decl) = N_Subprogram_Declaration
4771         and then Present (Original_Node (Subp_Decl))
4772       then
4773          Orig_Node := Original_Node (Subp_Decl);
4774       end if;
4775
4776       --  The rewritten subprogram is actually an entry
4777
4778       if Present (Orig_Node)
4779         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
4780         and then Is_Entry (Name (Orig_Node))
4781       then
4782          return True;
4783       end if;
4784
4785       return False;
4786    end Is_Renamed_Entry;
4787
4788    ----------------------
4789    -- Is_Selector_Name --
4790    ----------------------
4791
4792    function Is_Selector_Name (N : Node_Id) return Boolean is
4793    begin
4794       if not Is_List_Member (N) then
4795          declare
4796             P : constant Node_Id   := Parent (N);
4797             K : constant Node_Kind := Nkind (P);
4798          begin
4799             return
4800               (K = N_Expanded_Name          or else
4801                K = N_Generic_Association    or else
4802                K = N_Parameter_Association  or else
4803                K = N_Selected_Component)
4804               and then Selector_Name (P) = N;
4805          end;
4806
4807       else
4808          declare
4809             L : constant List_Id := List_Containing (N);
4810             P : constant Node_Id := Parent (L);
4811          begin
4812             return (Nkind (P) = N_Discriminant_Association
4813                      and then Selector_Names (P) = L)
4814               or else
4815                    (Nkind (P) = N_Component_Association
4816                      and then Choices (P) = L);
4817          end;
4818       end if;
4819    end Is_Selector_Name;
4820
4821    ------------------
4822    -- Is_Statement --
4823    ------------------
4824
4825    function Is_Statement (N : Node_Id) return Boolean is
4826    begin
4827       return
4828         Nkind (N) in N_Statement_Other_Than_Procedure_Call
4829           or else Nkind (N) = N_Procedure_Call_Statement;
4830    end Is_Statement;
4831
4832    -----------------
4833    -- Is_Transfer --
4834    -----------------
4835
4836    function Is_Transfer (N : Node_Id) return Boolean is
4837       Kind : constant Node_Kind := Nkind (N);
4838
4839    begin
4840       if Kind = N_Return_Statement
4841            or else
4842          Kind = N_Goto_Statement
4843            or else
4844          Kind = N_Raise_Statement
4845            or else
4846          Kind = N_Requeue_Statement
4847       then
4848          return True;
4849
4850       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
4851         and then No (Condition (N))
4852       then
4853          return True;
4854
4855       elsif Kind = N_Procedure_Call_Statement
4856         and then Is_Entity_Name (Name (N))
4857         and then Present (Entity (Name (N)))
4858         and then No_Return (Entity (Name (N)))
4859       then
4860          return True;
4861
4862       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
4863          return True;
4864
4865       else
4866          return False;
4867       end if;
4868    end Is_Transfer;
4869
4870    -------------
4871    -- Is_True --
4872    -------------
4873
4874    function Is_True (U : Uint) return Boolean is
4875    begin
4876       return (U /= 0);
4877    end Is_True;
4878
4879    -----------------
4880    -- Is_Variable --
4881    -----------------
4882
4883    function Is_Variable (N : Node_Id) return Boolean is
4884
4885       Orig_Node : constant Node_Id := Original_Node (N);
4886       --  We do the test on the original node, since this is basically a
4887       --  test of syntactic categories, so it must not be disturbed by
4888       --  whatever rewriting might have occurred. For example, an aggregate,
4889       --  which is certainly NOT a variable, could be turned into a variable
4890       --  by expansion.
4891
4892       function In_Protected_Function (E : Entity_Id) return Boolean;
4893       --  Within a protected function, the private components of the
4894       --  enclosing protected type are constants. A function nested within
4895       --  a (protected) procedure is not itself protected.
4896
4897       function Is_Variable_Prefix (P : Node_Id) return Boolean;
4898       --  Prefixes can involve implicit dereferences, in which case we
4899       --  must test for the case of a reference of a constant access
4900       --  type, which can never be a variable.
4901
4902       ---------------------------
4903       -- In_Protected_Function --
4904       ---------------------------
4905
4906       function In_Protected_Function (E : Entity_Id) return Boolean is
4907          Prot : constant Entity_Id := Scope (E);
4908          S    : Entity_Id;
4909
4910       begin
4911          if not Is_Protected_Type (Prot) then
4912             return False;
4913          else
4914             S := Current_Scope;
4915             while Present (S) and then S /= Prot loop
4916                if Ekind (S) = E_Function
4917                  and then Scope (S) = Prot
4918                then
4919                   return True;
4920                end if;
4921
4922                S := Scope (S);
4923             end loop;
4924
4925             return False;
4926          end if;
4927       end In_Protected_Function;
4928
4929       ------------------------
4930       -- Is_Variable_Prefix --
4931       ------------------------
4932
4933       function Is_Variable_Prefix (P : Node_Id) return Boolean is
4934       begin
4935          if Is_Access_Type (Etype (P)) then
4936             return not Is_Access_Constant (Root_Type (Etype (P)));
4937
4938          --  For the case of an indexed component whose prefix has a packed
4939          --  array type, the prefix has been rewritten into a type conversion.
4940          --  Determine variable-ness from the converted expression.
4941
4942          elsif Nkind (P) = N_Type_Conversion
4943            and then not Comes_From_Source (P)
4944            and then Is_Array_Type (Etype (P))
4945            and then Is_Packed (Etype (P))
4946          then
4947             return Is_Variable (Expression (P));
4948
4949          else
4950             return Is_Variable (P);
4951          end if;
4952       end Is_Variable_Prefix;
4953
4954    --  Start of processing for Is_Variable
4955
4956    begin
4957       --  Definitely OK if Assignment_OK is set. Since this is something that
4958       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
4959
4960       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
4961          return True;
4962
4963       --  Normally we go to the original node, but there is one exception
4964       --  where we use the rewritten node, namely when it is an explicit
4965       --  dereference. The generated code may rewrite a prefix which is an
4966       --  access type with an explicit dereference. The dereference is a
4967       --  variable, even though the original node may not be (since it could
4968       --  be a constant of the access type).
4969
4970       elsif Nkind (N) = N_Explicit_Dereference
4971         and then Nkind (Orig_Node) /= N_Explicit_Dereference
4972         and then Is_Access_Type (Etype (Orig_Node))
4973       then
4974          return Is_Variable_Prefix (Original_Node (Prefix (N)));
4975
4976       --  A function call is never a variable
4977
4978       elsif Nkind (N) = N_Function_Call then
4979          return False;
4980
4981       --  All remaining checks use the original node
4982
4983       elsif Is_Entity_Name (Orig_Node) then
4984          declare
4985             E : constant Entity_Id := Entity (Orig_Node);
4986             K : constant Entity_Kind := Ekind (E);
4987
4988          begin
4989             return (K = E_Variable
4990                       and then Nkind (Parent (E)) /= N_Exception_Handler)
4991               or else  (K = E_Component
4992                           and then not In_Protected_Function (E))
4993               or else  K = E_Out_Parameter
4994               or else  K = E_In_Out_Parameter
4995               or else  K = E_Generic_In_Out_Parameter
4996
4997                --  Current instance of type:
4998
4999               or else (Is_Type (E) and then In_Open_Scopes (E))
5000               or else (Is_Incomplete_Or_Private_Type (E)
5001                         and then In_Open_Scopes (Full_View (E)));
5002          end;
5003
5004       else
5005          case Nkind (Orig_Node) is
5006             when N_Indexed_Component | N_Slice =>
5007                return Is_Variable_Prefix (Prefix (Orig_Node));
5008
5009             when N_Selected_Component =>
5010                return Is_Variable_Prefix (Prefix (Orig_Node))
5011                  and then Is_Variable (Selector_Name (Orig_Node));
5012
5013             --  For an explicit dereference, the type of the prefix cannot
5014             --  be an access to constant or an access to subprogram.
5015
5016             when N_Explicit_Dereference =>
5017                declare
5018                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
5019                begin
5020                   return Is_Access_Type (Typ)
5021                     and then not Is_Access_Constant (Root_Type (Typ))
5022                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
5023                end;
5024
5025             --  The type conversion is the case where we do not deal with the
5026             --  context dependent special case of an actual parameter. Thus
5027             --  the type conversion is only considered a variable for the
5028             --  purposes of this routine if the target type is tagged. However,
5029             --  a type conversion is considered to be a variable if it does not
5030             --  come from source (this deals for example with the conversions
5031             --  of expressions to their actual subtypes).
5032
5033             when N_Type_Conversion =>
5034                return Is_Variable (Expression (Orig_Node))
5035                  and then
5036                    (not Comes_From_Source (Orig_Node)
5037                       or else
5038                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
5039                           and then
5040                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
5041
5042             --  GNAT allows an unchecked type conversion as a variable. This
5043             --  only affects the generation of internal expanded code, since
5044             --  calls to instantiations of Unchecked_Conversion are never
5045             --  considered variables (since they are function calls).
5046             --  This is also true for expression actions.
5047
5048             when N_Unchecked_Type_Conversion =>
5049                return Is_Variable (Expression (Orig_Node));
5050
5051             when others =>
5052                return False;
5053          end case;
5054       end if;
5055    end Is_Variable;
5056
5057    ------------------------
5058    -- Is_Volatile_Object --
5059    ------------------------
5060
5061    function Is_Volatile_Object (N : Node_Id) return Boolean is
5062
5063       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
5064       --  Determines if given object has volatile components
5065
5066       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
5067       --  If prefix is an implicit dereference, examine designated type
5068
5069       ------------------------
5070       -- Is_Volatile_Prefix --
5071       ------------------------
5072
5073       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
5074          Typ  : constant Entity_Id := Etype (N);
5075
5076       begin
5077          if Is_Access_Type (Typ) then
5078             declare
5079                Dtyp : constant Entity_Id := Designated_Type (Typ);
5080
5081             begin
5082                return Is_Volatile (Dtyp)
5083                  or else Has_Volatile_Components (Dtyp);
5084             end;
5085
5086          else
5087             return Object_Has_Volatile_Components (N);
5088          end if;
5089       end Is_Volatile_Prefix;
5090
5091       ------------------------------------
5092       -- Object_Has_Volatile_Components --
5093       ------------------------------------
5094
5095       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
5096          Typ : constant Entity_Id := Etype (N);
5097
5098       begin
5099          if Is_Volatile (Typ)
5100            or else Has_Volatile_Components (Typ)
5101          then
5102             return True;
5103
5104          elsif Is_Entity_Name (N)
5105            and then (Has_Volatile_Components (Entity (N))
5106                       or else Is_Volatile (Entity (N)))
5107          then
5108             return True;
5109
5110          elsif Nkind (N) = N_Indexed_Component
5111            or else Nkind (N) = N_Selected_Component
5112          then
5113             return Is_Volatile_Prefix (Prefix (N));
5114
5115          else
5116             return False;
5117          end if;
5118       end Object_Has_Volatile_Components;
5119
5120    --  Start of processing for Is_Volatile_Object
5121
5122    begin
5123       if Is_Volatile (Etype (N))
5124         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
5125       then
5126          return True;
5127
5128       elsif Nkind (N) = N_Indexed_Component
5129         or else Nkind (N) = N_Selected_Component
5130       then
5131          return Is_Volatile_Prefix (Prefix (N));
5132
5133       else
5134          return False;
5135       end if;
5136    end Is_Volatile_Object;
5137
5138    -------------------------
5139    -- Kill_Current_Values --
5140    -------------------------
5141
5142    procedure Kill_Current_Values (Ent : Entity_Id) is
5143    begin
5144       if Is_Object (Ent) then
5145          Kill_Checks (Ent);
5146          Set_Current_Value (Ent, Empty);
5147
5148          if not Can_Never_Be_Null (Ent) then
5149             Set_Is_Known_Non_Null (Ent, False);
5150          end if;
5151
5152          Set_Is_Known_Null (Ent, False);
5153       end if;
5154    end Kill_Current_Values;
5155
5156    procedure Kill_Current_Values is
5157       S : Entity_Id;
5158
5159       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
5160       --  Clear current value for entity E and all entities chained to E
5161
5162       ------------------------------------------
5163       -- Kill_Current_Values_For_Entity_Chain --
5164       ------------------------------------------
5165
5166       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
5167          Ent : Entity_Id;
5168       begin
5169          Ent := E;
5170          while Present (Ent) loop
5171             Kill_Current_Values (Ent);
5172             Next_Entity (Ent);
5173          end loop;
5174       end Kill_Current_Values_For_Entity_Chain;
5175
5176    --  Start of processing for Kill_Current_Values
5177
5178    begin
5179       --  Kill all saved checks, a special case of killing saved values
5180
5181       Kill_All_Checks;
5182
5183       --  Loop through relevant scopes, which includes the current scope and
5184       --  any parent scopes if the current scope is a block or a package.
5185
5186       S := Current_Scope;
5187       Scope_Loop : loop
5188
5189          --  Clear current values of all entities in current scope
5190
5191          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
5192
5193          --  If scope is a package, also clear current values of all
5194          --  private entities in the scope.
5195
5196          if Ekind (S) = E_Package
5197               or else
5198             Ekind (S) = E_Generic_Package
5199               or else
5200             Is_Concurrent_Type (S)
5201          then
5202             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
5203          end if;
5204
5205          --  If this is a block or nested package, deal with parent
5206
5207          if Ekind (S) = E_Block
5208            or else (Ekind (S) = E_Package
5209                       and then not Is_Library_Level_Entity (S))
5210          then
5211             S := Scope (S);
5212          else
5213             exit Scope_Loop;
5214          end if;
5215       end loop Scope_Loop;
5216    end Kill_Current_Values;
5217
5218    --------------------------
5219    -- Kill_Size_Check_Code --
5220    --------------------------
5221
5222    procedure Kill_Size_Check_Code (E : Entity_Id) is
5223    begin
5224       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
5225         and then Present (Size_Check_Code (E))
5226       then
5227          Remove (Size_Check_Code (E));
5228          Set_Size_Check_Code (E, Empty);
5229       end if;
5230    end Kill_Size_Check_Code;
5231
5232    -------------------------
5233    -- New_External_Entity --
5234    -------------------------
5235
5236    function New_External_Entity
5237      (Kind         : Entity_Kind;
5238       Scope_Id     : Entity_Id;
5239       Sloc_Value   : Source_Ptr;
5240       Related_Id   : Entity_Id;
5241       Suffix       : Character;
5242       Suffix_Index : Nat := 0;
5243       Prefix       : Character := ' ') return Entity_Id
5244    is
5245       N : constant Entity_Id :=
5246             Make_Defining_Identifier (Sloc_Value,
5247               New_External_Name
5248                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
5249
5250    begin
5251       Set_Ekind          (N, Kind);
5252       Set_Is_Internal    (N, True);
5253       Append_Entity      (N, Scope_Id);
5254       Set_Public_Status  (N);
5255
5256       if Kind in Type_Kind then
5257          Init_Size_Align (N);
5258       end if;
5259
5260       return N;
5261    end New_External_Entity;
5262
5263    -------------------------
5264    -- New_Internal_Entity --
5265    -------------------------
5266
5267    function New_Internal_Entity
5268      (Kind       : Entity_Kind;
5269       Scope_Id   : Entity_Id;
5270       Sloc_Value : Source_Ptr;
5271       Id_Char    : Character) return Entity_Id
5272    is
5273       N : constant Entity_Id :=
5274             Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
5275
5276    begin
5277       Set_Ekind          (N, Kind);
5278       Set_Is_Internal    (N, True);
5279       Append_Entity      (N, Scope_Id);
5280
5281       if Kind in Type_Kind then
5282          Init_Size_Align (N);
5283       end if;
5284
5285       return N;
5286    end New_Internal_Entity;
5287
5288    -----------------
5289    -- Next_Actual --
5290    -----------------
5291
5292    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
5293       N  : Node_Id;
5294
5295    begin
5296       --  If we are pointing at a positional parameter, it is a member of
5297       --  a node list (the list of parameters), and the next parameter
5298       --  is the next node on the list, unless we hit a parameter
5299       --  association, in which case we shift to using the chain whose
5300       --  head is the First_Named_Actual in the parent, and then is
5301       --  threaded using the Next_Named_Actual of the Parameter_Association.
5302       --  All this fiddling is because the original node list is in the
5303       --  textual call order, and what we need is the declaration order.
5304
5305       if Is_List_Member (Actual_Id) then
5306          N := Next (Actual_Id);
5307
5308          if Nkind (N) = N_Parameter_Association then
5309             return First_Named_Actual (Parent (Actual_Id));
5310          else
5311             return N;
5312          end if;
5313
5314       else
5315          return Next_Named_Actual (Parent (Actual_Id));
5316       end if;
5317    end Next_Actual;
5318
5319    procedure Next_Actual (Actual_Id : in out Node_Id) is
5320    begin
5321       Actual_Id := Next_Actual (Actual_Id);
5322    end Next_Actual;
5323
5324    -----------------------
5325    -- Normalize_Actuals --
5326    -----------------------
5327
5328    --  Chain actuals according to formals of subprogram. If there are no named
5329    --  associations, the chain is simply the list of Parameter Associations,
5330    --  since the order is the same as the declaration order. If there are named
5331    --  associations, then the First_Named_Actual field in the N_Function_Call
5332    --  or N_Procedure_Call_Statement node points to the Parameter_Association
5333    --  node for the parameter that comes first in declaration order. The
5334    --  remaining named parameters are then chained in declaration order using
5335    --  Next_Named_Actual.
5336
5337    --  This routine also verifies that the number of actuals is compatible with
5338    --  the number and default values of formals, but performs no type checking
5339    --  (type checking is done by the caller).
5340
5341    --  If the matching succeeds, Success is set to True and the caller proceeds
5342    --  with type-checking. If the match is unsuccessful, then Success is set to
5343    --  False, and the caller attempts a different interpretation, if there is
5344    --  one.
5345
5346    --  If the flag Report is on, the call is not overloaded, and a failure to
5347    --  match can be reported here, rather than in the caller.
5348
5349    procedure Normalize_Actuals
5350      (N       : Node_Id;
5351       S       : Entity_Id;
5352       Report  : Boolean;
5353       Success : out Boolean)
5354    is
5355       Actuals     : constant List_Id := Parameter_Associations (N);
5356       Actual      : Node_Id   := Empty;
5357       Formal      : Entity_Id;
5358       Last        : Node_Id := Empty;
5359       First_Named : Node_Id := Empty;
5360       Found       : Boolean;
5361
5362       Formals_To_Match : Integer := 0;
5363       Actuals_To_Match : Integer := 0;
5364
5365       procedure Chain (A : Node_Id);
5366       --  Add named actual at the proper place in the list, using the
5367       --  Next_Named_Actual link.
5368
5369       function Reporting return Boolean;
5370       --  Determines if an error is to be reported. To report an error, we
5371       --  need Report to be True, and also we do not report errors caused
5372       --  by calls to init procs that occur within other init procs. Such
5373       --  errors must always be cascaded errors, since if all the types are
5374       --  declared correctly, the compiler will certainly build decent calls!
5375
5376       -----------
5377       -- Chain --
5378       -----------
5379
5380       procedure Chain (A : Node_Id) is
5381       begin
5382          if No (Last) then
5383
5384             --  Call node points to first actual in list
5385
5386             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
5387
5388          else
5389             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
5390          end if;
5391
5392          Last := A;
5393          Set_Next_Named_Actual (Last, Empty);
5394       end Chain;
5395
5396       ---------------
5397       -- Reporting --
5398       ---------------
5399
5400       function Reporting return Boolean is
5401       begin
5402          if not Report then
5403             return False;
5404
5405          elsif not Within_Init_Proc then
5406             return True;
5407
5408          elsif Is_Init_Proc (Entity (Name (N))) then
5409             return False;
5410
5411          else
5412             return True;
5413          end if;
5414       end Reporting;
5415
5416    --  Start of processing for Normalize_Actuals
5417
5418    begin
5419       if Is_Access_Type (S) then
5420
5421          --  The name in the call is a function call that returns an access
5422          --  to subprogram. The designated type has the list of formals.
5423
5424          Formal := First_Formal (Designated_Type (S));
5425       else
5426          Formal := First_Formal (S);
5427       end if;
5428
5429       while Present (Formal) loop
5430          Formals_To_Match := Formals_To_Match + 1;
5431          Next_Formal (Formal);
5432       end loop;
5433
5434       --  Find if there is a named association, and verify that no positional
5435       --  associations appear after named ones.
5436
5437       if Present (Actuals) then
5438          Actual := First (Actuals);
5439       end if;
5440
5441       while Present (Actual)
5442         and then Nkind (Actual) /= N_Parameter_Association
5443       loop
5444          Actuals_To_Match := Actuals_To_Match + 1;
5445          Next (Actual);
5446       end loop;
5447
5448       if No (Actual) and Actuals_To_Match = Formals_To_Match then
5449
5450          --  Most common case: positional notation, no defaults
5451
5452          Success := True;
5453          return;
5454
5455       elsif Actuals_To_Match > Formals_To_Match then
5456
5457          --  Too many actuals: will not work
5458
5459          if Reporting then
5460             if Is_Entity_Name (Name (N)) then
5461                Error_Msg_N ("too many arguments in call to&", Name (N));
5462             else
5463                Error_Msg_N ("too many arguments in call", N);
5464             end if;
5465          end if;
5466
5467          Success := False;
5468          return;
5469       end if;
5470
5471       First_Named := Actual;
5472
5473       while Present (Actual) loop
5474          if Nkind (Actual) /= N_Parameter_Association then
5475             Error_Msg_N
5476               ("positional parameters not allowed after named ones", Actual);
5477             Success := False;
5478             return;
5479
5480          else
5481             Actuals_To_Match := Actuals_To_Match + 1;
5482          end if;
5483
5484          Next (Actual);
5485       end loop;
5486
5487       if Present (Actuals) then
5488          Actual := First (Actuals);
5489       end if;
5490
5491       Formal := First_Formal (S);
5492       while Present (Formal) loop
5493
5494          --  Match the formals in order. If the corresponding actual
5495          --  is positional,  nothing to do. Else scan the list of named
5496          --  actuals to find the one with the right name.
5497
5498          if Present (Actual)
5499            and then Nkind (Actual) /= N_Parameter_Association
5500          then
5501             Next (Actual);
5502             Actuals_To_Match := Actuals_To_Match - 1;
5503             Formals_To_Match := Formals_To_Match - 1;
5504
5505          else
5506             --  For named parameters, search the list of actuals to find
5507             --  one that matches the next formal name.
5508
5509             Actual := First_Named;
5510             Found  := False;
5511
5512             while Present (Actual) loop
5513                if Chars (Selector_Name (Actual)) = Chars (Formal) then
5514                   Found := True;
5515                   Chain (Actual);
5516                   Actuals_To_Match := Actuals_To_Match - 1;
5517                   Formals_To_Match := Formals_To_Match - 1;
5518                   exit;
5519                end if;
5520
5521                Next (Actual);
5522             end loop;
5523
5524             if not Found then
5525                if Ekind (Formal) /= E_In_Parameter
5526                  or else No (Default_Value (Formal))
5527                then
5528                   if Reporting then
5529                      if (Comes_From_Source (S)
5530                           or else Sloc (S) = Standard_Location)
5531                        and then Is_Overloadable (S)
5532                      then
5533                         if No (Actuals)
5534                           and then
5535                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
5536                              or else
5537                            (Nkind (Parent (N)) = N_Function_Call
5538                              or else
5539                             Nkind (Parent (N)) = N_Parameter_Association))
5540                           and then Ekind (S) /= E_Function
5541                         then
5542                            Set_Etype (N, Etype (S));
5543                         else
5544                            Error_Msg_Name_1 := Chars (S);
5545                            Error_Msg_Sloc := Sloc (S);
5546                            Error_Msg_NE
5547                              ("missing argument for parameter & " &
5548                                 "in call to % declared #", N, Formal);
5549                         end if;
5550
5551                      elsif Is_Overloadable (S) then
5552                         Error_Msg_Name_1 := Chars (S);
5553
5554                         --  Point to type derivation that generated the
5555                         --  operation.
5556
5557                         Error_Msg_Sloc := Sloc (Parent (S));
5558
5559                         Error_Msg_NE
5560                           ("missing argument for parameter & " &
5561                              "in call to % (inherited) #", N, Formal);
5562
5563                      else
5564                         Error_Msg_NE
5565                           ("missing argument for parameter &", N, Formal);
5566                      end if;
5567                   end if;
5568
5569                   Success := False;
5570                   return;
5571
5572                else
5573                   Formals_To_Match := Formals_To_Match - 1;
5574                end if;
5575             end if;
5576          end if;
5577
5578          Next_Formal (Formal);
5579       end loop;
5580
5581       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
5582          Success := True;
5583          return;
5584
5585       else
5586          if Reporting then
5587
5588             --  Find some superfluous named actual that did not get
5589             --  attached to the list of associations.
5590
5591             Actual := First (Actuals);
5592
5593             while Present (Actual) loop
5594                if Nkind (Actual) = N_Parameter_Association
5595                  and then Actual /= Last
5596                  and then No (Next_Named_Actual (Actual))
5597                then
5598                   Error_Msg_N ("unmatched actual & in call",
5599                     Selector_Name (Actual));
5600                   exit;
5601                end if;
5602
5603                Next (Actual);
5604             end loop;
5605          end if;
5606
5607          Success := False;
5608          return;
5609       end if;
5610    end Normalize_Actuals;
5611
5612    --------------------------------
5613    -- Note_Possible_Modification --
5614    --------------------------------
5615
5616    procedure Note_Possible_Modification (N : Node_Id) is
5617       Modification_Comes_From_Source : constant Boolean :=
5618                                          Comes_From_Source (Parent (N));
5619
5620       Ent : Entity_Id;
5621       Exp : Node_Id;
5622
5623    begin
5624       --  Loop to find referenced entity, if there is one
5625
5626       Exp := N;
5627       loop
5628          <<Continue>>
5629          Ent := Empty;
5630
5631          if Is_Entity_Name (Exp) then
5632             Ent := Entity (Exp);
5633
5634             --  If the entity is missing, it is an undeclared identifier,
5635             --  and there is nothing to annotate.
5636
5637             if No (Ent) then
5638                return;
5639             end if;
5640
5641          elsif Nkind (Exp) = N_Explicit_Dereference then
5642             declare
5643                P : constant Node_Id := Prefix (Exp);
5644
5645             begin
5646                if Nkind (P) = N_Selected_Component
5647                  and then Present (
5648                    Entry_Formal (Entity (Selector_Name (P))))
5649                then
5650                   --  Case of a reference to an entry formal
5651
5652                   Ent := Entry_Formal (Entity (Selector_Name (P)));
5653
5654                elsif Nkind (P) = N_Identifier
5655                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
5656                  and then Present (Expression (Parent (Entity (P))))
5657                  and then Nkind (Expression (Parent (Entity (P))))
5658                    = N_Reference
5659                then
5660                   --  Case of a reference to a value on which
5661                   --  side effects have been removed.
5662
5663                   Exp := Prefix (Expression (Parent (Entity (P))));
5664                   goto Continue;
5665
5666                else
5667                   return;
5668
5669                end if;
5670             end;
5671
5672          elsif     Nkind (Exp) = N_Type_Conversion
5673            or else Nkind (Exp) = N_Unchecked_Type_Conversion
5674          then
5675             Exp := Expression (Exp);
5676             goto Continue;
5677
5678          elsif     Nkind (Exp) = N_Slice
5679            or else Nkind (Exp) = N_Indexed_Component
5680            or else Nkind (Exp) = N_Selected_Component
5681          then
5682             Exp := Prefix (Exp);
5683             goto Continue;
5684
5685          else
5686             return;
5687          end if;
5688
5689          --  Now look for entity being referenced
5690
5691          if Present (Ent) then
5692             if Is_Object (Ent) then
5693                if Comes_From_Source (Exp)
5694                  or else Modification_Comes_From_Source
5695                then
5696                   Set_Never_Set_In_Source (Ent, False);
5697                end if;
5698
5699                Set_Is_True_Constant (Ent, False);
5700                Set_Current_Value    (Ent, Empty);
5701                Set_Is_Known_Null    (Ent, False);
5702
5703                if not Can_Never_Be_Null (Ent) then
5704                   Set_Is_Known_Non_Null (Ent, False);
5705                end if;
5706
5707                --  Follow renaming chain
5708
5709                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
5710                  and then Present (Renamed_Object (Ent))
5711                then
5712                   Exp := Renamed_Object (Ent);
5713                   goto Continue;
5714                end if;
5715
5716                --  Generate a reference only if the assignment comes from
5717                --  source. This excludes, for example, calls to a dispatching
5718                --  assignment operation when the left-hand side is tagged.
5719
5720                if Modification_Comes_From_Source then
5721                   Generate_Reference (Ent, Exp, 'm');
5722                end if;
5723             end if;
5724
5725             Kill_Checks (Ent);
5726             return;
5727          end if;
5728       end loop;
5729    end Note_Possible_Modification;
5730
5731    -------------------------
5732    -- Object_Access_Level --
5733    -------------------------
5734
5735    function Object_Access_Level (Obj : Node_Id) return Uint is
5736       E : Entity_Id;
5737
5738    --  Returns the static accessibility level of the view denoted
5739    --  by Obj.  Note that the value returned is the result of a
5740    --  call to Scope_Depth.  Only scope depths associated with
5741    --  dynamic scopes can actually be returned.  Since only
5742    --  relative levels matter for accessibility checking, the fact
5743    --  that the distance between successive levels of accessibility
5744    --  is not always one is immaterial (invariant: if level(E2) is
5745    --  deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5746
5747    begin
5748       if Is_Entity_Name (Obj) then
5749          E := Entity (Obj);
5750
5751          --  If E is a type then it denotes a current instance.
5752          --  For this case we add one to the normal accessibility
5753          --  level of the type to ensure that current instances
5754          --  are treated as always being deeper than than the level
5755          --  of any visible named access type (see 3.10.2(21)).
5756
5757          if Is_Type (E) then
5758             return Type_Access_Level (E) +  1;
5759
5760          elsif Present (Renamed_Object (E)) then
5761             return Object_Access_Level (Renamed_Object (E));
5762
5763          --  Similarly, if E is a component of the current instance of a
5764          --  protected type, any instance of it is assumed to be at a deeper
5765          --  level than the type. For a protected object (whose type is an
5766          --  anonymous protected type) its components are at the same level
5767          --  as the type itself.
5768
5769          elsif not Is_Overloadable (E)
5770            and then Ekind (Scope (E)) = E_Protected_Type
5771            and then Comes_From_Source (Scope (E))
5772          then
5773             return Type_Access_Level (Scope (E)) + 1;
5774
5775          else
5776             return Scope_Depth (Enclosing_Dynamic_Scope (E));
5777          end if;
5778
5779       elsif Nkind (Obj) = N_Selected_Component then
5780          if Is_Access_Type (Etype (Prefix (Obj))) then
5781             return Type_Access_Level (Etype (Prefix (Obj)));
5782          else
5783             return Object_Access_Level (Prefix (Obj));
5784          end if;
5785
5786       elsif Nkind (Obj) = N_Indexed_Component then
5787          if Is_Access_Type (Etype (Prefix (Obj))) then
5788             return Type_Access_Level (Etype (Prefix (Obj)));
5789          else
5790             return Object_Access_Level (Prefix (Obj));
5791          end if;
5792
5793       elsif Nkind (Obj) = N_Explicit_Dereference then
5794
5795          --  If the prefix is a selected access discriminant then
5796          --  we make a recursive call on the prefix, which will
5797          --  in turn check the level of the prefix object of
5798          --  the selected discriminant.
5799
5800          if Nkind (Prefix (Obj)) = N_Selected_Component
5801            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
5802            and then
5803              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
5804          then
5805             return Object_Access_Level (Prefix (Obj));
5806          else
5807             return Type_Access_Level (Etype (Prefix (Obj)));
5808          end if;
5809
5810       elsif Nkind (Obj) = N_Type_Conversion
5811         or else Nkind (Obj) = N_Unchecked_Type_Conversion
5812       then
5813          return Object_Access_Level (Expression (Obj));
5814
5815       --  Function results are objects, so we get either the access level
5816       --  of the function or, in the case of an indirect call, the level of
5817       --  of the access-to-subprogram type.
5818
5819       elsif Nkind (Obj) = N_Function_Call then
5820          if Is_Entity_Name (Name (Obj)) then
5821             return Subprogram_Access_Level (Entity (Name (Obj)));
5822          else
5823             return Type_Access_Level (Etype (Prefix (Name (Obj))));
5824          end if;
5825
5826       --  For convenience we handle qualified expressions, even though
5827       --  they aren't technically object names.
5828
5829       elsif Nkind (Obj) = N_Qualified_Expression then
5830          return Object_Access_Level (Expression (Obj));
5831
5832       --  Otherwise return the scope level of Standard.
5833       --  (If there are cases that fall through
5834       --  to this point they will be treated as
5835       --  having global accessibility for now. ???)
5836
5837       else
5838          return Scope_Depth (Standard_Standard);
5839       end if;
5840    end Object_Access_Level;
5841
5842    -----------------------
5843    -- Private_Component --
5844    -----------------------
5845
5846    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
5847       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
5848
5849       function Trace_Components
5850         (T     : Entity_Id;
5851          Check : Boolean) return Entity_Id;
5852       --  Recursive function that does the work, and checks against circular
5853       --  definition for each subcomponent type.
5854
5855       ----------------------
5856       -- Trace_Components --
5857       ----------------------
5858
5859       function Trace_Components
5860          (T     : Entity_Id;
5861           Check : Boolean) return Entity_Id
5862        is
5863          Btype     : constant Entity_Id := Base_Type (T);
5864          Component : Entity_Id;
5865          P         : Entity_Id;
5866          Candidate : Entity_Id := Empty;
5867
5868       begin
5869          if Check and then Btype = Ancestor then
5870             Error_Msg_N ("circular type definition", Type_Id);
5871             return Any_Type;
5872          end if;
5873
5874          if Is_Private_Type (Btype)
5875            and then not Is_Generic_Type (Btype)
5876          then
5877             if Present (Full_View (Btype))
5878               and then Is_Record_Type (Full_View (Btype))
5879               and then not Is_Frozen (Btype)
5880             then
5881                --  To indicate that the ancestor depends on a private type,
5882                --  the current Btype is sufficient. However, to check for
5883                --  circular definition we must recurse on the full view.
5884
5885                Candidate := Trace_Components (Full_View (Btype), True);
5886
5887                if Candidate = Any_Type then
5888                   return Any_Type;
5889                else
5890                   return Btype;
5891                end if;
5892
5893             else
5894                return Btype;
5895             end if;
5896
5897          elsif Is_Array_Type (Btype) then
5898             return Trace_Components (Component_Type (Btype), True);
5899
5900          elsif Is_Record_Type (Btype) then
5901             Component := First_Entity (Btype);
5902             while Present (Component) loop
5903
5904                --  Skip anonymous types generated by constrained components
5905
5906                if not Is_Type (Component) then
5907                   P := Trace_Components (Etype (Component), True);
5908
5909                   if Present (P) then
5910                      if P = Any_Type then
5911                         return P;
5912                      else
5913                         Candidate := P;
5914                      end if;
5915                   end if;
5916                end if;
5917
5918                Next_Entity (Component);
5919             end loop;
5920
5921             return Candidate;
5922
5923          else
5924             return Empty;
5925          end if;
5926       end Trace_Components;
5927
5928    --  Start of processing for Private_Component
5929
5930    begin
5931       return Trace_Components (Type_Id, False);
5932    end Private_Component;
5933
5934    -----------------------
5935    -- Process_End_Label --
5936    -----------------------
5937
5938    procedure Process_End_Label
5939      (N   : Node_Id;
5940       Typ : Character;
5941       Ent  : Entity_Id)
5942    is
5943       Loc  : Source_Ptr;
5944       Nam  : Node_Id;
5945
5946       Label_Ref : Boolean;
5947       --  Set True if reference to end label itself is required
5948
5949       Endl : Node_Id;
5950       --  Gets set to the operator symbol or identifier that references
5951       --  the entity Ent. For the child unit case, this is the identifier
5952       --  from the designator. For other cases, this is simply Endl.
5953
5954       procedure Generate_Parent_Ref (N : Node_Id);
5955       --  N is an identifier node that appears as a parent unit reference
5956       --  in the case where Ent is a child unit. This procedure generates
5957       --  an appropriate cross-reference entry.
5958
5959       -------------------------
5960       -- Generate_Parent_Ref --
5961       -------------------------
5962
5963       procedure Generate_Parent_Ref (N : Node_Id) is
5964          Parent_Ent : Entity_Id;
5965
5966       begin
5967          --  Search up scope stack. The reason we do this is that normal
5968          --  visibility analysis would not work for two reasons. First in
5969          --  some subunit cases, the entry for the parent unit may not be
5970          --  visible, and in any case there can be a local entity that
5971          --  hides the scope entity.
5972
5973          Parent_Ent := Current_Scope;
5974          while Present (Parent_Ent) loop
5975             if Chars (Parent_Ent) = Chars (N) then
5976
5977                --  Generate the reference. We do NOT consider this as a
5978                --  reference for unreferenced symbol purposes, but we do
5979                --  force a cross-reference even if the end line does not
5980                --  come from source (the caller already generated the
5981                --  appropriate Typ for this situation).
5982
5983                Generate_Reference
5984                  (Parent_Ent, N, 'r', Set_Ref => False, Force => True);
5985                Style.Check_Identifier (N, Parent_Ent);
5986                return;
5987             end if;
5988
5989             Parent_Ent := Scope (Parent_Ent);
5990          end loop;
5991
5992          --  Fall through means entity was not found -- that's odd, but
5993          --  the appropriate thing is simply to ignore and not generate
5994          --  any cross-reference for this entry.
5995
5996          return;
5997       end Generate_Parent_Ref;
5998
5999    --  Start of processing for Process_End_Label
6000
6001    begin
6002       --  If no node, ignore. This happens in some error situations,
6003       --  and also for some internally generated structures where no
6004       --  end label references are required in any case.
6005
6006       if No (N) then
6007          return;
6008       end if;
6009
6010       --  Nothing to do if no End_Label, happens for internally generated
6011       --  constructs where we don't want an end label reference anyway.
6012       --  Also nothing to do if Endl is a string literal, which means
6013       --  there was some prior error (bad operator symbol)
6014
6015       Endl := End_Label (N);
6016
6017       if No (Endl) or else Nkind (Endl) = N_String_Literal then
6018          return;
6019       end if;
6020
6021       --  Reference node is not in extended main source unit
6022
6023       if not In_Extended_Main_Source_Unit (N) then
6024
6025          --  Generally we do not collect references except for the
6026          --  extended main source unit. The one exception is the 'e'
6027          --  entry for a package spec, where it is useful for a client
6028          --  to have the ending information to define scopes.
6029
6030          if Typ /= 'e' then
6031             return;
6032
6033          else
6034             Label_Ref := False;
6035
6036             --  For this case, we can ignore any parent references,
6037             --  but we need the package name itself for the 'e' entry.
6038
6039             if Nkind (Endl) = N_Designator then
6040                Endl := Identifier (Endl);
6041             end if;
6042          end if;
6043
6044       --  Reference is in extended main source unit
6045
6046       else
6047          Label_Ref := True;
6048
6049          --  For designator, generate references for the parent entries
6050
6051          if Nkind (Endl) = N_Designator then
6052
6053             --  Generate references for the prefix if the END line comes
6054             --  from source (otherwise we do not need these references)
6055
6056             if Comes_From_Source (Endl) then
6057                Nam := Name (Endl);
6058                while Nkind (Nam) = N_Selected_Component loop
6059                   Generate_Parent_Ref (Selector_Name (Nam));
6060                   Nam := Prefix (Nam);
6061                end loop;
6062
6063                Generate_Parent_Ref (Nam);
6064             end if;
6065
6066             Endl := Identifier (Endl);
6067          end if;
6068       end if;
6069
6070       --  If the end label is not for the given entity, then either we have
6071       --  some previous error, or this is a generic instantiation for which
6072       --  we do not need to make a cross-reference in this case anyway. In
6073       --  either case we simply ignore the call.
6074
6075       if Chars (Ent) /= Chars (Endl) then
6076          return;
6077       end if;
6078
6079       --  If label was really there, then generate a normal reference
6080       --  and then adjust the location in the end label to point past
6081       --  the name (which should almost always be the semicolon).
6082
6083       Loc := Sloc (Endl);
6084
6085       if Comes_From_Source (Endl) then
6086
6087          --  If a label reference is required, then do the style check
6088          --  and generate an l-type cross-reference entry for the label
6089
6090          if Label_Ref then
6091             if Style_Check then
6092                Style.Check_Identifier (Endl, Ent);
6093             end if;
6094             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
6095          end if;
6096
6097          --  Set the location to point past the label (normally this will
6098          --  mean the semicolon immediately following the label). This is
6099          --  done for the sake of the 'e' or 't' entry generated below.
6100
6101          Get_Decoded_Name_String (Chars (Endl));
6102          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
6103       end if;
6104
6105       --  Now generate the e/t reference
6106
6107       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
6108
6109       --  Restore Sloc, in case modified above, since we have an identifier
6110       --  and the normal Sloc should be left set in the tree.
6111
6112       Set_Sloc (Endl, Loc);
6113    end Process_End_Label;
6114
6115    ------------------
6116    -- Real_Convert --
6117    ------------------
6118
6119    --  We do the conversion to get the value of the real string by using
6120    --  the scanner, see Sinput for details on use of the internal source
6121    --  buffer for scanning internal strings.
6122
6123    function Real_Convert (S : String) return Node_Id is
6124       Save_Src : constant Source_Buffer_Ptr := Source;
6125       Negative : Boolean;
6126
6127    begin
6128       Source := Internal_Source_Ptr;
6129       Scan_Ptr := 1;
6130
6131       for J in S'Range loop
6132          Source (Source_Ptr (J)) := S (J);
6133       end loop;
6134
6135       Source (S'Length + 1) := EOF;
6136
6137       if Source (Scan_Ptr) = '-' then
6138          Negative := True;
6139          Scan_Ptr := Scan_Ptr + 1;
6140       else
6141          Negative := False;
6142       end if;
6143
6144       Scan;
6145
6146       if Negative then
6147          Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
6148       end if;
6149
6150       Source := Save_Src;
6151       return Token_Node;
6152    end Real_Convert;
6153
6154    ---------------------
6155    -- Rep_To_Pos_Flag --
6156    ---------------------
6157
6158    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
6159    begin
6160       return New_Occurrence_Of
6161                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
6162    end Rep_To_Pos_Flag;
6163
6164    --------------------
6165    -- Require_Entity --
6166    --------------------
6167
6168    procedure Require_Entity (N : Node_Id) is
6169    begin
6170       if Is_Entity_Name (N) and then No (Entity (N)) then
6171          if Total_Errors_Detected /= 0 then
6172             Set_Entity (N, Any_Id);
6173          else
6174             raise Program_Error;
6175          end if;
6176       end if;
6177    end Require_Entity;
6178
6179    ------------------------------
6180    -- Requires_Transient_Scope --
6181    ------------------------------
6182
6183    --  A transient scope is required when variable-sized temporaries are
6184    --  allocated in the primary or secondary stack, or when finalization
6185    --  actions must be generated before the next instruction.
6186
6187    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
6188       Typ : constant Entity_Id := Underlying_Type (Id);
6189
6190    --  Start of processing for Requires_Transient_Scope
6191
6192    begin
6193       --  This is a private type which is not completed yet. This can only
6194       --  happen in a default expression (of a formal parameter or of a
6195       --  record component). Do not expand transient scope in this case
6196
6197       if No (Typ) then
6198          return False;
6199
6200       --  Do not expand transient scope for non-existent procedure return
6201
6202       elsif Typ = Standard_Void_Type then
6203          return False;
6204
6205       --  Elementary types do not require a transient scope
6206
6207       elsif Is_Elementary_Type (Typ) then
6208          return False;
6209
6210       --  Generally, indefinite subtypes require a transient scope, since the
6211       --  back end cannot generate temporaries, since this is not a valid type
6212       --  for declaring an object. It might be possible to relax this in the
6213       --  future, e.g. by declaring the maximum possible space for the type.
6214
6215       elsif Is_Indefinite_Subtype (Typ) then
6216          return True;
6217
6218       --  Functions returning tagged types may dispatch on result so their
6219       --  returned value is allocated on the secondary stack. Controlled
6220       --  type temporaries need finalization.
6221
6222       elsif Is_Tagged_Type (Typ)
6223         or else Has_Controlled_Component (Typ)
6224       then
6225          return True;
6226
6227       --  Record type
6228
6229       elsif Is_Record_Type (Typ) then
6230
6231          --  In GCC 2, discriminated records always require a transient
6232          --  scope because the back end otherwise tries to allocate a
6233          --  variable length temporary for the particular variant.
6234
6235          if Opt.GCC_Version = 2
6236            and then Has_Discriminants (Typ)
6237          then
6238             return True;
6239
6240          --  For GCC 3, or for a non-discriminated record in GCC 2, we are
6241          --  OK if none of the component types requires a transient scope.
6242          --  Note that we already know that this is a definite type (i.e.
6243          --  has discriminant defaults if it is a discriminated record).
6244
6245          else
6246             declare
6247                Comp : Entity_Id;
6248             begin
6249                Comp := First_Entity (Typ);
6250                while Present (Comp) loop
6251                   if Ekind (Comp) = E_Component
6252                      and then Requires_Transient_Scope (Etype (Comp))
6253                   then
6254                      return True;
6255                   else
6256                      Next_Entity (Comp);
6257                   end if;
6258                end loop;
6259             end;
6260
6261             return False;
6262          end if;
6263
6264       --  String literal types never require transient scope
6265
6266       elsif Ekind (Typ) = E_String_Literal_Subtype then
6267          return False;
6268
6269       --  Array type. Note that we already know that this is a constrained
6270       --  array, since unconstrained arrays will fail the indefinite test.
6271
6272       elsif Is_Array_Type (Typ) then
6273
6274          --  If component type requires a transient scope, the array does too
6275
6276          if Requires_Transient_Scope (Component_Type (Typ)) then
6277             return True;
6278
6279          --  Otherwise, we only need a transient scope if the size is not
6280          --  known at compile time.
6281
6282          else
6283             return not Size_Known_At_Compile_Time (Typ);
6284          end if;
6285
6286       --  All other cases do not require a transient scope
6287
6288       else
6289          return False;
6290       end if;
6291    end Requires_Transient_Scope;
6292
6293    --------------------------
6294    -- Reset_Analyzed_Flags --
6295    --------------------------
6296
6297    procedure Reset_Analyzed_Flags (N : Node_Id) is
6298
6299       function Clear_Analyzed
6300         (N : Node_Id) return Traverse_Result;
6301       --  Function used to reset Analyzed flags in tree. Note that we do
6302       --  not reset Analyzed flags in entities, since there is no need to
6303       --  renalalyze entities, and indeed, it is wrong to do so, since it
6304       --  can result in generating auxiliary stuff more than once.
6305
6306       --------------------
6307       -- Clear_Analyzed --
6308       --------------------
6309
6310       function Clear_Analyzed
6311         (N : Node_Id) return Traverse_Result
6312       is
6313       begin
6314          if not Has_Extension (N) then
6315             Set_Analyzed (N, False);
6316          end if;
6317
6318          return OK;
6319       end Clear_Analyzed;
6320
6321       function Reset_Analyzed is
6322         new Traverse_Func (Clear_Analyzed);
6323
6324       Discard : Traverse_Result;
6325       pragma Warnings (Off, Discard);
6326
6327    --  Start of processing for Reset_Analyzed_Flags
6328
6329    begin
6330       Discard := Reset_Analyzed (N);
6331    end Reset_Analyzed_Flags;
6332
6333    ---------------------------
6334    -- Safe_To_Capture_Value --
6335    ---------------------------
6336
6337    function Safe_To_Capture_Value
6338      (N   : Node_Id;
6339       Ent : Entity_Id) return Boolean
6340    is
6341    begin
6342       --  The only entities for which we track constant values are variables,
6343       --  out parameters and in out parameters, so check if we have this case.
6344
6345       if Ekind (Ent) /= E_Variable
6346            and then
6347          Ekind (Ent) /= E_Out_Parameter
6348            and then
6349          Ekind (Ent) /= E_In_Out_Parameter
6350       then
6351          return False;
6352       end if;
6353
6354       --  Skip volatile and aliased variables, since funny things might
6355       --  be going on in these cases which we cannot necessarily track.
6356       --  Also skip any variable for which an address clause is given.
6357
6358       --  Should we have a flag Has_Address_Clause ???
6359
6360       if Treat_As_Volatile (Ent)
6361         or else Is_Aliased (Ent)
6362         or else Present (Address_Clause (Ent))
6363       then
6364          return False;
6365       end if;
6366
6367       --  OK, all above conditions are met. We also require that the scope
6368       --  of the reference be the same as the scope of the entity, not
6369       --  counting packages and blocks.
6370
6371       declare
6372          E_Scope : constant Entity_Id := Scope (Ent);
6373          R_Scope : Entity_Id;
6374
6375       begin
6376          R_Scope := Current_Scope;
6377          while R_Scope /= Standard_Standard loop
6378             exit when R_Scope = E_Scope;
6379
6380             if Ekind (R_Scope) /= E_Package
6381                  and then
6382                Ekind (R_Scope) /= E_Block
6383             then
6384                return False;
6385             else
6386                R_Scope := Scope (R_Scope);
6387             end if;
6388          end loop;
6389       end;
6390
6391       --  We also require that the reference does not appear in a context
6392       --  where it is not sure to be executed (i.e. a conditional context
6393       --  or an exception handler).
6394
6395       declare
6396          Desc : Node_Id;
6397          P    : Node_Id;
6398
6399       begin
6400          Desc := N;
6401          P    := Parent (N);
6402          while Present (P) loop
6403             if Nkind (P) = N_If_Statement
6404               or else  Nkind (P) = N_Case_Statement
6405               or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P))
6406               or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P))
6407               or else  Nkind (P) = N_Exception_Handler
6408               or else  Nkind (P) = N_Selective_Accept
6409               or else  Nkind (P) = N_Conditional_Entry_Call
6410               or else  Nkind (P) = N_Timed_Entry_Call
6411               or else  Nkind (P) = N_Asynchronous_Select
6412             then
6413                return False;
6414             else
6415                Desc := P;
6416                P    := Parent (P);
6417             end if;
6418          end loop;
6419       end;
6420
6421       --  OK, looks safe to set value
6422
6423       return True;
6424    end Safe_To_Capture_Value;
6425
6426    ---------------
6427    -- Same_Name --
6428    ---------------
6429
6430    function Same_Name (N1, N2 : Node_Id) return Boolean is
6431       K1 : constant Node_Kind := Nkind (N1);
6432       K2 : constant Node_Kind := Nkind (N2);
6433
6434    begin
6435       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
6436         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
6437       then
6438          return Chars (N1) = Chars (N2);
6439
6440       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
6441         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
6442       then
6443          return Same_Name (Selector_Name (N1), Selector_Name (N2))
6444            and then Same_Name (Prefix (N1), Prefix (N2));
6445
6446       else
6447          return False;
6448       end if;
6449    end Same_Name;
6450
6451    ---------------
6452    -- Same_Type --
6453    ---------------
6454
6455    function Same_Type (T1, T2 : Entity_Id) return Boolean is
6456    begin
6457       if T1 = T2 then
6458          return True;
6459
6460       elsif not Is_Constrained (T1)
6461         and then not Is_Constrained (T2)
6462         and then Base_Type (T1) = Base_Type (T2)
6463       then
6464          return True;
6465
6466       --  For now don't bother with case of identical constraints, to be
6467       --  fiddled with later on perhaps (this is only used for optimization
6468       --  purposes, so it is not critical to do a best possible job)
6469
6470       else
6471          return False;
6472       end if;
6473    end Same_Type;
6474
6475    ------------------------
6476    -- Scope_Is_Transient --
6477    ------------------------
6478
6479    function Scope_Is_Transient  return Boolean is
6480    begin
6481       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
6482    end Scope_Is_Transient;
6483
6484    ------------------
6485    -- Scope_Within --
6486    ------------------
6487
6488    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
6489       Scop : Entity_Id;
6490
6491    begin
6492       Scop := Scope1;
6493       while Scop /= Standard_Standard loop
6494          Scop := Scope (Scop);
6495
6496          if Scop = Scope2 then
6497             return True;
6498          end if;
6499       end loop;
6500
6501       return False;
6502    end Scope_Within;
6503
6504    --------------------------
6505    -- Scope_Within_Or_Same --
6506    --------------------------
6507
6508    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
6509       Scop : Entity_Id;
6510
6511    begin
6512       Scop := Scope1;
6513       while Scop /= Standard_Standard loop
6514          if Scop = Scope2 then
6515             return True;
6516          else
6517             Scop := Scope (Scop);
6518          end if;
6519       end loop;
6520
6521       return False;
6522    end Scope_Within_Or_Same;
6523
6524    ------------------------
6525    -- Set_Current_Entity --
6526    ------------------------
6527
6528    --  The given entity is to be set as the currently visible definition
6529    --  of its associated name (i.e. the Node_Id associated with its name).
6530    --  All we have to do is to get the name from the identifier, and
6531    --  then set the associated Node_Id to point to the given entity.
6532
6533    procedure Set_Current_Entity (E : Entity_Id) is
6534    begin
6535       Set_Name_Entity_Id (Chars (E), E);
6536    end Set_Current_Entity;
6537
6538    ---------------------------------
6539    -- Set_Entity_With_Style_Check --
6540    ---------------------------------
6541
6542    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
6543       Val_Actual : Entity_Id;
6544       Nod        : Node_Id;
6545
6546    begin
6547       Set_Entity (N, Val);
6548
6549       if Style_Check
6550         and then not Suppress_Style_Checks (Val)
6551         and then not In_Instance
6552       then
6553          if Nkind (N) = N_Identifier then
6554             Nod := N;
6555
6556          elsif Nkind (N) = N_Expanded_Name then
6557             Nod := Selector_Name (N);
6558
6559          else
6560             return;
6561          end if;
6562
6563          --  A special situation arises for derived operations, where we want
6564          --  to do the check against the parent (since the Sloc of the derived
6565          --  operation points to the derived type declaration itself).
6566
6567          Val_Actual := Val;
6568          while not Comes_From_Source (Val_Actual)
6569            and then Nkind (Val_Actual) in N_Entity
6570            and then (Ekind (Val_Actual) = E_Enumeration_Literal
6571                       or else Is_Subprogram (Val_Actual)
6572                       or else Is_Generic_Subprogram (Val_Actual))
6573            and then Present (Alias (Val_Actual))
6574          loop
6575             Val_Actual := Alias (Val_Actual);
6576          end loop;
6577
6578          --  Renaming declarations for generic actuals do not come from source,
6579          --  and have a different name from that of the entity they rename, so
6580          --  there is no style check to perform here.
6581
6582          if Chars (Nod) = Chars (Val_Actual) then
6583             Style.Check_Identifier (Nod, Val_Actual);
6584          end if;
6585       end if;
6586
6587       Set_Entity (N, Val);
6588    end Set_Entity_With_Style_Check;
6589
6590    ------------------------
6591    -- Set_Name_Entity_Id --
6592    ------------------------
6593
6594    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
6595    begin
6596       Set_Name_Table_Info (Id, Int (Val));
6597    end Set_Name_Entity_Id;
6598
6599    ---------------------
6600    -- Set_Next_Actual --
6601    ---------------------
6602
6603    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
6604    begin
6605       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
6606          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
6607       end if;
6608    end Set_Next_Actual;
6609
6610    -----------------------
6611    -- Set_Public_Status --
6612    -----------------------
6613
6614    procedure Set_Public_Status (Id : Entity_Id) is
6615       S : constant Entity_Id := Current_Scope;
6616
6617    begin
6618       --  Everything in the scope of Standard is public
6619
6620       if S = Standard_Standard then
6621          Set_Is_Public (Id);
6622
6623       --  Entity is definitely not public if enclosing scope is not public
6624
6625       elsif not Is_Public (S) then
6626          return;
6627
6628       --  An object declaration that occurs in a handled sequence of statements
6629       --  is the declaration for a temporary object generated by the expander.
6630       --  It never needs to be made public and furthermore, making it public
6631       --  can cause back end problems if it is of variable size.
6632
6633       elsif Nkind (Parent (Id)) = N_Object_Declaration
6634         and then
6635           Nkind (Parent (Parent (Id))) = N_Handled_Sequence_Of_Statements
6636       then
6637          return;
6638
6639       --  Entities in public packages or records are public
6640
6641       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
6642          Set_Is_Public (Id);
6643
6644       --  The bounds of an entry family declaration can generate object
6645       --  declarations that are visible to the back-end, e.g. in the
6646       --  the declaration of a composite type that contains tasks.
6647
6648       elsif Is_Concurrent_Type (S)
6649         and then not Has_Completion (S)
6650         and then Nkind (Parent (Id)) = N_Object_Declaration
6651       then
6652          Set_Is_Public (Id);
6653       end if;
6654    end Set_Public_Status;
6655
6656    ----------------------------
6657    -- Set_Scope_Is_Transient --
6658    ----------------------------
6659
6660    procedure Set_Scope_Is_Transient (V : Boolean := True) is
6661    begin
6662       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
6663    end Set_Scope_Is_Transient;
6664
6665    -------------------
6666    -- Set_Size_Info --
6667    -------------------
6668
6669    procedure Set_Size_Info (T1, T2 : Entity_Id) is
6670    begin
6671       --  We copy Esize, but not RM_Size, since in general RM_Size is
6672       --  subtype specific and does not get inherited by all subtypes.
6673
6674       Set_Esize                     (T1, Esize                     (T2));
6675       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
6676
6677       if Is_Discrete_Or_Fixed_Point_Type (T1)
6678            and then
6679          Is_Discrete_Or_Fixed_Point_Type (T2)
6680       then
6681          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
6682       end if;
6683       Set_Alignment                 (T1, Alignment                 (T2));
6684    end Set_Size_Info;
6685
6686    --------------------
6687    -- Static_Integer --
6688    --------------------
6689
6690    function Static_Integer (N : Node_Id) return Uint is
6691    begin
6692       Analyze_And_Resolve (N, Any_Integer);
6693
6694       if N = Error
6695         or else Error_Posted (N)
6696         or else Etype (N) = Any_Type
6697       then
6698          return No_Uint;
6699       end if;
6700
6701       if Is_Static_Expression (N) then
6702          if not Raises_Constraint_Error (N) then
6703             return Expr_Value (N);
6704          else
6705             return No_Uint;
6706          end if;
6707
6708       elsif Etype (N) = Any_Type then
6709          return No_Uint;
6710
6711       else
6712          Flag_Non_Static_Expr
6713            ("static integer expression required here", N);
6714          return No_Uint;
6715       end if;
6716    end Static_Integer;
6717
6718    --------------------------
6719    -- Statically_Different --
6720    --------------------------
6721
6722    function Statically_Different (E1, E2 : Node_Id) return Boolean is
6723       R1 : constant Node_Id := Get_Referenced_Object (E1);
6724       R2 : constant Node_Id := Get_Referenced_Object (E2);
6725    begin
6726       return     Is_Entity_Name (R1)
6727         and then Is_Entity_Name (R2)
6728         and then Entity (R1) /= Entity (R2)
6729         and then not Is_Formal (Entity (R1))
6730         and then not Is_Formal (Entity (R2));
6731    end Statically_Different;
6732
6733    -----------------------------
6734    -- Subprogram_Access_Level --
6735    -----------------------------
6736
6737    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
6738    begin
6739       if Present (Alias (Subp)) then
6740          return Subprogram_Access_Level (Alias (Subp));
6741       else
6742          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
6743       end if;
6744    end Subprogram_Access_Level;
6745
6746    -----------------
6747    -- Trace_Scope --
6748    -----------------
6749
6750    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
6751    begin
6752       if Debug_Flag_W then
6753          for J in 0 .. Scope_Stack.Last loop
6754             Write_Str ("  ");
6755          end loop;
6756
6757          Write_Str (Msg);
6758          Write_Name (Chars (E));
6759          Write_Str ("   line ");
6760          Write_Int (Int (Get_Logical_Line_Number (Sloc (N))));
6761          Write_Eol;
6762       end if;
6763    end Trace_Scope;
6764
6765    -----------------------
6766    -- Transfer_Entities --
6767    -----------------------
6768
6769    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
6770       Ent : Entity_Id := First_Entity (From);
6771
6772    begin
6773       if No (Ent) then
6774          return;
6775       end if;
6776
6777       if (Last_Entity (To)) = Empty then
6778          Set_First_Entity (To, Ent);
6779       else
6780          Set_Next_Entity (Last_Entity (To), Ent);
6781       end if;
6782
6783       Set_Last_Entity (To, Last_Entity (From));
6784
6785       while Present (Ent) loop
6786          Set_Scope (Ent, To);
6787
6788          if not Is_Public (Ent) then
6789             Set_Public_Status (Ent);
6790
6791             if Is_Public (Ent)
6792               and then Ekind (Ent) = E_Record_Subtype
6793
6794             then
6795                --  The components of the propagated Itype must be public
6796                --  as well.
6797
6798                declare
6799                   Comp : Entity_Id;
6800
6801                begin
6802                   Comp := First_Entity (Ent);
6803                   while Present (Comp) loop
6804                      Set_Is_Public (Comp);
6805                      Next_Entity (Comp);
6806                   end loop;
6807                end;
6808             end if;
6809          end if;
6810
6811          Next_Entity (Ent);
6812       end loop;
6813
6814       Set_First_Entity (From, Empty);
6815       Set_Last_Entity (From, Empty);
6816    end Transfer_Entities;
6817
6818    -----------------------
6819    -- Type_Access_Level --
6820    -----------------------
6821
6822    function Type_Access_Level (Typ : Entity_Id) return Uint is
6823       Btyp : Entity_Id;
6824
6825    begin
6826       --  If the type is an anonymous access type we treat it as being
6827       --  declared at the library level to ensure that names such as
6828       --  X.all'access don't fail static accessibility checks.
6829
6830       --  Ada 2005 (AI-230): In case of anonymous access types that are
6831       --  component_definition or discriminants of a nonlimited type,
6832       --  the level is the same as that of the enclosing component type.
6833
6834       Btyp := Base_Type (Typ);
6835
6836       if Ekind (Btyp) in Access_Kind then
6837          if Ekind (Btyp) = E_Anonymous_Access_Type
6838            and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230)
6839          then
6840             return Scope_Depth (Standard_Standard);
6841          end if;
6842
6843          Btyp := Root_Type (Btyp);
6844
6845          --  The accessibility level of anonymous acccess types associated with
6846          --  discriminants is that of the current instance of the type, and
6847          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
6848
6849          if Ekind (Typ) = E_Anonymous_Access_Type
6850            and then Present (Associated_Node_For_Itype (Typ))
6851            and then Nkind (Associated_Node_For_Itype (Typ)) =
6852                                                  N_Discriminant_Specification
6853          then
6854             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
6855          end if;
6856       end if;
6857
6858       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
6859    end Type_Access_Level;
6860
6861    --------------------------
6862    -- Unit_Declaration_Node --
6863    --------------------------
6864
6865    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
6866       N : Node_Id := Parent (Unit_Id);
6867
6868    begin
6869       --  Predefined operators do not have a full function declaration
6870
6871       if Ekind (Unit_Id) = E_Operator then
6872          return N;
6873       end if;
6874
6875       while Nkind (N) /= N_Abstract_Subprogram_Declaration
6876         and then Nkind (N) /= N_Formal_Package_Declaration
6877         and then Nkind (N) /= N_Function_Instantiation
6878         and then Nkind (N) /= N_Generic_Package_Declaration
6879         and then Nkind (N) /= N_Generic_Subprogram_Declaration
6880         and then Nkind (N) /= N_Package_Declaration
6881         and then Nkind (N) /= N_Package_Body
6882         and then Nkind (N) /= N_Package_Instantiation
6883         and then Nkind (N) /= N_Package_Renaming_Declaration
6884         and then Nkind (N) /= N_Procedure_Instantiation
6885         and then Nkind (N) /= N_Protected_Body
6886         and then Nkind (N) /= N_Subprogram_Declaration
6887         and then Nkind (N) /= N_Subprogram_Body
6888         and then Nkind (N) /= N_Subprogram_Body_Stub
6889         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
6890         and then Nkind (N) /= N_Task_Body
6891         and then Nkind (N) /= N_Task_Type_Declaration
6892         and then Nkind (N) not in N_Formal_Subprogram_Declaration
6893         and then Nkind (N) not in N_Generic_Renaming_Declaration
6894       loop
6895          N := Parent (N);
6896          pragma Assert (Present (N));
6897       end loop;
6898
6899       return N;
6900    end Unit_Declaration_Node;
6901
6902    ------------------------------
6903    -- Universal_Interpretation --
6904    ------------------------------
6905
6906    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
6907       Index : Interp_Index;
6908       It    : Interp;
6909
6910    begin
6911       --  The argument may be a formal parameter of an operator or subprogram
6912       --  with multiple interpretations, or else an expression for an actual.
6913
6914       if Nkind (Opnd) = N_Defining_Identifier
6915         or else not Is_Overloaded (Opnd)
6916       then
6917          if Etype (Opnd) = Universal_Integer
6918            or else Etype (Opnd) = Universal_Real
6919          then
6920             return Etype (Opnd);
6921          else
6922             return Empty;
6923          end if;
6924
6925       else
6926          Get_First_Interp (Opnd, Index, It);
6927          while Present (It.Typ) loop
6928             if It.Typ = Universal_Integer
6929               or else It.Typ = Universal_Real
6930             then
6931                return It.Typ;
6932             end if;
6933
6934             Get_Next_Interp (Index, It);
6935          end loop;
6936
6937          return Empty;
6938       end if;
6939    end Universal_Interpretation;
6940
6941    ----------------------
6942    -- Within_Init_Proc --
6943    ----------------------
6944
6945    function Within_Init_Proc return Boolean is
6946       S : Entity_Id;
6947
6948    begin
6949       S := Current_Scope;
6950       while not Is_Overloadable (S) loop
6951          if S = Standard_Standard then
6952             return False;
6953          else
6954             S := Scope (S);
6955          end if;
6956       end loop;
6957
6958       return Is_Init_Proc (S);
6959    end Within_Init_Proc;
6960
6961    ----------------
6962    -- Wrong_Type --
6963    ----------------
6964
6965    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
6966       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
6967       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
6968
6969       function Has_One_Matching_Field return Boolean;
6970       --  Determines if Expec_Type is a record type with a single component or
6971       --  discriminant whose type matches the found type or is one dimensional
6972       --  array whose component type matches the found type.
6973
6974       ----------------------------
6975       -- Has_One_Matching_Field --
6976       ----------------------------
6977
6978       function Has_One_Matching_Field return Boolean is
6979          E : Entity_Id;
6980
6981       begin
6982          if Is_Array_Type (Expec_Type)
6983            and then Number_Dimensions (Expec_Type) = 1
6984            and then
6985              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
6986          then
6987             return True;
6988
6989          elsif not Is_Record_Type (Expec_Type) then
6990             return False;
6991
6992          else
6993             E := First_Entity (Expec_Type);
6994             loop
6995                if No (E) then
6996                   return False;
6997
6998                elsif (Ekind (E) /= E_Discriminant
6999                        and then Ekind (E) /= E_Component)
7000                  or else (Chars (E) = Name_uTag
7001                            or else Chars (E) = Name_uParent)
7002                then
7003                   Next_Entity (E);
7004
7005                else
7006                   exit;
7007                end if;
7008             end loop;
7009
7010             if not Covers (Etype (E), Found_Type) then
7011                return False;
7012
7013             elsif Present (Next_Entity (E)) then
7014                return False;
7015
7016             else
7017                return True;
7018             end if;
7019          end if;
7020       end Has_One_Matching_Field;
7021
7022    --  Start of processing for Wrong_Type
7023
7024    begin
7025       --  Don't output message if either type is Any_Type, or if a message
7026       --  has already been posted for this node. We need to do the latter
7027       --  check explicitly (it is ordinarily done in Errout), because we
7028       --  are using ! to force the output of the error messages.
7029
7030       if Expec_Type = Any_Type
7031         or else Found_Type = Any_Type
7032         or else Error_Posted (Expr)
7033       then
7034          return;
7035
7036       --  In  an instance, there is an ongoing problem with completion of
7037       --  type derived from private types. Their structure is what Gigi
7038       --  expects, but the  Etype is the parent type rather than the
7039       --  derived private type itself. Do not flag error in this case. The
7040       --  private completion is an entity without a parent, like an Itype.
7041       --  Similarly, full and partial views may be incorrect in the instance.
7042       --  There is no simple way to insure that it is consistent ???
7043
7044       elsif In_Instance then
7045
7046          if Etype (Etype (Expr)) = Etype (Expected_Type)
7047            and then
7048              (Has_Private_Declaration (Expected_Type)
7049                or else Has_Private_Declaration (Etype (Expr)))
7050            and then No (Parent (Expected_Type))
7051          then
7052             return;
7053          end if;
7054       end if;
7055
7056       --  An interesting special check. If the expression is parenthesized
7057       --  and its type corresponds to the type of the sole component of the
7058       --  expected record type, or to the component type of the expected one
7059       --  dimensional array type, then assume we have a bad aggregate attempt.
7060
7061       if Nkind (Expr) in N_Subexpr
7062         and then Paren_Count (Expr) /= 0
7063         and then Has_One_Matching_Field
7064       then
7065          Error_Msg_N ("positional aggregate cannot have one component", Expr);
7066
7067       --  Another special check, if we are looking for a pool-specific access
7068       --  type and we found an E_Access_Attribute_Type, then we have the case
7069       --  of an Access attribute being used in a context which needs a pool-
7070       --  specific type, which is never allowed. The one extra check we make
7071       --  is that the expected designated type covers the Found_Type.
7072
7073       elsif Is_Access_Type (Expec_Type)
7074         and then Ekind (Found_Type) = E_Access_Attribute_Type
7075         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
7076         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
7077         and then Covers
7078           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
7079       then
7080          Error_Msg_N ("result must be general access type!", Expr);
7081          Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
7082
7083       --  If the expected type is an anonymous access type, as for access
7084       --  parameters and discriminants, the error is on the designated types.
7085
7086       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
7087          if Comes_From_Source (Expec_Type) then
7088             Error_Msg_NE ("expected}!", Expr, Expec_Type);
7089          else
7090             Error_Msg_NE
7091               ("expected an access type with designated}",
7092                  Expr, Designated_Type (Expec_Type));
7093          end if;
7094
7095          if Is_Access_Type (Found_Type)
7096            and then not Comes_From_Source (Found_Type)
7097          then
7098             Error_Msg_NE
7099               ("found an access type with designated}!",
7100                 Expr, Designated_Type (Found_Type));
7101          else
7102             if From_With_Type (Found_Type) then
7103                Error_Msg_NE ("found incomplete}!", Expr, Found_Type);
7104                Error_Msg_NE
7105                  ("\possibly missing with_clause on&", Expr,
7106                    Scope (Found_Type));
7107             else
7108                Error_Msg_NE ("found}!", Expr, Found_Type);
7109             end if;
7110          end if;
7111
7112       --  Normal case of one type found, some other type expected
7113
7114       else
7115          --  If the names of the two types are the same, see if some
7116          --  number of levels of qualification will help. Don't try
7117          --  more than three levels, and if we get to standard, it's
7118          --  no use (and probably represents an error in the compiler)
7119          --  Also do not bother with internal scope names.
7120
7121          declare
7122             Expec_Scope : Entity_Id;
7123             Found_Scope : Entity_Id;
7124
7125          begin
7126             Expec_Scope := Expec_Type;
7127             Found_Scope := Found_Type;
7128
7129             for Levels in Int range 0 .. 3 loop
7130                if Chars (Expec_Scope) /= Chars (Found_Scope) then
7131                   Error_Msg_Qual_Level := Levels;
7132                   exit;
7133                end if;
7134
7135                Expec_Scope := Scope (Expec_Scope);
7136                Found_Scope := Scope (Found_Scope);
7137
7138                exit when Expec_Scope = Standard_Standard
7139                  or else Found_Scope = Standard_Standard
7140                  or else not Comes_From_Source (Expec_Scope)
7141                  or else not Comes_From_Source (Found_Scope);
7142             end loop;
7143          end;
7144
7145          if Is_Record_Type (Expec_Type)
7146            and then Present (Corresponding_Remote_Type (Expec_Type))
7147          then
7148             Error_Msg_NE ("expected}!", Expr,
7149                           Corresponding_Remote_Type (Expec_Type));
7150          else
7151             Error_Msg_NE ("expected}!", Expr, Expec_Type);
7152          end if;
7153
7154          if Is_Entity_Name (Expr)
7155            and then Is_Package_Or_Generic_Package (Entity (Expr))
7156          then
7157             Error_Msg_N ("found package name!", Expr);
7158
7159          elsif Is_Entity_Name (Expr)
7160            and then
7161              (Ekind (Entity (Expr)) = E_Procedure
7162                 or else
7163               Ekind (Entity (Expr)) = E_Generic_Procedure)
7164          then
7165             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
7166                Error_Msg_N
7167                  ("found procedure name, possibly missing Access attribute!",
7168                    Expr);
7169             else
7170                Error_Msg_N ("found procedure name instead of function!", Expr);
7171             end if;
7172
7173          elsif Nkind (Expr) = N_Function_Call
7174            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
7175            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
7176            and then No (Parameter_Associations (Expr))
7177          then
7178             Error_Msg_N
7179               ("found function name, possibly missing Access attribute!",
7180                Expr);
7181
7182          --  Catch common error: a prefix or infix operator which is not
7183          --  directly visible because the type isn't.
7184
7185          elsif Nkind (Expr) in N_Op
7186             and then Is_Overloaded (Expr)
7187             and then not Is_Immediately_Visible (Expec_Type)
7188             and then not Is_Potentially_Use_Visible (Expec_Type)
7189             and then not In_Use (Expec_Type)
7190             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
7191          then
7192             Error_Msg_N
7193               ("operator of the type is not directly visible!", Expr);
7194
7195          elsif Ekind (Found_Type) = E_Void
7196            and then Present (Parent (Found_Type))
7197            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
7198          then
7199             Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
7200
7201          else
7202             Error_Msg_NE ("found}!", Expr, Found_Type);
7203          end if;
7204
7205          Error_Msg_Qual_Level := 0;
7206       end if;
7207    end Wrong_Type;
7208
7209 end Sem_Util;