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