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