gcc/ada/sem_util.adb

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