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