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