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