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