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          --  Ada0Y (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 or else (Ada_83 and then Comes_From_Source (N)) then
1097             Msgl := Msgl + 1;
1098             Msgc (Msgl) := '?';
1099             Wmsg := True;
1100
1101          elsif In_Instance_Not_Visible then
1102             Msgl := Msgl + 1;
1103             Msgc (Msgl) := '?';
1104             Wmsg := True;
1105
1106          --  Otherwise we have a real error message (Ada 95 static case)
1107
1108          else
1109             Wmsg := False;
1110          end if;
1111
1112          --  Should we generate a warning? The answer is not quite yes. The
1113          --  very annoying exception occurs in the case of a short circuit
1114          --  operator where the left operand is static and decisive. Climb
1115          --  parents to see if that is the case we have here.
1116
1117          Msgs := True;
1118          P := N;
1119
1120          loop
1121             P := Parent (P);
1122
1123             if (Nkind (P) = N_And_Then
1124                 and then Compile_Time_Known_Value (Left_Opnd (P))
1125                 and then Is_False (Expr_Value (Left_Opnd (P))))
1126               or else (Nkind (P) = N_Or_Else
1127                 and then Compile_Time_Known_Value (Left_Opnd (P))
1128                 and then Is_True (Expr_Value (Left_Opnd (P))))
1129             then
1130                Msgs := False;
1131                exit;
1132
1133             elsif Nkind (P) = N_Component_Association
1134               and then Nkind (Parent (P)) = N_Aggregate
1135             then
1136                null;  --   Keep going.
1137
1138             else
1139                exit when Nkind (P) not in N_Subexpr;
1140             end if;
1141          end loop;
1142
1143          if Msgs then
1144             if Present (Ent) then
1145                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
1146             else
1147                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
1148             end if;
1149
1150             if Wmsg then
1151                if Inside_Init_Proc then
1152                   Error_Msg_NEL
1153                     ("\& will be raised for objects of this type!?",
1154                      N, Standard_Constraint_Error, Eloc);
1155                else
1156                   Error_Msg_NEL
1157                     ("\& will be raised at run time!?",
1158                      N, Standard_Constraint_Error, Eloc);
1159                end if;
1160             else
1161                Error_Msg_NEL
1162                  ("\static expression raises&!",
1163                   N, Standard_Constraint_Error, Eloc);
1164             end if;
1165          end if;
1166       end if;
1167
1168       return N;
1169    end Compile_Time_Constraint_Error;
1170
1171    -----------------------
1172    -- Conditional_Delay --
1173    -----------------------
1174
1175    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
1176    begin
1177       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
1178          Set_Has_Delayed_Freeze (New_Ent);
1179       end if;
1180    end Conditional_Delay;
1181
1182    --------------------
1183    -- Current_Entity --
1184    --------------------
1185
1186    --  The currently visible definition for a given identifier is the
1187    --  one most chained at the start of the visibility chain, i.e. the
1188    --  one that is referenced by the Node_Id value of the name of the
1189    --  given identifier.
1190
1191    function Current_Entity (N : Node_Id) return Entity_Id is
1192    begin
1193       return Get_Name_Entity_Id (Chars (N));
1194    end Current_Entity;
1195
1196    -----------------------------
1197    -- Current_Entity_In_Scope --
1198    -----------------------------
1199
1200    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
1201       E  : Entity_Id;
1202       CS : constant Entity_Id := Current_Scope;
1203
1204       Transient_Case : constant Boolean := Scope_Is_Transient;
1205
1206    begin
1207       E := Get_Name_Entity_Id (Chars (N));
1208
1209       while Present (E)
1210         and then Scope (E) /= CS
1211         and then (not Transient_Case or else Scope (E) /= Scope (CS))
1212       loop
1213          E := Homonym (E);
1214       end loop;
1215
1216       return E;
1217    end Current_Entity_In_Scope;
1218
1219    -------------------
1220    -- Current_Scope --
1221    -------------------
1222
1223    function Current_Scope return Entity_Id is
1224    begin
1225       if Scope_Stack.Last = -1 then
1226          return Standard_Standard;
1227       else
1228          declare
1229             C : constant Entity_Id :=
1230                   Scope_Stack.Table (Scope_Stack.Last).Entity;
1231          begin
1232             if Present (C) then
1233                return C;
1234             else
1235                return Standard_Standard;
1236             end if;
1237          end;
1238       end if;
1239    end Current_Scope;
1240
1241    ------------------------
1242    -- Current_Subprogram --
1243    ------------------------
1244
1245    function Current_Subprogram return Entity_Id is
1246       Scop : constant Entity_Id := Current_Scope;
1247
1248    begin
1249       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
1250          return Scop;
1251       else
1252          return Enclosing_Subprogram (Scop);
1253       end if;
1254    end Current_Subprogram;
1255
1256    ---------------------
1257    -- Defining_Entity --
1258    ---------------------
1259
1260    function Defining_Entity (N : Node_Id) return Entity_Id is
1261       K   : constant Node_Kind := Nkind (N);
1262       Err : Entity_Id := Empty;
1263
1264    begin
1265       case K is
1266          when
1267            N_Subprogram_Declaration                 |
1268            N_Abstract_Subprogram_Declaration        |
1269            N_Subprogram_Body                        |
1270            N_Package_Declaration                    |
1271            N_Subprogram_Renaming_Declaration        |
1272            N_Subprogram_Body_Stub                   |
1273            N_Generic_Subprogram_Declaration         |
1274            N_Generic_Package_Declaration            |
1275            N_Formal_Subprogram_Declaration
1276          =>
1277             return Defining_Entity (Specification (N));
1278
1279          when
1280            N_Component_Declaration                  |
1281            N_Defining_Program_Unit_Name             |
1282            N_Discriminant_Specification             |
1283            N_Entry_Body                             |
1284            N_Entry_Declaration                      |
1285            N_Entry_Index_Specification              |
1286            N_Exception_Declaration                  |
1287            N_Exception_Renaming_Declaration         |
1288            N_Formal_Object_Declaration              |
1289            N_Formal_Package_Declaration             |
1290            N_Formal_Type_Declaration                |
1291            N_Full_Type_Declaration                  |
1292            N_Implicit_Label_Declaration             |
1293            N_Incomplete_Type_Declaration            |
1294            N_Loop_Parameter_Specification           |
1295            N_Number_Declaration                     |
1296            N_Object_Declaration                     |
1297            N_Object_Renaming_Declaration            |
1298            N_Package_Body_Stub                      |
1299            N_Parameter_Specification                |
1300            N_Private_Extension_Declaration          |
1301            N_Private_Type_Declaration               |
1302            N_Protected_Body                         |
1303            N_Protected_Body_Stub                    |
1304            N_Protected_Type_Declaration             |
1305            N_Single_Protected_Declaration           |
1306            N_Single_Task_Declaration                |
1307            N_Subtype_Declaration                    |
1308            N_Task_Body                              |
1309            N_Task_Body_Stub                         |
1310            N_Task_Type_Declaration
1311          =>
1312             return Defining_Identifier (N);
1313
1314          when N_Subunit =>
1315             return Defining_Entity (Proper_Body (N));
1316
1317          when
1318            N_Function_Instantiation                 |
1319            N_Function_Specification                 |
1320            N_Generic_Function_Renaming_Declaration  |
1321            N_Generic_Package_Renaming_Declaration   |
1322            N_Generic_Procedure_Renaming_Declaration |
1323            N_Package_Body                           |
1324            N_Package_Instantiation                  |
1325            N_Package_Renaming_Declaration           |
1326            N_Package_Specification                  |
1327            N_Procedure_Instantiation                |
1328            N_Procedure_Specification
1329          =>
1330             declare
1331                Nam : constant Node_Id := Defining_Unit_Name (N);
1332
1333             begin
1334                if Nkind (Nam) in N_Entity then
1335                   return Nam;
1336
1337                --  For Error, make up a name and attach to declaration
1338                --  so we can continue semantic analysis
1339
1340                elsif Nam = Error then
1341                   Err :=
1342                     Make_Defining_Identifier (Sloc (N),
1343                       Chars => New_Internal_Name ('T'));
1344                   Set_Defining_Unit_Name (N, Err);
1345
1346                   return Err;
1347                --  If not an entity, get defining identifier
1348
1349                else
1350                   return Defining_Identifier (Nam);
1351                end if;
1352             end;
1353
1354          when N_Block_Statement =>
1355             return Entity (Identifier (N));
1356
1357          when others =>
1358             raise Program_Error;
1359
1360       end case;
1361    end Defining_Entity;
1362
1363    --------------------------
1364    -- Denotes_Discriminant --
1365    --------------------------
1366
1367    function Denotes_Discriminant
1368      (N               : Node_Id;
1369       Check_Protected : Boolean := False) return Boolean
1370    is
1371       E : Entity_Id;
1372    begin
1373       if not Is_Entity_Name (N)
1374         or else No (Entity (N))
1375       then
1376          return False;
1377       else
1378          E := Entity (N);
1379       end if;
1380
1381       --  If we are checking for a protected type, the discriminant may have
1382       --  been rewritten as the corresponding discriminal of the original type
1383       --  or of the corresponding concurrent record, depending on whether we
1384       --  are in the spec or body of the protected type.
1385
1386       return Ekind (E) = E_Discriminant
1387         or else
1388           (Check_Protected
1389             and then Ekind (E) = E_In_Parameter
1390             and then Present (Discriminal_Link (E))
1391             and then
1392               (Is_Protected_Type (Scope (Discriminal_Link (E)))
1393                 or else
1394                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
1395
1396    end Denotes_Discriminant;
1397
1398    -----------------------------
1399    -- Depends_On_Discriminant --
1400    -----------------------------
1401
1402    function Depends_On_Discriminant (N : Node_Id) return Boolean is
1403       L : Node_Id;
1404       H : Node_Id;
1405
1406    begin
1407       Get_Index_Bounds (N, L, H);
1408       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
1409    end Depends_On_Discriminant;
1410
1411    -------------------------
1412    -- Designate_Same_Unit --
1413    -------------------------
1414
1415    function Designate_Same_Unit
1416      (Name1 : Node_Id;
1417       Name2 : Node_Id) return Boolean
1418    is
1419       K1 : constant Node_Kind := Nkind (Name1);
1420       K2 : constant Node_Kind := Nkind (Name2);
1421
1422       function Prefix_Node (N : Node_Id) return Node_Id;
1423       --  Returns the parent unit name node of a defining program unit name
1424       --  or the prefix if N is a selected component or an expanded name.
1425
1426       function Select_Node (N : Node_Id) return Node_Id;
1427       --  Returns the defining identifier node of a defining program unit
1428       --  name or  the selector node if N is a selected component or an
1429       --  expanded name.
1430
1431       -----------------
1432       -- Prefix_Node --
1433       -----------------
1434
1435       function Prefix_Node (N : Node_Id) return Node_Id is
1436       begin
1437          if Nkind (N) = N_Defining_Program_Unit_Name then
1438             return Name (N);
1439
1440          else
1441             return Prefix (N);
1442          end if;
1443       end Prefix_Node;
1444
1445       -----------------
1446       -- Select_Node --
1447       -----------------
1448
1449       function Select_Node (N : Node_Id) return Node_Id is
1450       begin
1451          if Nkind (N) = N_Defining_Program_Unit_Name then
1452             return Defining_Identifier (N);
1453
1454          else
1455             return Selector_Name (N);
1456          end if;
1457       end Select_Node;
1458
1459    --  Start of processing for Designate_Next_Unit
1460
1461    begin
1462       if (K1 = N_Identifier or else
1463           K1 = N_Defining_Identifier)
1464         and then
1465          (K2 = N_Identifier or else
1466           K2 = N_Defining_Identifier)
1467       then
1468          return Chars (Name1) = Chars (Name2);
1469
1470       elsif
1471          (K1 = N_Expanded_Name      or else
1472           K1 = N_Selected_Component or else
1473           K1 = N_Defining_Program_Unit_Name)
1474         and then
1475          (K2 = N_Expanded_Name      or else
1476           K2 = N_Selected_Component or else
1477           K2 = N_Defining_Program_Unit_Name)
1478       then
1479          return
1480            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
1481              and then
1482                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
1483
1484       else
1485          return False;
1486       end if;
1487    end Designate_Same_Unit;
1488
1489    ----------------------------
1490    -- Enclosing_Generic_Body --
1491    ----------------------------
1492
1493    function Enclosing_Generic_Body
1494      (E : Entity_Id) return Node_Id
1495    is
1496       P    : Node_Id;
1497       Decl : Node_Id;
1498       Spec : Node_Id;
1499
1500    begin
1501       P := Parent (E);
1502
1503       while Present (P) loop
1504          if Nkind (P) = N_Package_Body
1505            or else Nkind (P) = N_Subprogram_Body
1506          then
1507             Spec := Corresponding_Spec (P);
1508
1509             if Present (Spec) then
1510                Decl := Unit_Declaration_Node (Spec);
1511
1512                if Nkind (Decl) = N_Generic_Package_Declaration
1513                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
1514                then
1515                   return P;
1516                end if;
1517             end if;
1518          end if;
1519
1520          P := Parent (P);
1521       end loop;
1522
1523       return Empty;
1524    end Enclosing_Generic_Body;
1525
1526    -------------------------------
1527    -- Enclosing_Lib_Unit_Entity --
1528    -------------------------------
1529
1530    function Enclosing_Lib_Unit_Entity return Entity_Id is
1531       Unit_Entity : Entity_Id := Current_Scope;
1532
1533    begin
1534       --  Look for enclosing library unit entity by following scope links.
1535       --  Equivalent to, but faster than indexing through the scope stack.
1536
1537       while (Present (Scope (Unit_Entity))
1538         and then Scope (Unit_Entity) /= Standard_Standard)
1539         and not Is_Child_Unit (Unit_Entity)
1540       loop
1541          Unit_Entity := Scope (Unit_Entity);
1542       end loop;
1543
1544       return Unit_Entity;
1545    end Enclosing_Lib_Unit_Entity;
1546
1547    -----------------------------
1548    -- Enclosing_Lib_Unit_Node --
1549    -----------------------------
1550
1551    function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
1552       Current_Node : Node_Id := N;
1553
1554    begin
1555       while Present (Current_Node)
1556         and then Nkind (Current_Node) /= N_Compilation_Unit
1557       loop
1558          Current_Node := Parent (Current_Node);
1559       end loop;
1560
1561       if Nkind (Current_Node) /= N_Compilation_Unit then
1562          return Empty;
1563       end if;
1564
1565       return Current_Node;
1566    end Enclosing_Lib_Unit_Node;
1567
1568    --------------------------
1569    -- Enclosing_Subprogram --
1570    --------------------------
1571
1572    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
1573       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
1574
1575    begin
1576       if Dynamic_Scope = Standard_Standard then
1577          return Empty;
1578
1579       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
1580          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
1581
1582       elsif Ekind (Dynamic_Scope) = E_Block then
1583          return Enclosing_Subprogram (Dynamic_Scope);
1584
1585       elsif Ekind (Dynamic_Scope) = E_Task_Type then
1586          return Get_Task_Body_Procedure (Dynamic_Scope);
1587
1588       elsif Convention (Dynamic_Scope) = Convention_Protected then
1589          return Protected_Body_Subprogram (Dynamic_Scope);
1590
1591       else
1592          return Dynamic_Scope;
1593       end if;
1594    end Enclosing_Subprogram;
1595
1596    ------------------------
1597    -- Ensure_Freeze_Node --
1598    ------------------------
1599
1600    procedure Ensure_Freeze_Node (E : Entity_Id) is
1601       FN : Node_Id;
1602
1603    begin
1604       if No (Freeze_Node (E)) then
1605          FN := Make_Freeze_Entity (Sloc (E));
1606          Set_Has_Delayed_Freeze (E);
1607          Set_Freeze_Node (E, FN);
1608          Set_Access_Types_To_Process (FN, No_Elist);
1609          Set_TSS_Elist (FN, No_Elist);
1610          Set_Entity (FN, E);
1611       end if;
1612    end Ensure_Freeze_Node;
1613
1614    ----------------
1615    -- Enter_Name --
1616    ----------------
1617
1618    procedure Enter_Name (Def_Id : Node_Id) is
1619       C : constant Entity_Id := Current_Entity (Def_Id);
1620       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
1621       S : constant Entity_Id := Current_Scope;
1622
1623    begin
1624       Generate_Definition (Def_Id);
1625
1626       --  Add new name to current scope declarations. Check for duplicate
1627       --  declaration, which may or may not be a genuine error.
1628
1629       if Present (E) then
1630
1631          --  Case of previous entity entered because of a missing declaration
1632          --  or else a bad subtype indication. Best is to use the new entity,
1633          --  and make the previous one invisible.
1634
1635          if Etype (E) = Any_Type then
1636             Set_Is_Immediately_Visible (E, False);
1637
1638          --  Case of renaming declaration constructed for package instances.
1639          --  if there is an explicit declaration with the same identifier,
1640          --  the renaming is not immediately visible any longer, but remains
1641          --  visible through selected component notation.
1642
1643          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
1644            and then not Comes_From_Source (E)
1645          then
1646             Set_Is_Immediately_Visible (E, False);
1647
1648          --  The new entity may be the package renaming, which has the same
1649          --  same name as a generic formal which has been seen already.
1650
1651          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
1652             and then not Comes_From_Source (Def_Id)
1653          then
1654             Set_Is_Immediately_Visible (E, False);
1655
1656          --  For a fat pointer corresponding to a remote access to subprogram,
1657          --  we use the same identifier as the RAS type, so that the proper
1658          --  name appears in the stub. This type is only retrieved through
1659          --  the RAS type and never by visibility, and is not added to the
1660          --  visibility list (see below).
1661
1662          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
1663            and then Present (Corresponding_Remote_Type (Def_Id))
1664          then
1665             null;
1666
1667          --  A controller component for a type extension overrides the
1668          --  inherited component.
1669
1670          elsif Chars (E) = Name_uController then
1671             null;
1672
1673          --  Case of an implicit operation or derived literal. The new entity
1674          --  hides the implicit one,  which is removed from all visibility,
1675          --  i.e. the entity list of its scope, and homonym chain of its name.
1676
1677          elsif (Is_Overloadable (E) and then Present (Alias (E)))
1678            or else Is_Internal (E)
1679            or else (Ekind (E) = E_Enumeration_Literal
1680                      and then Is_Derived_Type (Etype (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       else           --  Nkind (Decl) = N_Subprogram_Declaration
2660
2661          if Present (Corresponding_Body (Decl)) then
2662             return Unit_Declaration_Node (Corresponding_Body (Decl));
2663
2664          else        --  imported subprogram.
2665             return Empty;
2666          end if;
2667       end if;
2668    end Get_Subprogram_Body;
2669
2670    -----------------------------
2671    -- Get_Task_Body_Procedure --
2672    -----------------------------
2673
2674    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
2675    begin
2676       return Task_Body_Procedure (Declaration_Node (Root_Type (E)));
2677    end Get_Task_Body_Procedure;
2678
2679    ----------------------
2680    -- Has_Declarations --
2681    ----------------------
2682
2683    function Has_Declarations (N : Node_Id) return Boolean is
2684       K : constant Node_Kind := Nkind (N);
2685    begin
2686       return    K = N_Accept_Statement
2687         or else K = N_Block_Statement
2688         or else K = N_Compilation_Unit_Aux
2689         or else K = N_Entry_Body
2690         or else K = N_Package_Body
2691         or else K = N_Protected_Body
2692         or else K = N_Subprogram_Body
2693         or else K = N_Task_Body
2694         or else K = N_Package_Specification;
2695    end Has_Declarations;
2696
2697    --------------------
2698    -- Has_Infinities --
2699    --------------------
2700
2701    function Has_Infinities (E : Entity_Id) return Boolean is
2702    begin
2703       return
2704         Is_Floating_Point_Type (E)
2705           and then Nkind (Scalar_Range (E)) = N_Range
2706           and then Includes_Infinities (Scalar_Range (E));
2707    end Has_Infinities;
2708
2709    ------------------------
2710    -- Has_Null_Extension --
2711    ------------------------
2712
2713    function Has_Null_Extension (T : Entity_Id) return Boolean is
2714       B     : constant Entity_Id := Base_Type (T);
2715       Comps : Node_Id;
2716       Ext   : Node_Id;
2717
2718    begin
2719       if Nkind (Parent (B)) = N_Full_Type_Declaration
2720         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
2721       then
2722          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
2723
2724          if Present (Ext) then
2725             if Null_Present (Ext) then
2726                return True;
2727             else
2728                Comps := Component_List (Ext);
2729
2730                --  The null component list is rewritten during analysis to
2731                --  include the parent component. Any other component indicates
2732                --  that the extension was not originally null.
2733
2734                return Null_Present (Comps)
2735                  or else No (Next (First (Component_Items (Comps))));
2736             end if;
2737          else
2738             return False;
2739          end if;
2740
2741       else
2742          return False;
2743       end if;
2744    end Has_Null_Extension;
2745
2746    ---------------------------
2747    -- Has_Private_Component --
2748    ---------------------------
2749
2750    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
2751       Btype     : Entity_Id := Base_Type (Type_Id);
2752       Component : Entity_Id;
2753
2754    begin
2755       if Error_Posted (Type_Id)
2756         or else Error_Posted (Btype)
2757       then
2758          return False;
2759       end if;
2760
2761       if Is_Class_Wide_Type (Btype) then
2762          Btype := Root_Type (Btype);
2763       end if;
2764
2765       if Is_Private_Type (Btype) then
2766          declare
2767             UT : constant Entity_Id := Underlying_Type (Btype);
2768          begin
2769             if No (UT) then
2770
2771                if No (Full_View (Btype)) then
2772                   return not Is_Generic_Type (Btype)
2773                     and then not Is_Generic_Type (Root_Type (Btype));
2774
2775                else
2776                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
2777                end if;
2778
2779             else
2780                return not Is_Frozen (UT) and then Has_Private_Component (UT);
2781             end if;
2782          end;
2783       elsif Is_Array_Type (Btype) then
2784          return Has_Private_Component (Component_Type (Btype));
2785
2786       elsif Is_Record_Type (Btype) then
2787
2788          Component := First_Component (Btype);
2789          while Present (Component) loop
2790
2791             if Has_Private_Component (Etype (Component)) then
2792                return True;
2793             end if;
2794
2795             Next_Component (Component);
2796          end loop;
2797
2798          return False;
2799
2800       elsif Is_Protected_Type (Btype)
2801         and then Present (Corresponding_Record_Type (Btype))
2802       then
2803          return Has_Private_Component (Corresponding_Record_Type (Btype));
2804
2805       else
2806          return False;
2807       end if;
2808    end Has_Private_Component;
2809
2810    --------------------------
2811    -- Has_Tagged_Component --
2812    --------------------------
2813
2814    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
2815       Comp : Entity_Id;
2816
2817    begin
2818       if Is_Private_Type (Typ)
2819         and then Present (Underlying_Type (Typ))
2820       then
2821          return Has_Tagged_Component (Underlying_Type (Typ));
2822
2823       elsif Is_Array_Type (Typ) then
2824          return Has_Tagged_Component (Component_Type (Typ));
2825
2826       elsif Is_Tagged_Type (Typ) then
2827          return True;
2828
2829       elsif Is_Record_Type (Typ) then
2830          Comp := First_Component (Typ);
2831
2832          while Present (Comp) loop
2833             if Has_Tagged_Component (Etype (Comp)) then
2834                return True;
2835             end if;
2836
2837             Comp := Next_Component (Typ);
2838          end loop;
2839
2840          return False;
2841
2842       else
2843          return False;
2844       end if;
2845    end Has_Tagged_Component;
2846
2847    -----------------
2848    -- In_Instance --
2849    -----------------
2850
2851    function In_Instance return Boolean is
2852       S : Entity_Id := Current_Scope;
2853
2854    begin
2855       while Present (S)
2856         and then S /= Standard_Standard
2857       loop
2858          if (Ekind (S) = E_Function
2859               or else Ekind (S) = E_Package
2860               or else Ekind (S) = E_Procedure)
2861            and then Is_Generic_Instance (S)
2862          then
2863             return True;
2864          end if;
2865
2866          S := Scope (S);
2867       end loop;
2868
2869       return False;
2870    end In_Instance;
2871
2872    ----------------------
2873    -- In_Instance_Body --
2874    ----------------------
2875
2876    function In_Instance_Body return Boolean is
2877       S : Entity_Id := Current_Scope;
2878
2879    begin
2880       while Present (S)
2881         and then S /= Standard_Standard
2882       loop
2883          if (Ekind (S) = E_Function
2884               or else Ekind (S) = E_Procedure)
2885            and then Is_Generic_Instance (S)
2886          then
2887             return True;
2888
2889          elsif Ekind (S) = E_Package
2890            and then In_Package_Body (S)
2891            and then Is_Generic_Instance (S)
2892          then
2893             return True;
2894          end if;
2895
2896          S := Scope (S);
2897       end loop;
2898
2899       return False;
2900    end In_Instance_Body;
2901
2902    -----------------------------
2903    -- In_Instance_Not_Visible --
2904    -----------------------------
2905
2906    function In_Instance_Not_Visible return Boolean is
2907       S : Entity_Id := Current_Scope;
2908
2909    begin
2910       while Present (S)
2911         and then S /= Standard_Standard
2912       loop
2913          if (Ekind (S) = E_Function
2914               or else Ekind (S) = E_Procedure)
2915            and then Is_Generic_Instance (S)
2916          then
2917             return True;
2918
2919          elsif Ekind (S) = E_Package
2920            and then (In_Package_Body (S) or else In_Private_Part (S))
2921            and then Is_Generic_Instance (S)
2922          then
2923             return True;
2924          end if;
2925
2926          S := Scope (S);
2927       end loop;
2928
2929       return False;
2930    end In_Instance_Not_Visible;
2931
2932    ------------------------------
2933    -- In_Instance_Visible_Part --
2934    ------------------------------
2935
2936    function In_Instance_Visible_Part return Boolean is
2937       S : Entity_Id := Current_Scope;
2938
2939    begin
2940       while Present (S)
2941         and then S /= Standard_Standard
2942       loop
2943          if Ekind (S) = E_Package
2944            and then Is_Generic_Instance (S)
2945            and then not In_Package_Body (S)
2946            and then not In_Private_Part (S)
2947          then
2948             return True;
2949          end if;
2950
2951          S := Scope (S);
2952       end loop;
2953
2954       return False;
2955    end In_Instance_Visible_Part;
2956
2957    ----------------------
2958    -- In_Packiage_Body --
2959    ----------------------
2960
2961    function In_Package_Body return Boolean is
2962       S : Entity_Id := Current_Scope;
2963
2964    begin
2965       while Present (S)
2966         and then S /= Standard_Standard
2967       loop
2968          if Ekind (S) = E_Package
2969            and then In_Package_Body (S)
2970          then
2971             return True;
2972          else
2973             S := Scope (S);
2974          end if;
2975       end loop;
2976
2977       return False;
2978    end In_Package_Body;
2979
2980    --------------------------------------
2981    -- In_Subprogram_Or_Concurrent_Unit --
2982    --------------------------------------
2983
2984    function In_Subprogram_Or_Concurrent_Unit return Boolean is
2985       E : Entity_Id;
2986       K : Entity_Kind;
2987
2988    begin
2989       --  Use scope chain to check successively outer scopes
2990
2991       E := Current_Scope;
2992       loop
2993          K := Ekind (E);
2994
2995          if K in Subprogram_Kind
2996            or else K in Concurrent_Kind
2997            or else K in Generic_Subprogram_Kind
2998          then
2999             return True;
3000
3001          elsif E = Standard_Standard then
3002             return False;
3003          end if;
3004
3005          E := Scope (E);
3006       end loop;
3007    end In_Subprogram_Or_Concurrent_Unit;
3008
3009    ---------------------
3010    -- In_Visible_Part --
3011    ---------------------
3012
3013    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
3014    begin
3015       return
3016         Is_Package (Scope_Id)
3017           and then In_Open_Scopes (Scope_Id)
3018           and then not In_Package_Body (Scope_Id)
3019           and then not In_Private_Part (Scope_Id);
3020    end In_Visible_Part;
3021
3022    ---------------------------------
3023    -- Insert_Explicit_Dereference --
3024    ---------------------------------
3025
3026    procedure Insert_Explicit_Dereference (N : Node_Id) is
3027       New_Prefix : constant Node_Id := Relocate_Node (N);
3028       I          : Interp_Index;
3029       It         : Interp;
3030       T          : Entity_Id;
3031
3032    begin
3033       Save_Interps (N, New_Prefix);
3034       Rewrite (N,
3035         Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
3036
3037       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
3038
3039       if Is_Overloaded (New_Prefix) then
3040
3041          --  The deference is also overloaded, and its interpretations are the
3042          --  designated types of the interpretations of the original node.
3043
3044          Set_Etype (N, Any_Type);
3045          Get_First_Interp (New_Prefix, I, It);
3046
3047          while Present (It.Nam) loop
3048             T := It.Typ;
3049
3050             if Is_Access_Type (T) then
3051                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
3052             end if;
3053
3054             Get_Next_Interp (I, It);
3055          end loop;
3056
3057          End_Interp_List;
3058       end if;
3059    end Insert_Explicit_Dereference;
3060
3061    -------------------
3062    -- Is_AAMP_Float --
3063    -------------------
3064
3065    function Is_AAMP_Float (E : Entity_Id) return Boolean is
3066    begin
3067       pragma Assert (Is_Type (E));
3068
3069       return AAMP_On_Target
3070          and then Is_Floating_Point_Type (E)
3071          and then E = Base_Type (E);
3072    end Is_AAMP_Float;
3073
3074    -------------------------
3075    -- Is_Actual_Parameter --
3076    -------------------------
3077
3078    function Is_Actual_Parameter (N : Node_Id) return Boolean is
3079       PK : constant Node_Kind := Nkind (Parent (N));
3080
3081    begin
3082       case PK is
3083          when N_Parameter_Association =>
3084             return N = Explicit_Actual_Parameter (Parent (N));
3085
3086          when N_Function_Call | N_Procedure_Call_Statement =>
3087             return Is_List_Member (N)
3088               and then
3089                 List_Containing (N) = Parameter_Associations (Parent (N));
3090
3091          when others =>
3092             return False;
3093       end case;
3094    end Is_Actual_Parameter;
3095
3096    ---------------------
3097    -- Is_Aliased_View --
3098    ---------------------
3099
3100    function Is_Aliased_View (Obj : Node_Id) return Boolean is
3101       E : Entity_Id;
3102
3103    begin
3104       if Is_Entity_Name (Obj) then
3105
3106          --  Shouldn't we check that we really have an object here?
3107          --  If we do, then a-caldel.adb blows up mysteriously ???
3108
3109          E := Entity (Obj);
3110
3111          return Is_Aliased (E)
3112            or else (Present (Renamed_Object (E))
3113                      and then Is_Aliased_View (Renamed_Object (E)))
3114
3115            or else ((Is_Formal (E)
3116                       or else Ekind (E) = E_Generic_In_Out_Parameter
3117                       or else Ekind (E) = E_Generic_In_Parameter)
3118                     and then Is_Tagged_Type (Etype (E)))
3119
3120            or else ((Ekind (E) = E_Task_Type or else
3121                      Ekind (E) = E_Protected_Type)
3122                     and then In_Open_Scopes (E))
3123
3124             --  Current instance of type
3125
3126            or else (Is_Type (E) and then E = Current_Scope)
3127            or else (Is_Incomplete_Or_Private_Type (E)
3128                      and then Full_View (E) = Current_Scope);
3129
3130       elsif Nkind (Obj) = N_Selected_Component then
3131          return Is_Aliased (Entity (Selector_Name (Obj)));
3132
3133       elsif Nkind (Obj) = N_Indexed_Component then
3134          return Has_Aliased_Components (Etype (Prefix (Obj)))
3135            or else
3136              (Is_Access_Type (Etype (Prefix (Obj)))
3137                and then
3138               Has_Aliased_Components
3139                 (Designated_Type (Etype (Prefix (Obj)))));
3140
3141       elsif Nkind (Obj) = N_Unchecked_Type_Conversion
3142         or else Nkind (Obj) = N_Type_Conversion
3143       then
3144          return Is_Tagged_Type (Etype (Obj))
3145            and then Is_Aliased_View (Expression (Obj));
3146
3147       elsif Nkind (Obj) = N_Explicit_Dereference then
3148          return Nkind (Original_Node (Obj)) /= N_Function_Call;
3149
3150       else
3151          return False;
3152       end if;
3153    end Is_Aliased_View;
3154
3155    ----------------------
3156    -- Is_Atomic_Object --
3157    ----------------------
3158
3159    function Is_Atomic_Object (N : Node_Id) return Boolean is
3160
3161       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
3162       --  Determines if given object has atomic components
3163
3164       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
3165       --  If prefix is an implicit dereference, examine designated type.
3166
3167       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
3168       begin
3169          if Is_Access_Type (Etype (N)) then
3170             return
3171               Has_Atomic_Components (Designated_Type (Etype (N)));
3172          else
3173             return Object_Has_Atomic_Components (N);
3174          end if;
3175       end Is_Atomic_Prefix;
3176
3177       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
3178       begin
3179          if Has_Atomic_Components (Etype (N))
3180            or else Is_Atomic (Etype (N))
3181          then
3182             return True;
3183
3184          elsif Is_Entity_Name (N)
3185            and then (Has_Atomic_Components (Entity (N))
3186                       or else Is_Atomic (Entity (N)))
3187          then
3188             return True;
3189
3190          elsif Nkind (N) = N_Indexed_Component
3191            or else Nkind (N) = N_Selected_Component
3192          then
3193             return Is_Atomic_Prefix (Prefix (N));
3194
3195          else
3196             return False;
3197          end if;
3198       end Object_Has_Atomic_Components;
3199
3200    --  Start of processing for Is_Atomic_Object
3201
3202    begin
3203       if Is_Atomic (Etype (N))
3204         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
3205       then
3206          return True;
3207
3208       elsif Nkind (N) = N_Indexed_Component
3209         or else Nkind (N) = N_Selected_Component
3210       then
3211          return Is_Atomic_Prefix (Prefix (N));
3212
3213       else
3214          return False;
3215       end if;
3216    end Is_Atomic_Object;
3217
3218    ----------------------------------------------
3219    -- Is_Dependent_Component_Of_Mutable_Object --
3220    ----------------------------------------------
3221
3222    function Is_Dependent_Component_Of_Mutable_Object
3223      (Object : Node_Id) return   Boolean
3224    is
3225       P           : Node_Id;
3226       Prefix_Type : Entity_Id;
3227       P_Aliased   : Boolean := False;
3228       Comp        : Entity_Id;
3229
3230       function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean;
3231       --  Returns True if and only if Comp has a constrained subtype
3232       --  that depends on a discriminant.
3233
3234       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
3235       --  Returns True if and only if Comp is declared within a variant part.
3236
3237       ------------------------------
3238       -- Has_Dependent_Constraint --
3239       ------------------------------
3240
3241       function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
3242          Comp_Decl  : constant Node_Id := Parent (Comp);
3243          Subt_Indic : constant Node_Id :=
3244                         Subtype_Indication (Component_Definition (Comp_Decl));
3245          Constr     : Node_Id;
3246          Assn       : Node_Id;
3247
3248       begin
3249          if Nkind (Subt_Indic) = N_Subtype_Indication then
3250             Constr := Constraint (Subt_Indic);
3251
3252             if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
3253                Assn := First (Constraints (Constr));
3254                while Present (Assn) loop
3255                   case Nkind (Assn) is
3256                      when N_Subtype_Indication |
3257                           N_Range              |
3258                           N_Identifier
3259                      =>
3260                         if Depends_On_Discriminant (Assn) then
3261                            return True;
3262                         end if;
3263
3264                      when N_Discriminant_Association =>
3265                         if Depends_On_Discriminant (Expression (Assn)) then
3266                            return True;
3267                         end if;
3268
3269                      when others =>
3270                         null;
3271
3272                   end case;
3273
3274                   Next (Assn);
3275                end loop;
3276             end if;
3277          end if;
3278
3279          return False;
3280       end Has_Dependent_Constraint;
3281
3282       --------------------------------
3283       -- Is_Declared_Within_Variant --
3284       --------------------------------
3285
3286       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
3287          Comp_Decl : constant Node_Id   := Parent (Comp);
3288          Comp_List : constant Node_Id   := Parent (Comp_Decl);
3289
3290       begin
3291          return Nkind (Parent (Comp_List)) = N_Variant;
3292       end Is_Declared_Within_Variant;
3293
3294    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
3295
3296    begin
3297       if Is_Variable (Object) then
3298
3299          if Nkind (Object) = N_Selected_Component then
3300             P := Prefix (Object);
3301             Prefix_Type := Etype (P);
3302
3303             if Is_Entity_Name (P) then
3304
3305                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
3306                   Prefix_Type := Base_Type (Prefix_Type);
3307                end if;
3308
3309                if Is_Aliased (Entity (P)) then
3310                   P_Aliased := True;
3311                end if;
3312
3313             --  A discriminant check on a selected component may be
3314             --  expanded into a dereference when removing side-effects.
3315             --  Recover the original node and its type, which may be
3316             --  unconstrained.
3317
3318             elsif Nkind (P) = N_Explicit_Dereference
3319               and then not (Comes_From_Source (P))
3320             then
3321                P := Original_Node (P);
3322                Prefix_Type := Etype (P);
3323
3324             else
3325                --  Check for prefix being an aliased component ???
3326                null;
3327
3328             end if;
3329
3330             if Is_Access_Type (Prefix_Type)
3331               or else Nkind (P) = N_Explicit_Dereference
3332             then
3333                return False;
3334             end if;
3335
3336             Comp :=
3337               Original_Record_Component (Entity (Selector_Name (Object)));
3338
3339             --  As per AI-0017, the renaming is illegal in a generic body,
3340             --  even if the subtype is indefinite.
3341
3342             if not Is_Constrained (Prefix_Type)
3343               and then (not Is_Indefinite_Subtype (Prefix_Type)
3344                          or else
3345                           (Is_Generic_Type (Prefix_Type)
3346                             and then Ekind (Current_Scope) = E_Generic_Package
3347                             and then In_Package_Body (Current_Scope)))
3348
3349               and then (Is_Declared_Within_Variant (Comp)
3350                           or else Has_Dependent_Constraint (Comp))
3351               and then not P_Aliased
3352             then
3353                return True;
3354
3355             else
3356                return
3357                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
3358
3359             end if;
3360
3361          elsif Nkind (Object) = N_Indexed_Component
3362            or else Nkind (Object) = N_Slice
3363          then
3364             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
3365
3366          --  A type conversion that Is_Variable is a view conversion:
3367          --  go back to the denoted object.
3368
3369          elsif Nkind (Object) = N_Type_Conversion then
3370             return
3371               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
3372          end if;
3373       end if;
3374
3375       return False;
3376    end Is_Dependent_Component_Of_Mutable_Object;
3377
3378    ---------------------
3379    -- Is_Dereferenced --
3380    ---------------------
3381
3382    function Is_Dereferenced (N : Node_Id) return Boolean is
3383       P : constant Node_Id := Parent (N);
3384
3385    begin
3386       return
3387          (Nkind (P) = N_Selected_Component
3388             or else
3389           Nkind (P) = N_Explicit_Dereference
3390             or else
3391           Nkind (P) = N_Indexed_Component
3392             or else
3393           Nkind (P) = N_Slice)
3394         and then Prefix (P) = N;
3395    end Is_Dereferenced;
3396
3397    ----------------------
3398    -- Is_Descendent_Of --
3399    ----------------------
3400
3401    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
3402       T    : Entity_Id;
3403       Etyp : Entity_Id;
3404
3405    begin
3406       pragma Assert (Nkind (T1) in N_Entity);
3407       pragma Assert (Nkind (T2) in N_Entity);
3408
3409       T := Base_Type (T1);
3410
3411       --  Immediate return if the types match
3412
3413       if T = T2 then
3414          return True;
3415
3416       --  Comment needed here ???
3417
3418       elsif Ekind (T) = E_Class_Wide_Type then
3419          return Etype (T) = T2;
3420
3421       --  All other cases
3422
3423       else
3424          loop
3425             Etyp := Etype (T);
3426
3427             --  Done if we found the type we are looking for
3428
3429             if Etyp = T2 then
3430                return True;
3431
3432             --  Done if no more derivations to check
3433
3434             elsif T = T1 then
3435                return False;
3436
3437             --  Following test catches error cases resulting from prev errors
3438
3439             elsif No (Etyp) then
3440                return False;
3441
3442             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
3443                return False;
3444
3445             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
3446                return False;
3447             end if;
3448
3449             --  Return if no further entries to check
3450
3451             if T = Base_Type (T1) or else T = T1 then
3452                return False;
3453             end if;
3454          end loop;
3455       end if;
3456
3457       raise Program_Error;
3458    end Is_Descendent_Of;
3459
3460    ------------------------------
3461    -- Is_Descendent_Of_Address --
3462    ------------------------------
3463
3464    function Is_Descendent_Of_Address (T1 : Entity_Id) return Boolean is
3465    begin
3466       --  If Address has not been loaded, answer must be False
3467
3468       if not RTU_Loaded (System) then
3469          return False;
3470
3471       --  Otherwise we can get the entity we are interested in without
3472       --  causing an unwanted dependency on System, and do the test.
3473
3474       else
3475          return Is_Descendent_Of (T1, Base_Type (RTE (RE_Address)));
3476       end if;
3477    end Is_Descendent_Of_Address;
3478
3479    --------------
3480    -- Is_False --
3481    --------------
3482
3483    function Is_False (U : Uint) return Boolean is
3484    begin
3485       return (U = 0);
3486    end Is_False;
3487
3488    ---------------------------
3489    -- Is_Fixed_Model_Number --
3490    ---------------------------
3491
3492    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
3493       S : constant Ureal := Small_Value (T);
3494       M : Urealp.Save_Mark;
3495       R : Boolean;
3496
3497    begin
3498       M := Urealp.Mark;
3499       R := (U = UR_Trunc (U / S) * S);
3500       Urealp.Release (M);
3501       return R;
3502    end Is_Fixed_Model_Number;
3503
3504    -------------------------------
3505    -- Is_Fully_Initialized_Type --
3506    -------------------------------
3507
3508    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
3509    begin
3510       if Is_Scalar_Type (Typ) then
3511          return False;
3512
3513       elsif Is_Access_Type (Typ) then
3514          return True;
3515
3516       elsif Is_Array_Type (Typ) then
3517          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
3518             return True;
3519          end if;
3520
3521          --  An interesting case, if we have a constrained type one of whose
3522          --  bounds is known to be null, then there are no elements to be
3523          --  initialized, so all the elements are initialized!
3524
3525          if Is_Constrained (Typ) then
3526             declare
3527                Indx     : Node_Id;
3528                Indx_Typ : Entity_Id;
3529                Lbd, Hbd : Node_Id;
3530
3531             begin
3532                Indx := First_Index (Typ);
3533                while Present (Indx) loop
3534
3535                   if Etype (Indx) = Any_Type then
3536                      return False;
3537
3538                   --  If index is a range, use directly.
3539
3540                   elsif Nkind (Indx) = N_Range then
3541                      Lbd := Low_Bound  (Indx);
3542                      Hbd := High_Bound (Indx);
3543
3544                   else
3545                      Indx_Typ := Etype (Indx);
3546
3547                      if Is_Private_Type (Indx_Typ)  then
3548                         Indx_Typ := Full_View (Indx_Typ);
3549                      end if;
3550
3551                      if No (Indx_Typ) then
3552                         return False;
3553                      else
3554                         Lbd := Type_Low_Bound  (Indx_Typ);
3555                         Hbd := Type_High_Bound (Indx_Typ);
3556                      end if;
3557                   end if;
3558
3559                   if Compile_Time_Known_Value (Lbd)
3560                     and then Compile_Time_Known_Value (Hbd)
3561                   then
3562                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
3563                         return True;
3564                      end if;
3565                   end if;
3566
3567                   Next_Index (Indx);
3568                end loop;
3569             end;
3570          end if;
3571
3572          --  If no null indexes, then type is not fully initialized
3573
3574          return False;
3575
3576       --  Record types
3577
3578       elsif Is_Record_Type (Typ) then
3579          if Has_Discriminants (Typ)
3580            and then
3581              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
3582            and then Is_Fully_Initialized_Variant (Typ)
3583          then
3584             return True;
3585          end if;
3586
3587          --  Controlled records are considered to be fully initialized if
3588          --  there is a user defined Initialize routine. This may not be
3589          --  entirely correct, but as the spec notes, we are guessing here
3590          --  what is best from the point of view of issuing warnings.
3591
3592          if Is_Controlled (Typ) then
3593             declare
3594                Utyp : constant Entity_Id := Underlying_Type (Typ);
3595
3596             begin
3597                if Present (Utyp) then
3598                   declare
3599                      Init : constant Entity_Id :=
3600                               (Find_Prim_Op
3601                                  (Underlying_Type (Typ), Name_Initialize));
3602
3603                   begin
3604                      if Present (Init)
3605                        and then Comes_From_Source (Init)
3606                        and then not
3607                          Is_Predefined_File_Name
3608                            (File_Name (Get_Source_File_Index (Sloc (Init))))
3609                      then
3610                         return True;
3611
3612                      elsif Has_Null_Extension (Typ)
3613                         and then
3614                           Is_Fully_Initialized_Type
3615                             (Etype (Base_Type (Typ)))
3616                      then
3617                         return True;
3618                      end if;
3619                   end;
3620                end if;
3621             end;
3622          end if;
3623
3624          --  Otherwise see if all record components are initialized
3625
3626          declare
3627             Ent : Entity_Id;
3628
3629          begin
3630             Ent := First_Entity (Typ);
3631
3632             while Present (Ent) loop
3633                if Chars (Ent) = Name_uController then
3634                   null;
3635
3636                elsif Ekind (Ent) = E_Component
3637                  and then (No (Parent (Ent))
3638                              or else No (Expression (Parent (Ent))))
3639                  and then not Is_Fully_Initialized_Type (Etype (Ent))
3640                then
3641                   return False;
3642                end if;
3643
3644                Next_Entity (Ent);
3645             end loop;
3646          end;
3647
3648          --  No uninitialized components, so type is fully initialized.
3649          --  Note that this catches the case of no components as well.
3650
3651          return True;
3652
3653       elsif Is_Concurrent_Type (Typ) then
3654          return True;
3655
3656       elsif Is_Private_Type (Typ) then
3657          declare
3658             U : constant Entity_Id := Underlying_Type (Typ);
3659
3660          begin
3661             if No (U) then
3662                return False;
3663             else
3664                return Is_Fully_Initialized_Type (U);
3665             end if;
3666          end;
3667
3668       else
3669          return False;
3670       end if;
3671    end Is_Fully_Initialized_Type;
3672
3673    ----------------------------------
3674    -- Is_Fully_Initialized_Variant --
3675    ----------------------------------
3676
3677    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
3678       Loc           : constant Source_Ptr := Sloc (Typ);
3679       Constraints   : constant List_Id    := New_List;
3680       Components    : constant Elist_Id   := New_Elmt_List;
3681       Comp_Elmt     : Elmt_Id;
3682       Comp_Id       : Node_Id;
3683       Comp_List     : Node_Id;
3684       Discr         : Entity_Id;
3685       Discr_Val     : Node_Id;
3686       Report_Errors : Boolean;
3687
3688    begin
3689       if Serious_Errors_Detected > 0 then
3690          return False;
3691       end if;
3692
3693       if Is_Record_Type (Typ)
3694         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
3695         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
3696       then
3697          Comp_List := Component_List (Type_Definition (Parent (Typ)));
3698          Discr := First_Discriminant (Typ);
3699
3700          while Present (Discr) loop
3701             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
3702                Discr_Val := Expression (Parent (Discr));
3703                if not Is_OK_Static_Expression (Discr_Val) then
3704                   return False;
3705                else
3706                   Append_To (Constraints,
3707                     Make_Component_Association (Loc,
3708                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
3709                       Expression => New_Copy (Discr_Val)));
3710
3711                end if;
3712             else
3713                return False;
3714             end if;
3715
3716             Next_Discriminant (Discr);
3717          end loop;
3718
3719          Gather_Components
3720            (Typ           => Typ,
3721             Comp_List     => Comp_List,
3722             Governed_By   => Constraints,
3723             Into          => Components,
3724             Report_Errors => Report_Errors);
3725
3726          --  Check that each component present is fully initialized.
3727
3728          Comp_Elmt := First_Elmt (Components);
3729
3730          while Present (Comp_Elmt) loop
3731             Comp_Id := Node (Comp_Elmt);
3732
3733             if Ekind (Comp_Id) = E_Component
3734               and then (No (Parent (Comp_Id))
3735                          or else No (Expression (Parent (Comp_Id))))
3736               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
3737             then
3738                return False;
3739             end if;
3740
3741             Next_Elmt (Comp_Elmt);
3742          end loop;
3743
3744          return True;
3745
3746       elsif Is_Private_Type (Typ) then
3747          declare
3748             U : constant Entity_Id := Underlying_Type (Typ);
3749
3750          begin
3751             if No (U) then
3752                return False;
3753             else
3754                return Is_Fully_Initialized_Variant (U);
3755             end if;
3756          end;
3757       else
3758          return False;
3759       end if;
3760    end Is_Fully_Initialized_Variant;
3761
3762    ----------------------------
3763    -- Is_Inherited_Operation --
3764    ----------------------------
3765
3766    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
3767       Kind : constant Node_Kind := Nkind (Parent (E));
3768
3769    begin
3770       pragma Assert (Is_Overloadable (E));
3771       return Kind = N_Full_Type_Declaration
3772         or else Kind = N_Private_Extension_Declaration
3773         or else Kind = N_Subtype_Declaration
3774         or else (Ekind (E) = E_Enumeration_Literal
3775                   and then Is_Derived_Type (Etype (E)));
3776    end Is_Inherited_Operation;
3777
3778    -----------------------------
3779    -- Is_Library_Level_Entity --
3780    -----------------------------
3781
3782    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
3783    begin
3784       --  The following is a small optimization, and it also handles
3785       --  properly discriminals, which in task bodies might appear in
3786       --  expressions before the corresponding procedure has been
3787       --  created, and which therefore do not have an assigned scope.
3788
3789       if Ekind (E) in Formal_Kind then
3790          return False;
3791       end if;
3792
3793       --  Normal test is simply that the enclosing dynamic scope is Standard
3794
3795       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
3796    end Is_Library_Level_Entity;
3797
3798    ---------------------------------
3799    -- Is_Local_Variable_Reference --
3800    ---------------------------------
3801
3802    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
3803    begin
3804       if not Is_Entity_Name (Expr) then
3805          return False;
3806
3807       else
3808          declare
3809             Ent : constant Entity_Id := Entity (Expr);
3810             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
3811
3812          begin
3813             if Ekind (Ent) /= E_Variable
3814                  and then
3815                Ekind (Ent) /= E_In_Out_Parameter
3816             then
3817                return False;
3818
3819             else
3820                return Present (Sub) and then Sub = Current_Subprogram;
3821             end if;
3822          end;
3823       end if;
3824    end Is_Local_Variable_Reference;
3825
3826    ---------------
3827    -- Is_Lvalue --
3828    ---------------
3829
3830    function Is_Lvalue (N : Node_Id) return Boolean is
3831       P : constant Node_Id := Parent (N);
3832
3833    begin
3834       case Nkind (P) is
3835
3836          --  Test left side of assignment
3837
3838          when N_Assignment_Statement =>
3839             return N = Name (P);
3840
3841          --  Test prefix of component or attribute
3842
3843          when N_Attribute_Reference  |
3844               N_Expanded_Name        |
3845               N_Explicit_Dereference |
3846               N_Indexed_Component    |
3847               N_Reference            |
3848               N_Selected_Component   |
3849               N_Slice                =>
3850             return N = Prefix (P);
3851
3852          --  Test subprogram parameter (we really should check the
3853          --  parameter mode, but it is not worth the trouble)
3854
3855          when N_Function_Call            |
3856               N_Procedure_Call_Statement |
3857               N_Accept_Statement         |
3858               N_Parameter_Association    =>
3859             return True;
3860
3861          --  Test for appearing in a conversion that itself appears
3862          --  in an lvalue context, since this should be an lvalue.
3863
3864          when N_Type_Conversion =>
3865             return Is_Lvalue (P);
3866
3867          --  Test for appearence in object renaming declaration
3868
3869          when N_Object_Renaming_Declaration =>
3870             return True;
3871
3872          --  All other references are definitely not Lvalues
3873
3874          when others =>
3875             return False;
3876
3877       end case;
3878    end Is_Lvalue;
3879
3880    -------------------------
3881    -- Is_Object_Reference --
3882    -------------------------
3883
3884    function Is_Object_Reference (N : Node_Id) return Boolean is
3885    begin
3886       if Is_Entity_Name (N) then
3887          return Is_Object (Entity (N));
3888
3889       else
3890          case Nkind (N) is
3891             when N_Indexed_Component | N_Slice =>
3892                return Is_Object_Reference (Prefix (N));
3893
3894             --  In Ada95, a function call is a constant object
3895
3896             when N_Function_Call =>
3897                return True;
3898
3899             --  A reference to the stream attribute Input is a function call
3900
3901             when N_Attribute_Reference =>
3902                return Attribute_Name (N) = Name_Input;
3903
3904             when N_Selected_Component =>
3905                return Is_Object_Reference (Selector_Name (N));
3906
3907             when N_Explicit_Dereference =>
3908                return True;
3909
3910             --  A view conversion of a tagged object is an object reference.
3911
3912             when N_Type_Conversion =>
3913                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
3914                  and then Is_Tagged_Type (Etype (Expression (N)))
3915                  and then Is_Object_Reference (Expression (N));
3916
3917             --  An unchecked type conversion is considered to be an object if
3918             --  the operand is an object (this construction arises only as a
3919             --  result of expansion activities).
3920
3921             when N_Unchecked_Type_Conversion =>
3922                return True;
3923
3924             when others =>
3925                return False;
3926          end case;
3927       end if;
3928    end Is_Object_Reference;
3929
3930    -----------------------------------
3931    -- Is_OK_Variable_For_Out_Formal --
3932    -----------------------------------
3933
3934    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
3935    begin
3936       Note_Possible_Modification (AV);
3937
3938       --  We must reject parenthesized variable names. The check for
3939       --  Comes_From_Source is present because there are currently
3940       --  cases where the compiler violates this rule (e.g. passing
3941       --  a task object to its controlled Initialize routine).
3942
3943       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
3944          return False;
3945
3946       --  A variable is always allowed
3947
3948       elsif Is_Variable (AV) then
3949          return True;
3950
3951       --  Unchecked conversions are allowed only if they come from the
3952       --  generated code, which sometimes uses unchecked conversions for
3953       --  out parameters in cases where code generation is unaffected.
3954       --  We tell source unchecked conversions by seeing if they are
3955       --  rewrites of an original UC function call, or of an explicit
3956       --  conversion of a function call.
3957
3958       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
3959          if Nkind (Original_Node (AV)) = N_Function_Call then
3960             return False;
3961
3962          elsif Comes_From_Source (AV)
3963            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
3964          then
3965             return False;
3966
3967          else
3968             return True;
3969          end if;
3970
3971       --  Normal type conversions are allowed if argument is a variable
3972
3973       elsif Nkind (AV) = N_Type_Conversion then
3974          if Is_Variable (Expression (AV))
3975            and then Paren_Count (Expression (AV)) = 0
3976          then
3977             Note_Possible_Modification (Expression (AV));
3978             return True;
3979
3980          --  We also allow a non-parenthesized expression that raises
3981          --  constraint error if it rewrites what used to be a variable
3982
3983          elsif Raises_Constraint_Error (Expression (AV))
3984             and then Paren_Count (Expression (AV)) = 0
3985             and then Is_Variable (Original_Node (Expression (AV)))
3986          then
3987             return True;
3988
3989          --  Type conversion of something other than a variable
3990
3991          else
3992             return False;
3993          end if;
3994
3995       --  If this node is rewritten, then test the original form, if that is
3996       --  OK, then we consider the rewritten node OK (for example, if the
3997       --  original node is a conversion, then Is_Variable will not be true
3998       --  but we still want to allow the conversion if it converts a variable).
3999
4000       elsif Original_Node (AV) /= AV then
4001          return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
4002
4003       --  All other non-variables are rejected
4004
4005       else
4006          return False;
4007       end if;
4008    end Is_OK_Variable_For_Out_Formal;
4009
4010    -----------------------------------
4011    -- Is_Partially_Initialized_Type --
4012    -----------------------------------
4013
4014    function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
4015    begin
4016       if Is_Scalar_Type (Typ) then
4017          return False;
4018
4019       elsif Is_Access_Type (Typ) then
4020          return True;
4021
4022       elsif Is_Array_Type (Typ) then
4023
4024          --  If component type is partially initialized, so is array type
4025
4026          if Is_Partially_Initialized_Type (Component_Type (Typ)) then
4027             return True;
4028
4029          --  Otherwise we are only partially initialized if we are fully
4030          --  initialized (this is the empty array case, no point in us
4031          --  duplicating that code here).
4032
4033          else
4034             return Is_Fully_Initialized_Type (Typ);
4035          end if;
4036
4037       elsif Is_Record_Type (Typ) then
4038
4039          --  A discriminated type is always partially initialized
4040
4041          if Has_Discriminants (Typ) then
4042             return True;
4043
4044          --  A tagged type is always partially initialized
4045
4046          elsif Is_Tagged_Type (Typ) then
4047             return True;
4048
4049          --  Case of non-discriminated record
4050
4051          else
4052             declare
4053                Ent : Entity_Id;
4054
4055                Component_Present : Boolean := False;
4056                --  Set True if at least one component is present. If no
4057                --  components are present, then record type is fully
4058                --  initialized (another odd case, like the null array).
4059
4060             begin
4061                --  Loop through components
4062
4063                Ent := First_Entity (Typ);
4064                while Present (Ent) loop
4065                   if Ekind (Ent) = E_Component then
4066                      Component_Present := True;
4067
4068                      --  If a component has an initialization expression then
4069                      --  the enclosing record type is partially initialized
4070
4071                      if Present (Parent (Ent))
4072                        and then Present (Expression (Parent (Ent)))
4073                      then
4074                         return True;
4075
4076                      --  If a component is of a type which is itself partially
4077                      --  initialized, then the enclosing record type is also.
4078
4079                      elsif Is_Partially_Initialized_Type (Etype (Ent)) then
4080                         return True;
4081                      end if;
4082                   end if;
4083
4084                   Next_Entity (Ent);
4085                end loop;
4086
4087                --  No initialized components found. If we found any components
4088                --  they were all uninitialized so the result is false.
4089
4090                if Component_Present then
4091                   return False;
4092
4093                --  But if we found no components, then all the components are
4094                --  initialized so we consider the type to be initialized.
4095
4096                else
4097                   return True;
4098                end if;
4099             end;
4100          end if;
4101
4102       --  Concurrent types are always fully initialized
4103
4104       elsif Is_Concurrent_Type (Typ) then
4105          return True;
4106
4107       --  For a private type, go to underlying type. If there is no underlying
4108       --  type then just assume this partially initialized. Not clear if this
4109       --  can happen in a non-error case, but no harm in testing for this.
4110
4111       elsif Is_Private_Type (Typ) then
4112          declare
4113             U : constant Entity_Id := Underlying_Type (Typ);
4114
4115          begin
4116             if No (U) then
4117                return True;
4118             else
4119                return Is_Partially_Initialized_Type (U);
4120             end if;
4121          end;
4122
4123       --  For any other type (are there any?) assume partially initialized
4124
4125       else
4126          return True;
4127       end if;
4128    end Is_Partially_Initialized_Type;
4129
4130    -----------------------------
4131    -- Is_RCI_Pkg_Spec_Or_Body --
4132    -----------------------------
4133
4134    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
4135
4136       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
4137       --  Return True if the unit of Cunit is an RCI package declaration
4138
4139       ---------------------------
4140       -- Is_RCI_Pkg_Decl_Cunit --
4141       ---------------------------
4142
4143       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
4144          The_Unit : constant Node_Id := Unit (Cunit);
4145
4146       begin
4147          if Nkind (The_Unit) /= N_Package_Declaration then
4148             return False;
4149          end if;
4150          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
4151       end Is_RCI_Pkg_Decl_Cunit;
4152
4153    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
4154
4155    begin
4156       return Is_RCI_Pkg_Decl_Cunit (Cunit)
4157         or else
4158          (Nkind (Unit (Cunit)) = N_Package_Body
4159            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
4160    end Is_RCI_Pkg_Spec_Or_Body;
4161
4162    -----------------------------------------
4163    -- Is_Remote_Access_To_Class_Wide_Type --
4164    -----------------------------------------
4165
4166    function Is_Remote_Access_To_Class_Wide_Type
4167      (E : Entity_Id) return Boolean
4168    is
4169       D : Entity_Id;
4170
4171       function Comes_From_Limited_Private_Type_Declaration
4172         (E    : Entity_Id)
4173          return Boolean;
4174       --  Check that the type is declared by a limited type declaration,
4175       --  or else is derived from a Remote_Type ancestor through private
4176       --  extensions.
4177
4178       -------------------------------------------------
4179       -- Comes_From_Limited_Private_Type_Declaration --
4180       -------------------------------------------------
4181
4182       function Comes_From_Limited_Private_Type_Declaration (E : in Entity_Id)
4183         return Boolean
4184       is
4185          N : constant Node_Id := Declaration_Node (E);
4186       begin
4187          if Nkind (N) = N_Private_Type_Declaration
4188            and then Limited_Present (N)
4189          then
4190             return True;
4191          end if;
4192
4193          if Nkind (N) = N_Private_Extension_Declaration then
4194             return
4195               Comes_From_Limited_Private_Type_Declaration (Etype (E))
4196                 or else
4197                  (Is_Remote_Types (Etype (E))
4198                     and then Is_Limited_Record (Etype (E))
4199                     and then Has_Private_Declaration (Etype (E)));
4200          end if;
4201
4202          return False;
4203       end Comes_From_Limited_Private_Type_Declaration;
4204
4205    --  Start of processing for Is_Remote_Access_To_Class_Wide_Type
4206
4207    begin
4208       if not (Is_Remote_Call_Interface (E)
4209                or else Is_Remote_Types (E))
4210         or else Ekind (E) /= E_General_Access_Type
4211       then
4212          return False;
4213       end if;
4214
4215       D := Designated_Type (E);
4216
4217       if Ekind (D) /= E_Class_Wide_Type then
4218          return False;
4219       end if;
4220
4221       return Comes_From_Limited_Private_Type_Declaration
4222                (Defining_Identifier (Parent (D)));
4223    end Is_Remote_Access_To_Class_Wide_Type;
4224
4225    -----------------------------------------
4226    -- Is_Remote_Access_To_Subprogram_Type --
4227    -----------------------------------------
4228
4229    function Is_Remote_Access_To_Subprogram_Type
4230      (E : Entity_Id) return Boolean
4231    is
4232    begin
4233       return (Ekind (E) = E_Access_Subprogram_Type
4234                 or else (Ekind (E) = E_Record_Type
4235                            and then Present (Corresponding_Remote_Type (E))))
4236         and then (Is_Remote_Call_Interface (E)
4237                    or else Is_Remote_Types (E));
4238    end Is_Remote_Access_To_Subprogram_Type;
4239
4240    --------------------
4241    -- Is_Remote_Call --
4242    --------------------
4243
4244    function Is_Remote_Call (N : Node_Id) return Boolean is
4245    begin
4246       if Nkind (N) /= N_Procedure_Call_Statement
4247         and then Nkind (N) /= N_Function_Call
4248       then
4249          --  An entry call cannot be remote
4250
4251          return False;
4252
4253       elsif Nkind (Name (N)) in N_Has_Entity
4254         and then Is_Remote_Call_Interface (Entity (Name (N)))
4255       then
4256          --  A subprogram declared in the spec of a RCI package is remote
4257
4258          return True;
4259
4260       elsif Nkind (Name (N)) = N_Explicit_Dereference
4261         and then Is_Remote_Access_To_Subprogram_Type
4262           (Etype (Prefix (Name (N))))
4263       then
4264          --  The dereference of a RAS is a remote call
4265
4266          return True;
4267
4268       elsif Present (Controlling_Argument (N))
4269         and then Is_Remote_Access_To_Class_Wide_Type
4270           (Etype (Controlling_Argument (N)))
4271       then
4272          --  Any primitive operation call with a controlling argument of
4273          --  a RACW type is a remote call.
4274
4275          return True;
4276       end if;
4277
4278       --  All other calls are local calls
4279
4280       return False;
4281    end Is_Remote_Call;
4282
4283    ----------------------
4284    -- Is_Selector_Name --
4285    ----------------------
4286
4287    function Is_Selector_Name (N : Node_Id) return Boolean is
4288
4289    begin
4290       if not Is_List_Member (N) then
4291          declare
4292             P : constant Node_Id   := Parent (N);
4293             K : constant Node_Kind := Nkind (P);
4294
4295          begin
4296             return
4297               (K = N_Expanded_Name          or else
4298                K = N_Generic_Association    or else
4299                K = N_Parameter_Association  or else
4300                K = N_Selected_Component)
4301               and then Selector_Name (P) = N;
4302          end;
4303
4304       else
4305          declare
4306             L : constant List_Id := List_Containing (N);
4307             P : constant Node_Id := Parent (L);
4308
4309          begin
4310             return (Nkind (P) = N_Discriminant_Association
4311                      and then Selector_Names (P) = L)
4312               or else
4313                    (Nkind (P) = N_Component_Association
4314                      and then Choices (P) = L);
4315          end;
4316       end if;
4317    end Is_Selector_Name;
4318
4319    ------------------
4320    -- Is_Statement --
4321    ------------------
4322
4323    function Is_Statement (N : Node_Id) return Boolean is
4324    begin
4325       return
4326         Nkind (N) in N_Statement_Other_Than_Procedure_Call
4327           or else Nkind (N) = N_Procedure_Call_Statement;
4328    end Is_Statement;
4329
4330    -----------------
4331    -- Is_Transfer --
4332    -----------------
4333
4334    function Is_Transfer (N : Node_Id) return Boolean is
4335       Kind : constant Node_Kind := Nkind (N);
4336
4337    begin
4338       if Kind = N_Return_Statement
4339            or else
4340          Kind = N_Goto_Statement
4341            or else
4342          Kind = N_Raise_Statement
4343            or else
4344          Kind = N_Requeue_Statement
4345       then
4346          return True;
4347
4348       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
4349         and then No (Condition (N))
4350       then
4351          return True;
4352
4353       elsif Kind = N_Procedure_Call_Statement
4354         and then Is_Entity_Name (Name (N))
4355         and then Present (Entity (Name (N)))
4356         and then No_Return (Entity (Name (N)))
4357       then
4358          return True;
4359
4360       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
4361          return True;
4362
4363       else
4364          return False;
4365       end if;
4366    end Is_Transfer;
4367
4368    -------------
4369    -- Is_True --
4370    -------------
4371
4372    function Is_True (U : Uint) return Boolean is
4373    begin
4374       return (U /= 0);
4375    end Is_True;
4376
4377    -----------------
4378    -- Is_Variable --
4379    -----------------
4380
4381    function Is_Variable (N : Node_Id) return Boolean is
4382
4383       Orig_Node : constant Node_Id := Original_Node (N);
4384       --  We do the test on the original node, since this is basically a
4385       --  test of syntactic categories, so it must not be disturbed by
4386       --  whatever rewriting might have occurred. For example, an aggregate,
4387       --  which is certainly NOT a variable, could be turned into a variable
4388       --  by expansion.
4389
4390       function In_Protected_Function (E : Entity_Id) return Boolean;
4391       --  Within a protected function, the private components of the
4392       --  enclosing protected type are constants. A function nested within
4393       --  a (protected) procedure is not itself protected.
4394
4395       function Is_Variable_Prefix (P : Node_Id) return Boolean;
4396       --  Prefixes can involve implicit dereferences, in which case we
4397       --  must test for the case of a reference of a constant access
4398       --  type, which can never be a variable.
4399
4400       ---------------------------
4401       -- In_Protected_Function --
4402       ---------------------------
4403
4404       function In_Protected_Function (E : Entity_Id) return Boolean is
4405          Prot : constant Entity_Id := Scope (E);
4406          S    : Entity_Id;
4407
4408       begin
4409          if not Is_Protected_Type (Prot) then
4410             return False;
4411          else
4412             S := Current_Scope;
4413
4414             while Present (S) and then S /= Prot loop
4415
4416                if Ekind (S) = E_Function
4417                  and then Scope (S) = Prot
4418                then
4419                   return True;
4420                end if;
4421
4422                S := Scope (S);
4423             end loop;
4424
4425             return False;
4426          end if;
4427       end In_Protected_Function;
4428
4429       ------------------------
4430       -- Is_Variable_Prefix --
4431       ------------------------
4432
4433       function Is_Variable_Prefix (P : Node_Id) return Boolean is
4434       begin
4435          if Is_Access_Type (Etype (P)) then
4436             return not Is_Access_Constant (Root_Type (Etype (P)));
4437          else
4438             return Is_Variable (P);
4439          end if;
4440       end Is_Variable_Prefix;
4441
4442    --  Start of processing for Is_Variable
4443
4444    begin
4445       --  Definitely OK if Assignment_OK is set. Since this is something that
4446       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
4447
4448       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
4449          return True;
4450
4451       --  Normally we go to the original node, but there is one exception
4452       --  where we use the rewritten node, namely when it is an explicit
4453       --  dereference. The generated code may rewrite a prefix which is an
4454       --  access type with an explicit dereference. The dereference is a
4455       --  variable, even though the original node may not be (since it could
4456       --  be a constant of the access type).
4457
4458       elsif Nkind (N) = N_Explicit_Dereference
4459         and then Nkind (Orig_Node) /= N_Explicit_Dereference
4460         and then Is_Access_Type (Etype (Orig_Node))
4461       then
4462          return Is_Variable_Prefix (Original_Node (Prefix (N)));
4463
4464       --  All remaining checks use the original node
4465
4466       elsif Is_Entity_Name (Orig_Node) then
4467          declare
4468             E : constant Entity_Id := Entity (Orig_Node);
4469             K : constant Entity_Kind := Ekind (E);
4470
4471          begin
4472             return (K = E_Variable
4473                       and then Nkind (Parent (E)) /= N_Exception_Handler)
4474               or else  (K = E_Component
4475                           and then not In_Protected_Function (E))
4476               or else  K = E_Out_Parameter
4477               or else  K = E_In_Out_Parameter
4478               or else  K = E_Generic_In_Out_Parameter
4479
4480                --  Current instance of type:
4481
4482               or else (Is_Type (E) and then In_Open_Scopes (E))
4483               or else (Is_Incomplete_Or_Private_Type (E)
4484                         and then In_Open_Scopes (Full_View (E)));
4485          end;
4486
4487       else
4488          case Nkind (Orig_Node) is
4489             when N_Indexed_Component | N_Slice =>
4490                return Is_Variable_Prefix (Prefix (Orig_Node));
4491
4492             when N_Selected_Component =>
4493                return Is_Variable_Prefix (Prefix (Orig_Node))
4494                  and then Is_Variable (Selector_Name (Orig_Node));
4495
4496             --  For an explicit dereference, the type of the prefix cannot
4497             --  be an access to constant or an access to subprogram.
4498
4499             when N_Explicit_Dereference =>
4500                declare
4501                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
4502
4503                begin
4504                   return Is_Access_Type (Typ)
4505                     and then not Is_Access_Constant (Root_Type (Typ))
4506                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
4507                end;
4508
4509             --  The type conversion is the case where we do not deal with the
4510             --  context dependent special case of an actual parameter. Thus
4511             --  the type conversion is only considered a variable for the
4512             --  purposes of this routine if the target type is tagged. However,
4513             --  a type conversion is considered to be a variable if it does not
4514             --  come from source (this deals for example with the conversions
4515             --  of expressions to their actual subtypes).
4516
4517             when N_Type_Conversion =>
4518                return Is_Variable (Expression (Orig_Node))
4519                  and then
4520                    (not Comes_From_Source (Orig_Node)
4521                       or else
4522                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
4523                           and then
4524                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
4525
4526             --  GNAT allows an unchecked type conversion as a variable. This
4527             --  only affects the generation of internal expanded code, since
4528             --  calls to instantiations of Unchecked_Conversion are never
4529             --  considered variables (since they are function calls).
4530             --  This is also true for expression actions.
4531
4532             when N_Unchecked_Type_Conversion =>
4533                return Is_Variable (Expression (Orig_Node));
4534
4535             when others =>
4536                return False;
4537          end case;
4538       end if;
4539    end Is_Variable;
4540
4541    ------------------------
4542    -- Is_Volatile_Object --
4543    ------------------------
4544
4545    function Is_Volatile_Object (N : Node_Id) return Boolean is
4546
4547       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
4548       --  Determines if given object has volatile components
4549
4550       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
4551       --  If prefix is an implicit dereference, examine designated type.
4552
4553       ------------------------
4554       -- Is_Volatile_Prefix --
4555       ------------------------
4556
4557       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
4558          Typ  : constant Entity_Id := Etype (N);
4559
4560       begin
4561          if Is_Access_Type (Typ) then
4562             declare
4563                Dtyp : constant Entity_Id := Designated_Type (Typ);
4564
4565             begin
4566                return Is_Volatile (Dtyp)
4567                  or else Has_Volatile_Components (Dtyp);
4568             end;
4569
4570          else
4571             return Object_Has_Volatile_Components (N);
4572          end if;
4573       end Is_Volatile_Prefix;
4574
4575       ------------------------------------
4576       -- Object_Has_Volatile_Components --
4577       ------------------------------------
4578
4579       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
4580          Typ : constant Entity_Id := Etype (N);
4581
4582       begin
4583          if Is_Volatile (Typ)
4584            or else Has_Volatile_Components (Typ)
4585          then
4586             return True;
4587
4588          elsif Is_Entity_Name (N)
4589            and then (Has_Volatile_Components (Entity (N))
4590                       or else Is_Volatile (Entity (N)))
4591          then
4592             return True;
4593
4594          elsif Nkind (N) = N_Indexed_Component
4595            or else Nkind (N) = N_Selected_Component
4596          then
4597             return Is_Volatile_Prefix (Prefix (N));
4598
4599          else
4600             return False;
4601          end if;
4602       end Object_Has_Volatile_Components;
4603
4604    --  Start of processing for Is_Volatile_Object
4605
4606    begin
4607       if Is_Volatile (Etype (N))
4608         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
4609       then
4610          return True;
4611
4612       elsif Nkind (N) = N_Indexed_Component
4613         or else Nkind (N) = N_Selected_Component
4614       then
4615          return Is_Volatile_Prefix (Prefix (N));
4616
4617       else
4618          return False;
4619       end if;
4620    end Is_Volatile_Object;
4621
4622    -------------------------
4623    -- Kill_Current_Values --
4624    -------------------------
4625
4626    procedure Kill_Current_Values is
4627       S : Entity_Id;
4628
4629       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
4630       --  Clear current value for entity E and all entities chained to E
4631
4632       -------------------------------------------
4633       --  Kill_Current_Values_For_Entity_Chain --
4634       -------------------------------------------
4635
4636       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
4637          Ent : Entity_Id;
4638
4639       begin
4640          Ent := E;
4641          while Present (Ent) loop
4642             if Is_Object (Ent) then
4643                Set_Current_Value (Ent, Empty);
4644
4645                if not Can_Never_Be_Null (Ent) then
4646                   Set_Is_Known_Non_Null (Ent, False);
4647                end if;
4648             end if;
4649
4650             Next_Entity (Ent);
4651          end loop;
4652       end Kill_Current_Values_For_Entity_Chain;
4653
4654    --  Start of processing for Kill_Current_Values
4655
4656    begin
4657       --  Kill all saved checks, a special case of killing saved values
4658
4659       Kill_All_Checks;
4660
4661       --  Loop through relevant scopes, which includes the current scope and
4662       --  any parent scopes if the current scope is a block or a package.
4663
4664       S := Current_Scope;
4665       Scope_Loop : loop
4666
4667          --  Clear current values of all entities in current scope
4668
4669          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
4670
4671          --  If scope is a package, also clear current values of all
4672          --  private entities in the scope.
4673
4674          if Ekind (S) = E_Package
4675               or else
4676             Ekind (S) = E_Generic_Package
4677               or else
4678             Is_Concurrent_Type (S)
4679          then
4680             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
4681          end if;
4682
4683          --  If this is a block or nested package, deal with parent
4684
4685          if Ekind (S) = E_Block
4686            or else (Ekind (S) = E_Package
4687                       and then not Is_Library_Level_Entity (S))
4688          then
4689             S := Scope (S);
4690          else
4691             exit Scope_Loop;
4692          end if;
4693       end loop Scope_Loop;
4694    end Kill_Current_Values;
4695
4696    --------------------------
4697    -- Kill_Size_Check_Code --
4698    --------------------------
4699
4700    procedure Kill_Size_Check_Code (E : Entity_Id) is
4701    begin
4702       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
4703         and then Present (Size_Check_Code (E))
4704       then
4705          Remove (Size_Check_Code (E));
4706          Set_Size_Check_Code (E, Empty);
4707       end if;
4708    end Kill_Size_Check_Code;
4709
4710    -------------------------
4711    -- New_External_Entity --
4712    -------------------------
4713
4714    function New_External_Entity
4715      (Kind         : Entity_Kind;
4716       Scope_Id     : Entity_Id;
4717       Sloc_Value   : Source_Ptr;
4718       Related_Id   : Entity_Id;
4719       Suffix       : Character;
4720       Suffix_Index : Nat := 0;
4721       Prefix       : Character := ' ') return Entity_Id
4722    is
4723       N : constant Entity_Id :=
4724             Make_Defining_Identifier (Sloc_Value,
4725               New_External_Name
4726                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
4727
4728    begin
4729       Set_Ekind          (N, Kind);
4730       Set_Is_Internal    (N, True);
4731       Append_Entity      (N, Scope_Id);
4732       Set_Public_Status  (N);
4733
4734       if Kind in Type_Kind then
4735          Init_Size_Align (N);
4736       end if;
4737
4738       return N;
4739    end New_External_Entity;
4740
4741    -------------------------
4742    -- New_Internal_Entity --
4743    -------------------------
4744
4745    function New_Internal_Entity
4746      (Kind       : Entity_Kind;
4747       Scope_Id   : Entity_Id;
4748       Sloc_Value : Source_Ptr;
4749       Id_Char    : Character) return Entity_Id
4750    is
4751       N : constant Entity_Id :=
4752             Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
4753
4754    begin
4755       Set_Ekind          (N, Kind);
4756       Set_Is_Internal    (N, True);
4757       Append_Entity      (N, Scope_Id);
4758
4759       if Kind in Type_Kind then
4760          Init_Size_Align (N);
4761       end if;
4762
4763       return N;
4764    end New_Internal_Entity;
4765
4766    -----------------
4767    -- Next_Actual --
4768    -----------------
4769
4770    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
4771       N  : Node_Id;
4772
4773    begin
4774       --  If we are pointing at a positional parameter, it is a member of
4775       --  a node list (the list of parameters), and the next parameter
4776       --  is the next node on the list, unless we hit a parameter
4777       --  association, in which case we shift to using the chain whose
4778       --  head is the First_Named_Actual in the parent, and then is
4779       --  threaded using the Next_Named_Actual of the Parameter_Association.
4780       --  All this fiddling is because the original node list is in the
4781       --  textual call order, and what we need is the declaration order.
4782
4783       if Is_List_Member (Actual_Id) then
4784          N := Next (Actual_Id);
4785
4786          if Nkind (N) = N_Parameter_Association then
4787             return First_Named_Actual (Parent (Actual_Id));
4788          else
4789             return N;
4790          end if;
4791
4792       else
4793          return Next_Named_Actual (Parent (Actual_Id));
4794       end if;
4795    end Next_Actual;
4796
4797    procedure Next_Actual (Actual_Id : in out Node_Id) is
4798    begin
4799       Actual_Id := Next_Actual (Actual_Id);
4800    end Next_Actual;
4801
4802    -----------------------
4803    -- Normalize_Actuals --
4804    -----------------------
4805
4806    --  Chain actuals according to formals of subprogram. If there are
4807    --  no named associations, the chain is simply the list of Parameter
4808    --  Associations, since the order is the same as the declaration order.
4809    --  If there are named associations, then the First_Named_Actual field
4810    --  in the N_Procedure_Call_Statement node or N_Function_Call node
4811    --  points to the Parameter_Association node for the parameter that
4812    --  comes first in declaration order. The remaining named parameters
4813    --  are then chained in declaration order using Next_Named_Actual.
4814
4815    --  This routine also verifies that the number of actuals is compatible
4816    --  with the number and default values of formals, but performs no type
4817    --  checking (type checking is done by the caller).
4818
4819    --  If the matching succeeds, Success is set to True, and the caller
4820    --  proceeds with type-checking. If the match is unsuccessful, then
4821    --  Success is set to False, and the caller attempts a different
4822    --  interpretation, if there is one.
4823
4824    --  If the flag Report is on, the call is not overloaded, and a failure
4825    --  to match can be reported here, rather than in the caller.
4826
4827    procedure Normalize_Actuals
4828      (N       : Node_Id;
4829       S       : Entity_Id;
4830       Report  : Boolean;
4831       Success : out Boolean)
4832    is
4833       Actuals     : constant List_Id := Parameter_Associations (N);
4834       Actual      : Node_Id   := Empty;
4835       Formal      : Entity_Id;
4836       Last        : Node_Id := Empty;
4837       First_Named : Node_Id := Empty;
4838       Found       : Boolean;
4839
4840       Formals_To_Match : Integer := 0;
4841       Actuals_To_Match : Integer := 0;
4842
4843       procedure Chain (A : Node_Id);
4844       --  Add named actual at the proper place in the list, using the
4845       --  Next_Named_Actual link.
4846
4847       function Reporting return Boolean;
4848       --  Determines if an error is to be reported. To report an error, we
4849       --  need Report to be True, and also we do not report errors caused
4850       --  by calls to init procs that occur within other init procs. Such
4851       --  errors must always be cascaded errors, since if all the types are
4852       --  declared correctly, the compiler will certainly build decent calls!
4853
4854       -----------
4855       -- Chain --
4856       -----------
4857
4858       procedure Chain (A : Node_Id) is
4859       begin
4860          if No (Last) then
4861
4862             --  Call node points to first actual in list.
4863
4864             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
4865
4866          else
4867             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
4868          end if;
4869
4870          Last := A;
4871          Set_Next_Named_Actual (Last, Empty);
4872       end Chain;
4873
4874       ---------------
4875       -- Reporting --
4876       ---------------
4877
4878       function Reporting return Boolean is
4879       begin
4880          if not Report then
4881             return False;
4882
4883          elsif not Within_Init_Proc then
4884             return True;
4885
4886          elsif Is_Init_Proc (Entity (Name (N))) then
4887             return False;
4888
4889          else
4890             return True;
4891          end if;
4892       end Reporting;
4893
4894    --  Start of processing for Normalize_Actuals
4895
4896    begin
4897       if Is_Access_Type (S) then
4898
4899          --  The name in the call is a function call that returns an access
4900          --  to subprogram. The designated type has the list of formals.
4901
4902          Formal := First_Formal (Designated_Type (S));
4903       else
4904          Formal := First_Formal (S);
4905       end if;
4906
4907       while Present (Formal) loop
4908          Formals_To_Match := Formals_To_Match + 1;
4909          Next_Formal (Formal);
4910       end loop;
4911
4912       --  Find if there is a named association, and verify that no positional
4913       --  associations appear after named ones.
4914
4915       if Present (Actuals) then
4916          Actual := First (Actuals);
4917       end if;
4918
4919       while Present (Actual)
4920         and then Nkind (Actual) /= N_Parameter_Association
4921       loop
4922          Actuals_To_Match := Actuals_To_Match + 1;
4923          Next (Actual);
4924       end loop;
4925
4926       if No (Actual) and Actuals_To_Match = Formals_To_Match then
4927
4928          --  Most common case: positional notation, no defaults
4929
4930          Success := True;
4931          return;
4932
4933       elsif Actuals_To_Match > Formals_To_Match then
4934
4935          --  Too many actuals: will not work.
4936
4937          if Reporting then
4938             if Is_Entity_Name (Name (N)) then
4939                Error_Msg_N ("too many arguments in call to&", Name (N));
4940             else
4941                Error_Msg_N ("too many arguments in call", N);
4942             end if;
4943          end if;
4944
4945          Success := False;
4946          return;
4947       end if;
4948
4949       First_Named := Actual;
4950
4951       while Present (Actual) loop
4952          if Nkind (Actual) /= N_Parameter_Association then
4953             Error_Msg_N
4954               ("positional parameters not allowed after named ones", Actual);
4955             Success := False;
4956             return;
4957
4958          else
4959             Actuals_To_Match := Actuals_To_Match + 1;
4960          end if;
4961
4962          Next (Actual);
4963       end loop;
4964
4965       if Present (Actuals) then
4966          Actual := First (Actuals);
4967       end if;
4968
4969       Formal := First_Formal (S);
4970
4971       while Present (Formal) loop
4972
4973          --  Match the formals in order. If the corresponding actual
4974          --  is positional,  nothing to do. Else scan the list of named
4975          --  actuals to find the one with the right name.
4976
4977          if Present (Actual)
4978            and then Nkind (Actual) /= N_Parameter_Association
4979          then
4980             Next (Actual);
4981             Actuals_To_Match := Actuals_To_Match - 1;
4982             Formals_To_Match := Formals_To_Match - 1;
4983
4984          else
4985             --  For named parameters, search the list of actuals to find
4986             --  one that matches the next formal name.
4987
4988             Actual := First_Named;
4989             Found  := False;
4990
4991             while Present (Actual) loop
4992                if Chars (Selector_Name (Actual)) = Chars (Formal) then
4993                   Found := True;
4994                   Chain (Actual);
4995                   Actuals_To_Match := Actuals_To_Match - 1;
4996                   Formals_To_Match := Formals_To_Match - 1;
4997                   exit;
4998                end if;
4999
5000                Next (Actual);
5001             end loop;
5002
5003             if not Found then
5004                if Ekind (Formal) /= E_In_Parameter
5005                  or else No (Default_Value (Formal))
5006                then
5007                   if Reporting then
5008                      if (Comes_From_Source (S)
5009                           or else Sloc (S) = Standard_Location)
5010                        and then Is_Overloadable (S)
5011                      then
5012                         if No (Actuals)
5013                           and then
5014                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
5015                              or else
5016                            (Nkind (Parent (N)) = N_Function_Call
5017                              or else
5018                            Nkind (Parent (N)) = N_Parameter_Association))
5019                         then
5020                            Set_Etype (N, Etype (S));
5021                         else
5022                            Error_Msg_Name_1 := Chars (S);
5023                            Error_Msg_Sloc := Sloc (S);
5024                            Error_Msg_NE
5025                              ("missing argument for parameter & " &
5026                                 "in call to % declared #", N, Formal);
5027                         end if;
5028
5029                      elsif Is_Overloadable (S) then
5030                         Error_Msg_Name_1 := Chars (S);
5031
5032                         --  Point to type derivation that generated the
5033                         --  operation.
5034
5035                         Error_Msg_Sloc := Sloc (Parent (S));
5036
5037                         Error_Msg_NE
5038                           ("missing argument for parameter & " &
5039                              "in call to % (inherited) #", N, Formal);
5040
5041                      else
5042                         Error_Msg_NE
5043                           ("missing argument for parameter &", N, Formal);
5044                      end if;
5045                   end if;
5046
5047                   Success := False;
5048                   return;
5049
5050                else
5051                   Formals_To_Match := Formals_To_Match - 1;
5052                end if;
5053             end if;
5054          end if;
5055
5056          Next_Formal (Formal);
5057       end loop;
5058
5059       if  Formals_To_Match = 0 and then Actuals_To_Match = 0 then
5060          Success := True;
5061          return;
5062
5063       else
5064          if Reporting then
5065
5066             --  Find some superfluous named actual that did not get
5067             --  attached to the list of associations.
5068
5069             Actual := First (Actuals);
5070
5071             while Present (Actual) loop
5072
5073                if Nkind (Actual) = N_Parameter_Association
5074                  and then Actual /= Last
5075                  and then No (Next_Named_Actual (Actual))
5076                then
5077                   Error_Msg_N ("unmatched actual & in call",
5078                     Selector_Name (Actual));
5079                   exit;
5080                end if;
5081
5082                Next (Actual);
5083             end loop;
5084          end if;
5085
5086          Success := False;
5087          return;
5088       end if;
5089    end Normalize_Actuals;
5090
5091    --------------------------------
5092    -- Note_Possible_Modification --
5093    --------------------------------
5094
5095    procedure Note_Possible_Modification (N : Node_Id) is
5096       Modification_Comes_From_Source : constant Boolean :=
5097                                          Comes_From_Source (Parent (N));
5098
5099       Ent : Entity_Id;
5100       Exp : Node_Id;
5101
5102    begin
5103       --  Loop to find referenced entity, if there is one
5104
5105       Exp := N;
5106       loop
5107          <<Continue>>
5108          Ent := Empty;
5109
5110          if Is_Entity_Name (Exp) then
5111             Ent := Entity (Exp);
5112
5113          elsif Nkind (Exp) = N_Explicit_Dereference then
5114             declare
5115                P : constant Node_Id := Prefix (Exp);
5116
5117             begin
5118                if Nkind (P) = N_Selected_Component
5119                  and then Present (
5120                    Entry_Formal (Entity (Selector_Name (P))))
5121                then
5122                   --  Case of a reference to an entry formal
5123
5124                   Ent := Entry_Formal (Entity (Selector_Name (P)));
5125
5126                elsif Nkind (P) = N_Identifier
5127                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
5128                  and then Present (Expression (Parent (Entity (P))))
5129                  and then Nkind (Expression (Parent (Entity (P))))
5130                    = N_Reference
5131                then
5132                   --  Case of a reference to a value on which
5133                   --  side effects have been removed.
5134
5135                   Exp := Prefix (Expression (Parent (Entity (P))));
5136
5137                else
5138                   return;
5139
5140                end if;
5141             end;
5142
5143          elsif     Nkind (Exp) = N_Type_Conversion
5144            or else Nkind (Exp) = N_Unchecked_Type_Conversion
5145          then
5146             Exp := Expression (Exp);
5147
5148          elsif     Nkind (Exp) = N_Slice
5149            or else Nkind (Exp) = N_Indexed_Component
5150            or else Nkind (Exp) = N_Selected_Component
5151          then
5152             Exp := Prefix (Exp);
5153
5154          else
5155             return;
5156
5157          end if;
5158
5159          --  Now look for entity being referenced
5160
5161          if Present (Ent) then
5162
5163             if Is_Object (Ent) then
5164                if Comes_From_Source (Exp)
5165                  or else Modification_Comes_From_Source
5166                then
5167                   Set_Never_Set_In_Source (Ent, False);
5168                end if;
5169
5170                Set_Is_True_Constant    (Ent, False);
5171                Set_Current_Value       (Ent, Empty);
5172
5173                if not Can_Never_Be_Null (Ent) then
5174                   Set_Is_Known_Non_Null (Ent, False);
5175                end if;
5176
5177                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
5178                  and then Present (Renamed_Object (Ent))
5179                then
5180                   Exp := Renamed_Object (Ent);
5181                   goto Continue;
5182                end if;
5183
5184                Generate_Reference (Ent, Exp, 'm');
5185             end if;
5186
5187             Kill_Checks (Ent);
5188             return;
5189          end if;
5190       end loop;
5191    end Note_Possible_Modification;
5192
5193    -------------------------
5194    -- Object_Access_Level --
5195    -------------------------
5196
5197    function Object_Access_Level (Obj : Node_Id) return Uint is
5198       E : Entity_Id;
5199
5200    --  Returns the static accessibility level of the view denoted
5201    --  by Obj.  Note that the value returned is the result of a
5202    --  call to Scope_Depth.  Only scope depths associated with
5203    --  dynamic scopes can actually be returned.  Since only
5204    --  relative levels matter for accessibility checking, the fact
5205    --  that the distance between successive levels of accessibility
5206    --  is not always one is immaterial (invariant: if level(E2) is
5207    --  deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
5208
5209    begin
5210       if Is_Entity_Name (Obj) then
5211          E := Entity (Obj);
5212
5213          --  If E is a type then it denotes a current instance.
5214          --  For this case we add one to the normal accessibility
5215          --  level of the type to ensure that current instances
5216          --  are treated as always being deeper than than the level
5217          --  of any visible named access type (see 3.10.2(21)).
5218
5219          if Is_Type (E) then
5220             return Type_Access_Level (E) +  1;
5221
5222          elsif Present (Renamed_Object (E)) then
5223             return Object_Access_Level (Renamed_Object (E));
5224
5225          --  Similarly, if E is a component of the current instance of a
5226          --  protected type, any instance of it is assumed to be at a deeper
5227          --  level than the type. For a protected object (whose type is an
5228          --  anonymous protected type) its components are at the same level
5229          --  as the type itself.
5230
5231          elsif not Is_Overloadable (E)
5232            and then Ekind (Scope (E)) = E_Protected_Type
5233            and then Comes_From_Source (Scope (E))
5234          then
5235             return Type_Access_Level (Scope (E)) + 1;
5236
5237          else
5238             return Scope_Depth (Enclosing_Dynamic_Scope (E));
5239          end if;
5240
5241       elsif Nkind (Obj) = N_Selected_Component then
5242          if Is_Access_Type (Etype (Prefix (Obj))) then
5243             return Type_Access_Level (Etype (Prefix (Obj)));
5244          else
5245             return Object_Access_Level (Prefix (Obj));
5246          end if;
5247
5248       elsif Nkind (Obj) = N_Indexed_Component then
5249          if Is_Access_Type (Etype (Prefix (Obj))) then
5250             return Type_Access_Level (Etype (Prefix (Obj)));
5251          else
5252             return Object_Access_Level (Prefix (Obj));
5253          end if;
5254
5255       elsif Nkind (Obj) = N_Explicit_Dereference then
5256
5257          --  If the prefix is a selected access discriminant then
5258          --  we make a recursive call on the prefix, which will
5259          --  in turn check the level of the prefix object of
5260          --  the selected discriminant.
5261
5262          if Nkind (Prefix (Obj)) = N_Selected_Component
5263            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
5264            and then
5265              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
5266          then
5267             return Object_Access_Level (Prefix (Obj));
5268          else
5269             return Type_Access_Level (Etype (Prefix (Obj)));
5270          end if;
5271
5272       elsif Nkind (Obj) = N_Type_Conversion
5273         or else Nkind (Obj) = N_Unchecked_Type_Conversion
5274       then
5275          return Object_Access_Level (Expression (Obj));
5276
5277       --  Function results are objects, so we get either the access level
5278       --  of the function or, in the case of an indirect call, the level of
5279       --  of the access-to-subprogram type.
5280
5281       elsif Nkind (Obj) = N_Function_Call then
5282          if Is_Entity_Name (Name (Obj)) then
5283             return Subprogram_Access_Level (Entity (Name (Obj)));
5284          else
5285             return Type_Access_Level (Etype (Prefix (Name (Obj))));
5286          end if;
5287
5288       --  For convenience we handle qualified expressions, even though
5289       --  they aren't technically object names.
5290
5291       elsif Nkind (Obj) = N_Qualified_Expression then
5292          return Object_Access_Level (Expression (Obj));
5293
5294       --  Otherwise return the scope level of Standard.
5295       --  (If there are cases that fall through
5296       --  to this point they will be treated as
5297       --  having global accessibility for now. ???)
5298
5299       else
5300          return Scope_Depth (Standard_Standard);
5301       end if;
5302    end Object_Access_Level;
5303
5304    -----------------------
5305    -- Private_Component --
5306    -----------------------
5307
5308    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
5309       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
5310
5311       function Trace_Components
5312         (T     : Entity_Id;
5313          Check : Boolean) return Entity_Id;
5314       --  Recursive function that does the work, and checks against circular
5315       --  definition for each subcomponent type.
5316
5317       ----------------------
5318       -- Trace_Components --
5319       ----------------------
5320
5321       function Trace_Components
5322          (T     : Entity_Id;
5323           Check : Boolean) return Entity_Id
5324        is
5325          Btype     : constant Entity_Id := Base_Type (T);
5326          Component : Entity_Id;
5327          P         : Entity_Id;
5328          Candidate : Entity_Id := Empty;
5329
5330       begin
5331          if Check and then Btype = Ancestor then
5332             Error_Msg_N ("circular type definition", Type_Id);
5333             return Any_Type;
5334          end if;
5335
5336          if Is_Private_Type (Btype)
5337            and then not Is_Generic_Type (Btype)
5338          then
5339             return Btype;
5340
5341          elsif Is_Array_Type (Btype) then
5342             return Trace_Components (Component_Type (Btype), True);
5343
5344          elsif Is_Record_Type (Btype) then
5345             Component := First_Entity (Btype);
5346             while Present (Component) loop
5347
5348                --  skip anonymous types generated by constrained components.
5349
5350                if not Is_Type (Component) then
5351                   P := Trace_Components (Etype (Component), True);
5352
5353                   if Present (P) then
5354                      if P = Any_Type then
5355                         return P;
5356                      else
5357                         Candidate := P;
5358                      end if;
5359                   end if;
5360                end if;
5361
5362                Next_Entity (Component);
5363             end loop;
5364
5365             return Candidate;
5366
5367          else
5368             return Empty;
5369          end if;
5370       end Trace_Components;
5371
5372    --  Start of processing for Private_Component
5373
5374    begin
5375       return Trace_Components (Type_Id, False);
5376    end Private_Component;
5377
5378    -----------------------
5379    -- Process_End_Label --
5380    -----------------------
5381
5382    procedure Process_End_Label
5383      (N   : Node_Id;
5384       Typ : Character;
5385       Ent  : Entity_Id)
5386    is
5387       Loc  : Source_Ptr;
5388       Nam  : Node_Id;
5389
5390       Label_Ref : Boolean;
5391       --  Set True if reference to end label itself is required
5392
5393       Endl : Node_Id;
5394       --  Gets set to the operator symbol or identifier that references
5395       --  the entity Ent. For the child unit case, this is the identifier
5396       --  from the designator. For other cases, this is simply Endl.
5397
5398       procedure Generate_Parent_Ref (N : Node_Id);
5399       --  N is an identifier node that appears as a parent unit reference
5400       --  in the case where Ent is a child unit. This procedure generates
5401       --  an appropriate cross-reference entry.
5402
5403       -------------------------
5404       -- Generate_Parent_Ref --
5405       -------------------------
5406
5407       procedure Generate_Parent_Ref (N : Node_Id) is
5408          Parent_Ent : Entity_Id;
5409
5410       begin
5411          --  Search up scope stack. The reason we do this is that normal
5412          --  visibility analysis would not work for two reasons. First in
5413          --  some subunit cases, the entry for the parent unit may not be
5414          --  visible, and in any case there can be a local entity that
5415          --  hides the scope entity.
5416
5417          Parent_Ent := Current_Scope;
5418          while Present (Parent_Ent) loop
5419             if Chars (Parent_Ent) = Chars (N) then
5420
5421                --  Generate the reference. We do NOT consider this as a
5422                --  reference for unreferenced symbol purposes, but we do
5423                --  force a cross-reference even if the end line does not
5424                --  come from source (the caller already generated the
5425                --  appropriate Typ for this situation).
5426
5427                Generate_Reference
5428                  (Parent_Ent, N, 'r', Set_Ref => False, Force => True);
5429                Style.Check_Identifier (N, Parent_Ent);
5430                return;
5431             end if;
5432
5433             Parent_Ent := Scope (Parent_Ent);
5434          end loop;
5435
5436          --  Fall through means entity was not found -- that's odd, but
5437          --  the appropriate thing is simply to ignore and not generate
5438          --  any cross-reference for this entry.
5439
5440          return;
5441       end Generate_Parent_Ref;
5442
5443    --  Start of processing for Process_End_Label
5444
5445    begin
5446       --  If no node, ignore. This happens in some error situations,
5447       --  and also for some internally generated structures where no
5448       --  end label references are required in any case.
5449
5450       if No (N) then
5451          return;
5452       end if;
5453
5454       --  Nothing to do if no End_Label, happens for internally generated
5455       --  constructs where we don't want an end label reference anyway.
5456       --  Also nothing to do if Endl is a string literal, which means
5457       --  there was some prior error (bad operator symbol)
5458
5459       Endl := End_Label (N);
5460
5461       if No (Endl) or else Nkind (Endl) = N_String_Literal then
5462          return;
5463       end if;
5464
5465       --  Reference node is not in extended main source unit
5466
5467       if not In_Extended_Main_Source_Unit (N) then
5468
5469          --  Generally we do not collect references except for the
5470          --  extended main source unit. The one exception is the 'e'
5471          --  entry for a package spec, where it is useful for a client
5472          --  to have the ending information to define scopes.
5473
5474          if Typ /= 'e' then
5475             return;
5476
5477          else
5478             Label_Ref := False;
5479
5480             --  For this case, we can ignore any parent references,
5481             --  but we need the package name itself for the 'e' entry.
5482
5483             if Nkind (Endl) = N_Designator then
5484                Endl := Identifier (Endl);
5485             end if;
5486          end if;
5487
5488       --  Reference is in extended main source unit
5489
5490       else
5491          Label_Ref := True;
5492
5493          --  For designator, generate references for the parent entries
5494
5495          if Nkind (Endl) = N_Designator then
5496
5497             --  Generate references for the prefix if the END line comes
5498             --  from source (otherwise we do not need these references)
5499
5500             if Comes_From_Source (Endl) then
5501                Nam := Name (Endl);
5502                while Nkind (Nam) = N_Selected_Component loop
5503                   Generate_Parent_Ref (Selector_Name (Nam));
5504                   Nam := Prefix (Nam);
5505                end loop;
5506
5507                Generate_Parent_Ref (Nam);
5508             end if;
5509
5510             Endl := Identifier (Endl);
5511          end if;
5512       end if;
5513
5514       --  If the end label is not for the given entity, then either we have
5515       --  some previous error, or this is a generic instantiation for which
5516       --  we do not need to make a cross-reference in this case anyway. In
5517       --  either case we simply ignore the call.
5518
5519       if Chars (Ent) /= Chars (Endl) then
5520          return;
5521       end if;
5522
5523       --  If label was really there, then generate a normal reference
5524       --  and then adjust the location in the end label to point past
5525       --  the name (which should almost always be the semicolon).
5526
5527       Loc := Sloc (Endl);
5528
5529       if Comes_From_Source (Endl) then
5530
5531          --  If a label reference is required, then do the style check
5532          --  and generate an l-type cross-reference entry for the label
5533
5534          if Label_Ref then
5535             if Style_Check then
5536                Style.Check_Identifier (Endl, Ent);
5537             end if;
5538             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
5539          end if;
5540
5541          --  Set the location to point past the label (normally this will
5542          --  mean the semicolon immediately following the label). This is
5543          --  done for the sake of the 'e' or 't' entry generated below.
5544
5545          Get_Decoded_Name_String (Chars (Endl));
5546          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
5547       end if;
5548
5549       --  Now generate the e/t reference
5550
5551       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
5552
5553       --  Restore Sloc, in case modified above, since we have an identifier
5554       --  and the normal Sloc should be left set in the tree.
5555
5556       Set_Sloc (Endl, Loc);
5557    end Process_End_Label;
5558
5559    ------------------
5560    -- Real_Convert --
5561    ------------------
5562
5563    --  We do the conversion to get the value of the real string by using
5564    --  the scanner, see Sinput for details on use of the internal source
5565    --  buffer for scanning internal strings.
5566
5567    function Real_Convert (S : String) return Node_Id is
5568       Save_Src : constant Source_Buffer_Ptr := Source;
5569       Negative : Boolean;
5570
5571    begin
5572       Source := Internal_Source_Ptr;
5573       Scan_Ptr := 1;
5574
5575       for J in S'Range loop
5576          Source (Source_Ptr (J)) := S (J);
5577       end loop;
5578
5579       Source (S'Length + 1) := EOF;
5580
5581       if Source (Scan_Ptr) = '-' then
5582          Negative := True;
5583          Scan_Ptr := Scan_Ptr + 1;
5584       else
5585          Negative := False;
5586       end if;
5587
5588       Scan;
5589
5590       if Negative then
5591          Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
5592       end if;
5593
5594       Source := Save_Src;
5595       return Token_Node;
5596    end Real_Convert;
5597
5598    ---------------------
5599    -- Rep_To_Pos_Flag --
5600    ---------------------
5601
5602    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
5603    begin
5604       return New_Occurrence_Of
5605                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
5606    end Rep_To_Pos_Flag;
5607
5608    --------------------
5609    -- Require_Entity --
5610    --------------------
5611
5612    procedure Require_Entity (N : Node_Id) is
5613    begin
5614       if Is_Entity_Name (N) and then No (Entity (N)) then
5615          if Total_Errors_Detected /= 0 then
5616             Set_Entity (N, Any_Id);
5617          else
5618             raise Program_Error;
5619          end if;
5620       end if;
5621    end Require_Entity;
5622
5623    ------------------------------
5624    -- Requires_Transient_Scope --
5625    ------------------------------
5626
5627    --  A transient scope is required when variable-sized temporaries are
5628    --  allocated in the primary or secondary stack, or when finalization
5629    --  actions must be generated before the next instruction
5630
5631    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
5632       Typ : constant Entity_Id := Underlying_Type (Id);
5633
5634    begin
5635       --  This is a private type which is not completed yet. This can only
5636       --  happen in a default expression (of a formal parameter or of a
5637       --  record component). Do not expand transient scope in this case
5638
5639       if No (Typ) then
5640          return False;
5641
5642       elsif Typ = Standard_Void_Type then
5643          return False;
5644
5645       --  The back-end has trouble allocating variable-size temporaries so
5646       --  we generate them in the front-end and need a transient scope to
5647       --  reclaim them properly
5648
5649       elsif not Size_Known_At_Compile_Time (Typ) then
5650          return True;
5651
5652       --  Unconstrained discriminated records always require a variable
5653       --  length temporary, since the length may depend on the variant.
5654
5655       elsif Is_Record_Type (Typ)
5656         and then Has_Discriminants (Typ)
5657         and then not Is_Constrained (Typ)
5658       then
5659          return True;
5660
5661       --  Functions returning tagged types may dispatch on result so their
5662       --  returned value is allocated on the secondary stack. Controlled
5663       --  type temporaries need finalization.
5664
5665       elsif Is_Tagged_Type (Typ)
5666         or else Has_Controlled_Component (Typ)
5667       then
5668          return True;
5669
5670       --  Unconstrained array types are returned on the secondary stack
5671
5672       elsif Is_Array_Type (Typ) then
5673          return not Is_Constrained (Typ);
5674       end if;
5675
5676       return False;
5677    end Requires_Transient_Scope;
5678
5679    --------------------------
5680    -- Reset_Analyzed_Flags --
5681    --------------------------
5682
5683    procedure Reset_Analyzed_Flags (N : Node_Id) is
5684
5685       function Clear_Analyzed
5686         (N : Node_Id) return Traverse_Result;
5687       --  Function used to reset Analyzed flags in tree. Note that we do
5688       --  not reset Analyzed flags in entities, since there is no need to
5689       --  renalalyze entities, and indeed, it is wrong to do so, since it
5690       --  can result in generating auxiliary stuff more than once.
5691
5692       --------------------
5693       -- Clear_Analyzed --
5694       --------------------
5695
5696       function Clear_Analyzed
5697         (N : Node_Id) return Traverse_Result
5698       is
5699       begin
5700          if not Has_Extension (N) then
5701             Set_Analyzed (N, False);
5702          end if;
5703
5704          return OK;
5705       end Clear_Analyzed;
5706
5707       function Reset_Analyzed is
5708         new Traverse_Func (Clear_Analyzed);
5709
5710       Discard : Traverse_Result;
5711       pragma Warnings (Off, Discard);
5712
5713    --  Start of processing for Reset_Analyzed_Flags
5714
5715    begin
5716       Discard := Reset_Analyzed (N);
5717    end Reset_Analyzed_Flags;
5718
5719    ---------------------------
5720    -- Safe_To_Capture_Value --
5721    ---------------------------
5722
5723    function Safe_To_Capture_Value
5724      (N   : Node_Id;
5725       Ent : Entity_Id) return Boolean
5726    is
5727    begin
5728       --  The only entities for which we track constant values are variables,
5729       --  out parameters and in out parameters, so check if we have this case.
5730
5731       if Ekind (Ent) /= E_Variable
5732            and then
5733          Ekind (Ent) /= E_Out_Parameter
5734            and then
5735          Ekind (Ent) /= E_In_Out_Parameter
5736       then
5737          return False;
5738       end if;
5739
5740       --  Skip volatile and aliased variables, since funny things might
5741       --  be going on in these cases which we cannot necessarily track.
5742
5743       if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) then
5744          return False;
5745       end if;
5746
5747       --  OK, all above conditions are met. We also require that the scope
5748       --  of the reference be the same as the scope of the entity, not
5749       --  counting packages and blocks.
5750
5751       declare
5752          E_Scope : constant Entity_Id := Scope (Ent);
5753          R_Scope : Entity_Id;
5754
5755       begin
5756          R_Scope := Current_Scope;
5757          while R_Scope /= Standard_Standard loop
5758             exit when R_Scope = E_Scope;
5759
5760             if Ekind (R_Scope) /= E_Package
5761                  and then
5762                Ekind (R_Scope) /= E_Block
5763             then
5764                return False;
5765             else
5766                R_Scope := Scope (R_Scope);
5767             end if;
5768          end loop;
5769       end;
5770
5771       --  We also require that the reference does not appear in a context
5772       --  where it is not sure to be executed (i.e. a conditional context
5773       --  or an exception handler).
5774
5775       declare
5776          P : Node_Id;
5777
5778       begin
5779          P := Parent (N);
5780          while Present (P) loop
5781             if Nkind (P) = N_If_Statement
5782                  or else
5783                Nkind (P) = N_Case_Statement
5784                  or else
5785                Nkind (P) = N_Exception_Handler
5786                  or else
5787                Nkind (P) = N_Selective_Accept
5788                  or else
5789                Nkind (P) = N_Conditional_Entry_Call
5790                  or else
5791                Nkind (P) = N_Timed_Entry_Call
5792                  or else
5793                Nkind (P) = N_Asynchronous_Select
5794             then
5795                return False;
5796             else
5797                P := Parent (P);
5798             end if;
5799          end loop;
5800       end;
5801
5802       --  OK, looks safe to set value
5803
5804       return True;
5805    end Safe_To_Capture_Value;
5806
5807    ---------------
5808    -- Same_Name --
5809    ---------------
5810
5811    function Same_Name (N1, N2 : Node_Id) return Boolean is
5812       K1 : constant Node_Kind := Nkind (N1);
5813       K2 : constant Node_Kind := Nkind (N2);
5814
5815    begin
5816       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
5817         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
5818       then
5819          return Chars (N1) = Chars (N2);
5820
5821       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
5822         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
5823       then
5824          return Same_Name (Selector_Name (N1), Selector_Name (N2))
5825            and then Same_Name (Prefix (N1), Prefix (N2));
5826
5827       else
5828          return False;
5829       end if;
5830    end Same_Name;
5831
5832    ---------------
5833    -- Same_Type --
5834    ---------------
5835
5836    function Same_Type (T1, T2 : Entity_Id) return Boolean is
5837    begin
5838       if T1 = T2 then
5839          return True;
5840
5841       elsif not Is_Constrained (T1)
5842         and then not Is_Constrained (T2)
5843         and then Base_Type (T1) = Base_Type (T2)
5844       then
5845          return True;
5846
5847       --  For now don't bother with case of identical constraints, to be
5848       --  fiddled with later on perhaps (this is only used for optimization
5849       --  purposes, so it is not critical to do a best possible job)
5850
5851       else
5852          return False;
5853       end if;
5854    end Same_Type;
5855
5856    ------------------------
5857    -- Scope_Is_Transient --
5858    ------------------------
5859
5860    function Scope_Is_Transient  return Boolean is
5861    begin
5862       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
5863    end Scope_Is_Transient;
5864
5865    ------------------
5866    -- Scope_Within --
5867    ------------------
5868
5869    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
5870       Scop : Entity_Id;
5871
5872    begin
5873       Scop := Scope1;
5874       while Scop /= Standard_Standard loop
5875          Scop := Scope (Scop);
5876
5877          if Scop = Scope2 then
5878             return True;
5879          end if;
5880       end loop;
5881
5882       return False;
5883    end Scope_Within;
5884
5885    --------------------------
5886    -- Scope_Within_Or_Same --
5887    --------------------------
5888
5889    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
5890       Scop : Entity_Id;
5891
5892    begin
5893       Scop := Scope1;
5894       while Scop /= Standard_Standard loop
5895          if Scop = Scope2 then
5896             return True;
5897          else
5898             Scop := Scope (Scop);
5899          end if;
5900       end loop;
5901
5902       return False;
5903    end Scope_Within_Or_Same;
5904
5905    ------------------------
5906    -- Set_Current_Entity --
5907    ------------------------
5908
5909    --  The given entity is to be set as the currently visible definition
5910    --  of its associated name (i.e. the Node_Id associated with its name).
5911    --  All we have to do is to get the name from the identifier, and
5912    --  then set the associated Node_Id to point to the given entity.
5913
5914    procedure Set_Current_Entity (E : Entity_Id) is
5915    begin
5916       Set_Name_Entity_Id (Chars (E), E);
5917    end Set_Current_Entity;
5918
5919    ---------------------------------
5920    -- Set_Entity_With_Style_Check --
5921    ---------------------------------
5922
5923    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
5924       Val_Actual : Entity_Id;
5925       Nod        : Node_Id;
5926
5927    begin
5928       Set_Entity (N, Val);
5929
5930       if Style_Check
5931         and then not Suppress_Style_Checks (Val)
5932         and then not In_Instance
5933       then
5934          if Nkind (N) = N_Identifier then
5935             Nod := N;
5936
5937          elsif Nkind (N) = N_Expanded_Name then
5938             Nod := Selector_Name (N);
5939
5940          else
5941             return;
5942          end if;
5943
5944          Val_Actual := Val;
5945
5946          --  A special situation arises for derived operations, where we want
5947          --  to do the check against the parent (since the Sloc of the derived
5948          --  operation points to the derived type declaration itself).
5949
5950          while not Comes_From_Source (Val_Actual)
5951            and then Nkind (Val_Actual) in N_Entity
5952            and then (Ekind (Val_Actual) = E_Enumeration_Literal
5953                       or else Is_Subprogram (Val_Actual)
5954                       or else Is_Generic_Subprogram (Val_Actual))
5955            and then Present (Alias (Val_Actual))
5956          loop
5957             Val_Actual := Alias (Val_Actual);
5958          end loop;
5959
5960          --  Renaming declarations for generic actuals do not come from source,
5961          --  and have a different name from that of the entity they rename, so
5962          --  there is no style check to perform here.
5963
5964          if Chars (Nod) = Chars (Val_Actual) then
5965             Style.Check_Identifier (Nod, Val_Actual);
5966          end if;
5967       end if;
5968
5969       Set_Entity (N, Val);
5970    end Set_Entity_With_Style_Check;
5971
5972    ------------------------
5973    -- Set_Name_Entity_Id --
5974    ------------------------
5975
5976    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
5977    begin
5978       Set_Name_Table_Info (Id, Int (Val));
5979    end Set_Name_Entity_Id;
5980
5981    ---------------------
5982    -- Set_Next_Actual --
5983    ---------------------
5984
5985    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
5986    begin
5987       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
5988          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
5989       end if;
5990    end Set_Next_Actual;
5991
5992    -----------------------
5993    -- Set_Public_Status --
5994    -----------------------
5995
5996    procedure Set_Public_Status (Id : Entity_Id) is
5997       S : constant Entity_Id := Current_Scope;
5998
5999    begin
6000       if S = Standard_Standard
6001         or else (Is_Public (S)
6002                   and then (Ekind (S) = E_Package
6003                              or else Is_Record_Type (S)
6004                              or else Ekind (S) = E_Void))
6005       then
6006          Set_Is_Public (Id);
6007
6008       --  The bounds of an entry family declaration can generate object
6009       --  declarations that are visible to the back-end, e.g. in the
6010       --  the declaration of a composite type that contains tasks.
6011
6012       elsif Is_Public (S)
6013         and then Is_Concurrent_Type (S)
6014         and then not Has_Completion (S)
6015         and then Nkind (Parent (Id)) = N_Object_Declaration
6016       then
6017          Set_Is_Public (Id);
6018       end if;
6019    end Set_Public_Status;
6020
6021    ----------------------------
6022    -- Set_Scope_Is_Transient --
6023    ----------------------------
6024
6025    procedure Set_Scope_Is_Transient (V : Boolean := True) is
6026    begin
6027       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
6028    end Set_Scope_Is_Transient;
6029
6030    -------------------
6031    -- Set_Size_Info --
6032    -------------------
6033
6034    procedure Set_Size_Info (T1, T2 : Entity_Id) is
6035    begin
6036       --  We copy Esize, but not RM_Size, since in general RM_Size is
6037       --  subtype specific and does not get inherited by all subtypes.
6038
6039       Set_Esize                     (T1, Esize                     (T2));
6040       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
6041
6042       if Is_Discrete_Or_Fixed_Point_Type (T1)
6043            and then
6044          Is_Discrete_Or_Fixed_Point_Type (T2)
6045       then
6046          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
6047       end if;
6048       Set_Alignment                 (T1, Alignment                 (T2));
6049    end Set_Size_Info;
6050
6051    --------------------
6052    -- Static_Integer --
6053    --------------------
6054
6055    function Static_Integer (N : Node_Id) return Uint is
6056    begin
6057       Analyze_And_Resolve (N, Any_Integer);
6058
6059       if N = Error
6060         or else Error_Posted (N)
6061         or else Etype (N) = Any_Type
6062       then
6063          return No_Uint;
6064       end if;
6065
6066       if Is_Static_Expression (N) then
6067          if not Raises_Constraint_Error (N) then
6068             return Expr_Value (N);
6069          else
6070             return No_Uint;
6071          end if;
6072
6073       elsif Etype (N) = Any_Type then
6074          return No_Uint;
6075
6076       else
6077          Flag_Non_Static_Expr
6078            ("static integer expression required here", N);
6079          return No_Uint;
6080       end if;
6081    end Static_Integer;
6082
6083    --------------------------
6084    -- Statically_Different --
6085    --------------------------
6086
6087    function Statically_Different (E1, E2 : Node_Id) return Boolean is
6088       R1 : constant Node_Id := Get_Referenced_Object (E1);
6089       R2 : constant Node_Id := Get_Referenced_Object (E2);
6090
6091    begin
6092       return     Is_Entity_Name (R1)
6093         and then Is_Entity_Name (R2)
6094         and then Entity (R1) /= Entity (R2)
6095         and then not Is_Formal (Entity (R1))
6096         and then not Is_Formal (Entity (R2));
6097    end Statically_Different;
6098
6099    -----------------------------
6100    -- Subprogram_Access_Level --
6101    -----------------------------
6102
6103    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
6104    begin
6105       if Present (Alias (Subp)) then
6106          return Subprogram_Access_Level (Alias (Subp));
6107       else
6108          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
6109       end if;
6110    end Subprogram_Access_Level;
6111
6112    -----------------
6113    -- Trace_Scope --
6114    -----------------
6115
6116    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
6117    begin
6118       if Debug_Flag_W then
6119          for J in 0 .. Scope_Stack.Last loop
6120             Write_Str ("  ");
6121          end loop;
6122
6123          Write_Str (Msg);
6124          Write_Name (Chars (E));
6125          Write_Str ("   line ");
6126          Write_Int (Int (Get_Logical_Line_Number (Sloc (N))));
6127          Write_Eol;
6128       end if;
6129    end Trace_Scope;
6130
6131    -----------------------
6132    -- Transfer_Entities --
6133    -----------------------
6134
6135    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
6136       Ent      : Entity_Id := First_Entity (From);
6137
6138    begin
6139       if No (Ent) then
6140          return;
6141       end if;
6142
6143       if (Last_Entity (To)) = Empty then
6144          Set_First_Entity (To, Ent);
6145       else
6146          Set_Next_Entity (Last_Entity (To), Ent);
6147       end if;
6148
6149       Set_Last_Entity (To, Last_Entity (From));
6150
6151       while Present (Ent) loop
6152          Set_Scope (Ent, To);
6153
6154          if not Is_Public (Ent) then
6155             Set_Public_Status (Ent);
6156
6157             if Is_Public (Ent)
6158               and then Ekind (Ent) = E_Record_Subtype
6159
6160             then
6161                --  The components of the propagated Itype must be public
6162                --  as well.
6163
6164                declare
6165                   Comp : Entity_Id;
6166
6167                begin
6168                   Comp := First_Entity (Ent);
6169
6170                   while Present (Comp) loop
6171                      Set_Is_Public (Comp);
6172                      Next_Entity (Comp);
6173                   end loop;
6174                end;
6175             end if;
6176          end if;
6177
6178          Next_Entity (Ent);
6179       end loop;
6180
6181       Set_First_Entity (From, Empty);
6182       Set_Last_Entity (From, Empty);
6183    end Transfer_Entities;
6184
6185    -----------------------
6186    -- Type_Access_Level --
6187    -----------------------
6188
6189    function Type_Access_Level (Typ : Entity_Id) return Uint is
6190       Btyp : Entity_Id;
6191
6192    begin
6193       --  If the type is an anonymous access type we treat it as being
6194       --  declared at the library level to ensure that names such as
6195       --  X.all'access don't fail static accessibility checks.
6196
6197       --  Ada 0Y (AI-230): In case of anonymous access types that are
6198       --  component_definition or discriminants of a nonlimited type,
6199       --  the level is the same as that of the enclosing component type.
6200
6201       Btyp := Base_Type (Typ);
6202       if Ekind (Btyp) in Access_Kind then
6203          if Ekind (Btyp) = E_Anonymous_Access_Type
6204            and then not Is_Array_Type (Scope (Btyp))      --  Ada 0Y (AI-230)
6205            and then Ekind (Scope (Btyp)) /= E_Record_Type --  Ada 0Y (AI-230)
6206          then
6207             return Scope_Depth (Standard_Standard);
6208          end if;
6209
6210          Btyp := Root_Type (Btyp);
6211       end if;
6212
6213       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
6214    end Type_Access_Level;
6215
6216    --------------------------
6217    -- Unit_Declaration_Node --
6218    --------------------------
6219
6220    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
6221       N : Node_Id := Parent (Unit_Id);
6222
6223    begin
6224       --  Predefined operators do not have a full function declaration.
6225
6226       if Ekind (Unit_Id) = E_Operator then
6227          return N;
6228       end if;
6229
6230       while Nkind (N) /= N_Abstract_Subprogram_Declaration
6231         and then Nkind (N) /= N_Formal_Package_Declaration
6232         and then Nkind (N) /= N_Formal_Subprogram_Declaration
6233         and then Nkind (N) /= N_Function_Instantiation
6234         and then Nkind (N) /= N_Generic_Package_Declaration
6235         and then Nkind (N) /= N_Generic_Subprogram_Declaration
6236         and then Nkind (N) /= N_Package_Declaration
6237         and then Nkind (N) /= N_Package_Body
6238         and then Nkind (N) /= N_Package_Instantiation
6239         and then Nkind (N) /= N_Package_Renaming_Declaration
6240         and then Nkind (N) /= N_Procedure_Instantiation
6241         and then Nkind (N) /= N_Protected_Body
6242         and then Nkind (N) /= N_Subprogram_Declaration
6243         and then Nkind (N) /= N_Subprogram_Body
6244         and then Nkind (N) /= N_Subprogram_Body_Stub
6245         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
6246         and then Nkind (N) /= N_Task_Body
6247         and then Nkind (N) /= N_Task_Type_Declaration
6248         and then Nkind (N) not in N_Generic_Renaming_Declaration
6249       loop
6250          N := Parent (N);
6251          pragma Assert (Present (N));
6252       end loop;
6253
6254       return N;
6255    end Unit_Declaration_Node;
6256
6257    ------------------------------
6258    -- Universal_Interpretation --
6259    ------------------------------
6260
6261    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
6262       Index : Interp_Index;
6263       It    : Interp;
6264
6265    begin
6266       --  The argument may be a formal parameter of an operator or subprogram
6267       --  with multiple interpretations, or else an expression for an actual.
6268
6269       if Nkind (Opnd) = N_Defining_Identifier
6270         or else not Is_Overloaded (Opnd)
6271       then
6272          if Etype (Opnd) = Universal_Integer
6273            or else Etype (Opnd) = Universal_Real
6274          then
6275             return Etype (Opnd);
6276          else
6277             return Empty;
6278          end if;
6279
6280       else
6281          Get_First_Interp (Opnd, Index, It);
6282
6283          while Present (It.Typ) loop
6284
6285             if It.Typ = Universal_Integer
6286               or else It.Typ = Universal_Real
6287             then
6288                return It.Typ;
6289             end if;
6290
6291             Get_Next_Interp (Index, It);
6292          end loop;
6293
6294          return Empty;
6295       end if;
6296    end Universal_Interpretation;
6297
6298    ----------------------
6299    -- Within_Init_Proc --
6300    ----------------------
6301
6302    function Within_Init_Proc return Boolean is
6303       S : Entity_Id;
6304
6305    begin
6306       S := Current_Scope;
6307       while not Is_Overloadable (S) loop
6308          if S = Standard_Standard then
6309             return False;
6310          else
6311             S := Scope (S);
6312          end if;
6313       end loop;
6314
6315       return Is_Init_Proc (S);
6316    end Within_Init_Proc;
6317
6318    ----------------
6319    -- Wrong_Type --
6320    ----------------
6321
6322    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
6323       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
6324       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
6325
6326       function Has_One_Matching_Field return Boolean;
6327       --  Determines whether Expec_Type is a record type with a single
6328       --  component or discriminant whose type matches the found type or
6329       --  is a one dimensional array whose component type matches the
6330       --  found type.
6331
6332       function Has_One_Matching_Field return Boolean is
6333          E : Entity_Id;
6334
6335       begin
6336          if Is_Array_Type (Expec_Type)
6337            and then Number_Dimensions (Expec_Type) = 1
6338            and then
6339              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
6340          then
6341             return True;
6342
6343          elsif not Is_Record_Type (Expec_Type) then
6344             return False;
6345
6346          else
6347             E := First_Entity (Expec_Type);
6348
6349             loop
6350                if No (E) then
6351                   return False;
6352
6353                elsif (Ekind (E) /= E_Discriminant
6354                        and then Ekind (E) /= E_Component)
6355                  or else (Chars (E) = Name_uTag
6356                            or else Chars (E) = Name_uParent)
6357                then
6358                   Next_Entity (E);
6359
6360                else
6361                   exit;
6362                end if;
6363             end loop;
6364
6365             if not Covers (Etype (E), Found_Type) then
6366                return False;
6367
6368             elsif Present (Next_Entity (E)) then
6369                return False;
6370
6371             else
6372                return True;
6373             end if;
6374          end if;
6375       end Has_One_Matching_Field;
6376
6377    --  Start of processing for Wrong_Type
6378
6379    begin
6380       --  Don't output message if either type is Any_Type, or if a message
6381       --  has already been posted for this node. We need to do the latter
6382       --  check explicitly (it is ordinarily done in Errout), because we
6383       --  are using ! to force the output of the error messages.
6384
6385       if Expec_Type = Any_Type
6386         or else Found_Type = Any_Type
6387         or else Error_Posted (Expr)
6388       then
6389          return;
6390
6391       --  In  an instance, there is an ongoing problem with completion of
6392       --  type derived from private types. Their structure is what Gigi
6393       --  expects, but the  Etype is the parent type rather than the
6394       --  derived private type itself. Do not flag error in this case. The
6395       --  private completion is an entity without a parent, like an Itype.
6396       --  Similarly, full and partial views may be incorrect in the instance.
6397       --  There is no simple way to insure that it is consistent ???
6398
6399       elsif In_Instance then
6400
6401          if Etype (Etype (Expr)) = Etype (Expected_Type)
6402            and then
6403              (Has_Private_Declaration (Expected_Type)
6404                or else Has_Private_Declaration (Etype (Expr)))
6405            and then No (Parent (Expected_Type))
6406          then
6407             return;
6408          end if;
6409       end if;
6410
6411       --  An interesting special check. If the expression is parenthesized
6412       --  and its type corresponds to the type of the sole component of the
6413       --  expected record type, or to the component type of the expected one
6414       --  dimensional array type, then assume we have a bad aggregate attempt.
6415
6416       if Nkind (Expr) in N_Subexpr
6417         and then Paren_Count (Expr) /= 0
6418         and then Has_One_Matching_Field
6419       then
6420          Error_Msg_N ("positional aggregate cannot have one component", Expr);
6421
6422       --  Another special check, if we are looking for a pool-specific access
6423       --  type and we found an E_Access_Attribute_Type, then we have the case
6424       --  of an Access attribute being used in a context which needs a pool-
6425       --  specific type, which is never allowed. The one extra check we make
6426       --  is that the expected designated type covers the Found_Type.
6427
6428       elsif Is_Access_Type (Expec_Type)
6429         and then Ekind (Found_Type) = E_Access_Attribute_Type
6430         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
6431         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
6432         and then Covers
6433           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
6434       then
6435          Error_Msg_N ("result must be general access type!", Expr);
6436          Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
6437
6438       --  If the expected type is an anonymous access type, as for access
6439       --  parameters and discriminants, the error is on the designated types.
6440
6441       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
6442          if Comes_From_Source (Expec_Type) then
6443             Error_Msg_NE ("expected}!", Expr, Expec_Type);
6444          else
6445             Error_Msg_NE
6446               ("expected an access type with designated}",
6447                  Expr, Designated_Type (Expec_Type));
6448          end if;
6449
6450          if Is_Access_Type (Found_Type)
6451            and then not Comes_From_Source (Found_Type)
6452          then
6453             Error_Msg_NE
6454               ("found an access type with designated}!",
6455                 Expr, Designated_Type (Found_Type));
6456          else
6457             if From_With_Type (Found_Type) then
6458                Error_Msg_NE ("found incomplete}!", Expr, Found_Type);
6459                Error_Msg_NE
6460                  ("\possibly missing with_clause on&", Expr,
6461                    Scope (Found_Type));
6462             else
6463                Error_Msg_NE ("found}!", Expr, Found_Type);
6464             end if;
6465          end if;
6466
6467       --  Normal case of one type found, some other type expected
6468
6469       else
6470          --  If the names of the two types are the same, see if some
6471          --  number of levels of qualification will help. Don't try
6472          --  more than three levels, and if we get to standard, it's
6473          --  no use (and probably represents an error in the compiler)
6474          --  Also do not bother with internal scope names.
6475
6476          declare
6477             Expec_Scope : Entity_Id;
6478             Found_Scope : Entity_Id;
6479
6480          begin
6481             Expec_Scope := Expec_Type;
6482             Found_Scope := Found_Type;
6483
6484             for Levels in Int range 0 .. 3 loop
6485                if Chars (Expec_Scope) /= Chars (Found_Scope) then
6486                   Error_Msg_Qual_Level := Levels;
6487                   exit;
6488                end if;
6489
6490                Expec_Scope := Scope (Expec_Scope);
6491                Found_Scope := Scope (Found_Scope);
6492
6493                exit when Expec_Scope = Standard_Standard
6494                            or else
6495                          Found_Scope = Standard_Standard
6496                            or else
6497                          not Comes_From_Source (Expec_Scope)
6498                            or else
6499                          not Comes_From_Source (Found_Scope);
6500             end loop;
6501          end;
6502
6503          Error_Msg_NE ("expected}!", Expr, Expec_Type);
6504
6505          if Is_Entity_Name (Expr)
6506            and then Is_Package (Entity (Expr))
6507          then
6508             Error_Msg_N ("found package name!", Expr);
6509
6510          elsif Is_Entity_Name (Expr)
6511            and then
6512              (Ekind (Entity (Expr)) = E_Procedure
6513                 or else
6514               Ekind (Entity (Expr)) = E_Generic_Procedure)
6515          then
6516             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
6517                Error_Msg_N
6518                  ("found procedure name, possibly missing Access attribute!",
6519                    Expr);
6520             else
6521                Error_Msg_N ("found procedure name instead of function!", Expr);
6522             end if;
6523
6524          elsif Nkind (Expr) = N_Function_Call
6525            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
6526            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
6527            and then No (Parameter_Associations (Expr))
6528          then
6529                Error_Msg_N
6530                  ("found function name, possibly missing Access attribute!",
6531                    Expr);
6532
6533          --  catch common error: a prefix or infix operator which is not
6534          --  directly visible because the type isn't.
6535
6536          elsif Nkind (Expr) in N_Op
6537             and then Is_Overloaded (Expr)
6538             and then not Is_Immediately_Visible (Expec_Type)
6539             and then not Is_Potentially_Use_Visible (Expec_Type)
6540             and then not In_Use (Expec_Type)
6541             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
6542          then
6543             Error_Msg_N (
6544               "operator of the type is not directly visible!", Expr);
6545
6546          elsif Ekind (Found_Type) = E_Void
6547            and then Present (Parent (Found_Type))
6548            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
6549          then
6550             Error_Msg_NE ("found premature usage of}!", Expr, Found_Type);
6551
6552          else
6553             Error_Msg_NE ("found}!", Expr, Found_Type);
6554          end if;
6555
6556          Error_Msg_Qual_Level := 0;
6557       end if;
6558    end Wrong_Type;
6559
6560 end Sem_Util;