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