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