gcc/ada/sem_util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ U T I L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Casing;   use Casing;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Errout;   use Errout;
  31 with Elists;   use Elists;
  32 with Exp_Tss;  use Exp_Tss;
  33 with Exp_Util; use Exp_Util;
  34 with Fname;    use Fname;
  35 with Freeze;   use Freeze;
  36 with Lib;      use Lib;
  37 with Lib.Xref; use Lib.Xref;
  38 with Nlists;   use Nlists;
  39 with Output;   use Output;
  40 with Opt;      use Opt;
  41 with Rtsfind;  use Rtsfind;
  42 with Scans;    use Scans;
  43 with Scn;      use Scn;
  44 with Sem;      use Sem;
  45 with Sem_Attr; use Sem_Attr;
  46 with Sem_Ch6;  use Sem_Ch6;
  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 Stand;    use Stand;
  54 with Style;
  55 with Stringt;  use Stringt;
  56 with Targparm; use Targparm;
  57 with Tbuild;   use Tbuild;
  58 with Ttypes;   use Ttypes;
  59 with Uname;    use Uname;
  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) return Node_Id;
  71    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
  72    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
  73    --  Loc is the source location, T is the original subtype.
  74
  75    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
  76    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
  77    --  with discriminants whose default values are static, examine only the
  78    --  components in the selected variant to determine whether all of them
  79    --  have a default.
  80
  81    function Has_Null_Extension (T : Entity_Id) return Boolean;
  82    --  T is a derived tagged type. Check whether the type extension is null.
  83    --  If the parent type is fully initialized, T can be treated as such.
  84
  85    ------------------------------
  86    --  Abstract_Interface_List --
  87    ------------------------------
  88
  89    function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
  90       Nod : Node_Id;
  91
  92    begin
  93       if Is_Concurrent_Type (Typ) then
  94
  95          --  If we are dealing with a synchronized subtype, go to the base
  96          --  type, whose declaration has the interface list.
  97
  98          --  Shouldn't this be Declaration_Node???
  99
 100          Nod := Parent (Base_Type (Typ));
 101
 102       elsif Ekind (Typ) = E_Record_Type_With_Private then
 103          if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
 104             Nod := Type_Definition (Parent (Typ));
 105
 106          elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
 107             if Present (Full_View (Typ)) then
 108                Nod := Type_Definition (Parent (Full_View (Typ)));
 109
 110             --  If the full-view is not available we cannot do anything else
 111             --  here (the source has errors).
 112
 113             else
 114                return Empty_List;
 115             end if;
 116
 117          --  Support for generic formals with interfaces is still missing ???
 118
 119          elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 120             return Empty_List;
 121
 122          else
 123             pragma Assert
 124               (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
 125             Nod := Parent (Typ);
 126          end if;
 127
 128       elsif Ekind (Typ) = E_Record_Subtype then
 129          Nod := Type_Definition (Parent (Etype (Typ)));
 130
 131       elsif Ekind (Typ) = E_Record_Subtype_With_Private then
 132
 133          --  Recurse, because parent may still be a private extension. Also
 134          --  note that the full view of the subtype or the full view of its
 135          --  base type may (both) be unavailable.
 136
 137          return Abstract_Interface_List (Etype (Typ));
 138
 139       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
 140          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 141             Nod := Formal_Type_Definition (Parent (Typ));
 142          else
 143             Nod := Type_Definition (Parent (Typ));
 144          end if;
 145       end if;
 146
 147       return Interface_List (Nod);
 148    end Abstract_Interface_List;
 149
 150    --------------------------------
 151    -- Add_Access_Type_To_Process --
 152    --------------------------------
 153
 154    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
 155       L : Elist_Id;
 156
 157    begin
 158       Ensure_Freeze_Node (E);
 159       L := Access_Types_To_Process (Freeze_Node (E));
 160
 161       if No (L) then
 162          L := New_Elmt_List;
 163          Set_Access_Types_To_Process (Freeze_Node (E), L);
 164       end if;
 165
 166       Append_Elmt (A, L);
 167    end Add_Access_Type_To_Process;
 168
 169    ----------------------------
 170    -- Add_Global_Declaration --
 171    ----------------------------
 172
 173    procedure Add_Global_Declaration (N : Node_Id) is
 174       Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
 175
 176    begin
 177       if No (Declarations (Aux_Node)) then
 178          Set_Declarations (Aux_Node, New_List);
 179       end if;
 180
 181       Append_To (Declarations (Aux_Node), N);
 182       Analyze (N);
 183    end Add_Global_Declaration;
 184
 185    -----------------------
 186    -- Alignment_In_Bits --
 187    -----------------------
 188
 189    function Alignment_In_Bits (E : Entity_Id) return Uint is
 190    begin
 191       return Alignment (E) * System_Storage_Unit;
 192    end Alignment_In_Bits;
 193
 194    -----------------------------------------
 195    -- Apply_Compile_Time_Constraint_Error --
 196    -----------------------------------------
 197
 198    procedure Apply_Compile_Time_Constraint_Error
 199      (N      : Node_Id;
 200       Msg    : String;
 201       Reason : RT_Exception_Code;
 202       Ent    : Entity_Id  := Empty;
 203       Typ    : Entity_Id  := Empty;
 204       Loc    : Source_Ptr := No_Location;
 205       Rep    : Boolean    := True;
 206       Warn   : Boolean    := False)
 207    is
 208       Stat : constant Boolean := Is_Static_Expression (N);
 209       Rtyp : Entity_Id;
 210
 211    begin
 212       if No (Typ) then
 213          Rtyp := Etype (N);
 214       else
 215          Rtyp := Typ;
 216       end if;
 217
 218       Discard_Node
 219         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 220
 221       if not Rep then
 222          return;
 223       end if;
 224
 225       --  Now we replace the node by an N_Raise_Constraint_Error node
 226       --  This does not need reanalyzing, so set it as analyzed now.
 227
 228       Rewrite (N,
 229         Make_Raise_Constraint_Error (Sloc (N),
 230           Reason => Reason));
 231       Set_Analyzed (N, True);
 232       Set_Etype (N, Rtyp);
 233       Set_Raises_Constraint_Error (N);
 234
 235       --  If the original expression was marked as static, the result is
 236       --  still marked as static, but the Raises_Constraint_Error flag is
 237       --  always set so that further static evaluation is not attempted.
 238
 239       if Stat then
 240          Set_Is_Static_Expression (N);
 241       end if;
 242    end Apply_Compile_Time_Constraint_Error;
 243
 244    --------------------------
 245    -- Build_Actual_Subtype --
 246    --------------------------
 247
 248    function Build_Actual_Subtype
 249      (T : Entity_Id;
 250       N : Node_Or_Entity_Id) return Node_Id
 251    is
 252       Loc : Source_Ptr;
 253       --  Normally Sloc (N), but may point to corresponding body in some cases
 254
 255       Constraints : List_Id;
 256       Decl        : Node_Id;
 257       Discr       : Entity_Id;
 258       Hi          : Node_Id;
 259       Lo          : Node_Id;
 260       Subt        : Entity_Id;
 261       Disc_Type   : Entity_Id;
 262       Obj         : Node_Id;
 263
 264    begin
 265       Loc := Sloc (N);
 266
 267       if Nkind (N) = N_Defining_Identifier then
 268          Obj := New_Reference_To (N, Loc);
 269
 270          --  If this is a formal parameter of a subprogram declaration, and
 271          --  we are compiling the body, we want the declaration for the
 272          --  actual subtype to carry the source position of the body, to
 273          --  prevent anomalies in gdb when stepping through the code.
 274
 275          if Is_Formal (N) then
 276             declare
 277                Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
 278             begin
 279                if Nkind (Decl) = N_Subprogram_Declaration
 280                  and then Present (Corresponding_Body (Decl))
 281                then
 282                   Loc := Sloc (Corresponding_Body (Decl));
 283                end if;
 284             end;
 285          end if;
 286
 287       else
 288          Obj := N;
 289       end if;
 290
 291       if Is_Array_Type (T) then
 292          Constraints := New_List;
 293          for J in 1 .. Number_Dimensions (T) loop
 294
 295             --  Build an array subtype declaration with the nominal subtype and
 296             --  the bounds of the actual. Add the declaration in front of the
 297             --  local declarations for the subprogram, for analysis before any
 298             --  reference to the formal in the body.
 299
 300             Lo :=
 301               Make_Attribute_Reference (Loc,
 302                 Prefix         =>
 303                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 304                 Attribute_Name => Name_First,
 305                 Expressions    => New_List (
 306                   Make_Integer_Literal (Loc, J)));
 307
 308             Hi :=
 309               Make_Attribute_Reference (Loc,
 310                 Prefix         =>
 311                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 312                 Attribute_Name => Name_Last,
 313                 Expressions    => New_List (
 314                   Make_Integer_Literal (Loc, J)));
 315
 316             Append (Make_Range (Loc, Lo, Hi), Constraints);
 317          end loop;
 318
 319       --  If the type has unknown discriminants there is no constrained
 320       --  subtype to build. This is never called for a formal or for a
 321       --  lhs, so returning the type is ok ???
 322
 323       elsif Has_Unknown_Discriminants (T) then
 324          return T;
 325
 326       else
 327          Constraints := New_List;
 328
 329          --  Type T is a generic derived type, inherit the discriminants from
 330          --  the parent type.
 331
 332          if Is_Private_Type (T)
 333            and then No (Full_View (T))
 334
 335             --  T was flagged as an error if it was declared as a formal
 336             --  derived type with known discriminants. In this case there
 337             --  is no need to look at the parent type since T already carries
 338             --  its own discriminants.
 339
 340            and then not Error_Posted (T)
 341          then
 342             Disc_Type := Etype (Base_Type (T));
 343          else
 344             Disc_Type := T;
 345          end if;
 346
 347          Discr := First_Discriminant (Disc_Type);
 348          while Present (Discr) loop
 349             Append_To (Constraints,
 350               Make_Selected_Component (Loc,
 351                 Prefix =>
 352                   Duplicate_Subexpr_No_Checks (Obj),
 353                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 354             Next_Discriminant (Discr);
 355          end loop;
 356       end if;
 357
 358       Subt :=
 359         Make_Defining_Identifier (Loc,
 360           Chars => New_Internal_Name ('S'));
 361       Set_Is_Internal (Subt);
 362
 363       Decl :=
 364         Make_Subtype_Declaration (Loc,
 365           Defining_Identifier => Subt,
 366           Subtype_Indication =>
 367             Make_Subtype_Indication (Loc,
 368               Subtype_Mark => New_Reference_To (T,  Loc),
 369               Constraint  =>
 370                 Make_Index_Or_Discriminant_Constraint (Loc,
 371                   Constraints => Constraints)));
 372
 373       Mark_Rewrite_Insertion (Decl);
 374       return Decl;
 375    end Build_Actual_Subtype;
 376
 377    ---------------------------------------
 378    -- Build_Actual_Subtype_Of_Component --
 379    ---------------------------------------
 380
 381    function Build_Actual_Subtype_Of_Component
 382      (T : Entity_Id;
 383       N : Node_Id) return Node_Id
 384    is
 385       Loc       : constant Source_Ptr := Sloc (N);
 386       P         : constant Node_Id    := Prefix (N);
 387       D         : Elmt_Id;
 388       Id        : Node_Id;
 389       Indx_Type : Entity_Id;
 390
 391       Deaccessed_T : Entity_Id;
 392       --  This is either a copy of T, or if T is an access type, then it is
 393       --  the directly designated type of this access type.
 394
 395       function Build_Actual_Array_Constraint return List_Id;
 396       --  If one or more of the bounds of the component depends on
 397       --  discriminants, build  actual constraint using the discriminants
 398       --  of the prefix.
 399
 400       function Build_Actual_Record_Constraint return List_Id;
 401       --  Similar to previous one, for discriminated components constrained
 402       --  by the discriminant of the enclosing object.
 403
 404       -----------------------------------
 405       -- Build_Actual_Array_Constraint --
 406       -----------------------------------
 407
 408       function Build_Actual_Array_Constraint return List_Id is
 409          Constraints : constant List_Id := New_List;
 410          Indx        : Node_Id;
 411          Hi          : Node_Id;
 412          Lo          : Node_Id;
 413          Old_Hi      : Node_Id;
 414          Old_Lo      : Node_Id;
 415
 416       begin
 417          Indx := First_Index (Deaccessed_T);
 418          while Present (Indx) loop
 419             Old_Lo := Type_Low_Bound  (Etype (Indx));
 420             Old_Hi := Type_High_Bound (Etype (Indx));
 421
 422             if Denotes_Discriminant (Old_Lo) then
 423                Lo :=
 424                  Make_Selected_Component (Loc,
 425                    Prefix => New_Copy_Tree (P),
 426                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 427
 428             else
 429                Lo := New_Copy_Tree (Old_Lo);
 430
 431                --  The new bound will be reanalyzed in the enclosing
 432                --  declaration. For literal bounds that come from a type
 433                --  declaration, the type of the context must be imposed, so
 434                --  insure that analysis will take place. For non-universal
 435                --  types this is not strictly necessary.
 436
 437                Set_Analyzed (Lo, False);
 438             end if;
 439
 440             if Denotes_Discriminant (Old_Hi) then
 441                Hi :=
 442                  Make_Selected_Component (Loc,
 443                    Prefix => New_Copy_Tree (P),
 444                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 445
 446             else
 447                Hi := New_Copy_Tree (Old_Hi);
 448                Set_Analyzed (Hi, False);
 449             end if;
 450
 451             Append (Make_Range (Loc, Lo, Hi), Constraints);
 452             Next_Index (Indx);
 453          end loop;
 454
 455          return Constraints;
 456       end Build_Actual_Array_Constraint;
 457
 458       ------------------------------------
 459       -- Build_Actual_Record_Constraint --
 460       ------------------------------------
 461
 462       function Build_Actual_Record_Constraint return List_Id is
 463          Constraints : constant List_Id := New_List;
 464          D           : Elmt_Id;
 465          D_Val       : Node_Id;
 466
 467       begin
 468          D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
 469          while Present (D) loop
 470             if Denotes_Discriminant (Node (D)) then
 471                D_Val :=  Make_Selected_Component (Loc,
 472                  Prefix => New_Copy_Tree (P),
 473                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 474
 475             else
 476                D_Val := New_Copy_Tree (Node (D));
 477             end if;
 478
 479             Append (D_Val, Constraints);
 480             Next_Elmt (D);
 481          end loop;
 482
 483          return Constraints;
 484       end Build_Actual_Record_Constraint;
 485
 486    --  Start of processing for Build_Actual_Subtype_Of_Component
 487
 488    begin
 489       if In_Default_Expression then
 490          return Empty;
 491
 492       elsif Nkind (N) = N_Explicit_Dereference then
 493          if Is_Composite_Type (T)
 494            and then not Is_Constrained (T)
 495            and then not (Is_Class_Wide_Type (T)
 496                           and then Is_Constrained (Root_Type (T)))
 497            and then not Has_Unknown_Discriminants (T)
 498          then
 499             --  If the type of the dereference is already constrained, it
 500             --  is an actual subtype.
 501
 502             if Is_Array_Type (Etype (N))
 503               and then Is_Constrained (Etype (N))
 504             then
 505                return Empty;
 506             else
 507                Remove_Side_Effects (P);
 508                return Build_Actual_Subtype (T, N);
 509             end if;
 510          else
 511             return Empty;
 512          end if;
 513       end if;
 514
 515       if Ekind (T) = E_Access_Subtype then
 516          Deaccessed_T := Designated_Type (T);
 517       else
 518          Deaccessed_T := T;
 519       end if;
 520
 521       if Ekind (Deaccessed_T) = E_Array_Subtype then
 522          Id := First_Index (Deaccessed_T);
 523          while Present (Id) loop
 524             Indx_Type := Underlying_Type (Etype (Id));
 525
 526             if Denotes_Discriminant (Type_Low_Bound  (Indx_Type))
 527                  or else
 528                Denotes_Discriminant (Type_High_Bound (Indx_Type))
 529             then
 530                Remove_Side_Effects (P);
 531                return
 532                  Build_Component_Subtype
 533                    (Build_Actual_Array_Constraint, Loc, Base_Type (T));
 534             end if;
 535
 536             Next_Index (Id);
 537          end loop;
 538
 539       elsif Is_Composite_Type (Deaccessed_T)
 540         and then Has_Discriminants (Deaccessed_T)
 541         and then not Has_Unknown_Discriminants (Deaccessed_T)
 542       then
 543          D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
 544          while Present (D) loop
 545             if Denotes_Discriminant (Node (D)) then
 546                Remove_Side_Effects (P);
 547                return
 548                  Build_Component_Subtype (
 549                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
 550             end if;
 551
 552             Next_Elmt (D);
 553          end loop;
 554       end if;
 555
 556       --  If none of the above, the actual and nominal subtypes are the same
 557
 558       return Empty;
 559    end Build_Actual_Subtype_Of_Component;
 560
 561    -----------------------------
 562    -- Build_Component_Subtype --
 563    -----------------------------
 564
 565    function Build_Component_Subtype
 566      (C   : List_Id;
 567       Loc : Source_Ptr;
 568       T   : Entity_Id) return Node_Id
 569    is
 570       Subt : Entity_Id;
 571       Decl : Node_Id;
 572
 573    begin
 574       --  Unchecked_Union components do not require component subtypes
 575
 576       if Is_Unchecked_Union (T) then
 577          return Empty;
 578       end if;
 579
 580       Subt :=
 581         Make_Defining_Identifier (Loc,
 582           Chars => New_Internal_Name ('S'));
 583       Set_Is_Internal (Subt);
 584
 585       Decl :=
 586         Make_Subtype_Declaration (Loc,
 587           Defining_Identifier => Subt,
 588           Subtype_Indication =>
 589             Make_Subtype_Indication (Loc,
 590               Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
 591               Constraint  =>
 592                 Make_Index_Or_Discriminant_Constraint (Loc,
 593                   Constraints => C)));
 594
 595       Mark_Rewrite_Insertion (Decl);
 596       return Decl;
 597    end Build_Component_Subtype;
 598
 599    ---------------------------
 600    -- Build_Default_Subtype --
 601    ---------------------------
 602
 603    function Build_Default_Subtype
 604      (T : Entity_Id;
 605       N : Node_Id) return Entity_Id
 606    is
 607       Loc  : constant Source_Ptr := Sloc (N);
 608       Disc : Entity_Id;
 609
 610    begin
 611       if not Has_Discriminants (T) or else Is_Constrained (T) then
 612          return T;
 613       end if;
 614
 615       Disc := First_Discriminant (T);
 616
 617       if No (Discriminant_Default_Value (Disc)) then
 618          return T;
 619       end if;
 620
 621       declare
 622          Act : constant Entity_Id :=
 623                  Make_Defining_Identifier (Loc,
 624                    Chars => New_Internal_Name ('S'));
 625
 626          Constraints : constant List_Id := New_List;
 627          Decl        : Node_Id;
 628
 629       begin
 630          while Present (Disc) loop
 631             Append_To (Constraints,
 632               New_Copy_Tree (Discriminant_Default_Value (Disc)));
 633             Next_Discriminant (Disc);
 634          end loop;
 635
 636          Decl :=
 637            Make_Subtype_Declaration (Loc,
 638              Defining_Identifier => Act,
 639              Subtype_Indication =>
 640                Make_Subtype_Indication (Loc,
 641                  Subtype_Mark => New_Occurrence_Of (T, Loc),
 642                  Constraint =>
 643                    Make_Index_Or_Discriminant_Constraint (Loc,
 644                      Constraints => Constraints)));
 645
 646          Insert_Action (N, Decl);
 647          Analyze (Decl);
 648          return Act;
 649       end;
 650    end Build_Default_Subtype;
 651
 652    --------------------------------------------
 653    -- Build_Discriminal_Subtype_Of_Component --
 654    --------------------------------------------
 655
 656    function Build_Discriminal_Subtype_Of_Component
 657      (T : Entity_Id) return Node_Id
 658    is
 659       Loc : constant Source_Ptr := Sloc (T);
 660       D   : Elmt_Id;
 661       Id  : Node_Id;
 662
 663       function Build_Discriminal_Array_Constraint return List_Id;
 664       --  If one or more of the bounds of the component depends on
 665       --  discriminants, build  actual constraint using the discriminants
 666       --  of the prefix.
 667
 668       function Build_Discriminal_Record_Constraint return List_Id;
 669       --  Similar to previous one, for discriminated components constrained
 670       --  by the discriminant of the enclosing object.
 671
 672       ----------------------------------------
 673       -- Build_Discriminal_Array_Constraint --
 674       ----------------------------------------
 675
 676       function Build_Discriminal_Array_Constraint return List_Id is
 677          Constraints : constant List_Id := New_List;
 678          Indx        : Node_Id;
 679          Hi          : Node_Id;
 680          Lo          : Node_Id;
 681          Old_Hi      : Node_Id;
 682          Old_Lo      : Node_Id;
 683
 684       begin
 685          Indx := First_Index (T);
 686          while Present (Indx) loop
 687             Old_Lo := Type_Low_Bound  (Etype (Indx));
 688             Old_Hi := Type_High_Bound (Etype (Indx));
 689
 690             if Denotes_Discriminant (Old_Lo) then
 691                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
 692
 693             else
 694                Lo := New_Copy_Tree (Old_Lo);
 695             end if;
 696
 697             if Denotes_Discriminant (Old_Hi) then
 698                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
 699
 700             else
 701                Hi := New_Copy_Tree (Old_Hi);
 702             end if;
 703
 704             Append (Make_Range (Loc, Lo, Hi), Constraints);
 705             Next_Index (Indx);
 706          end loop;
 707
 708          return Constraints;
 709       end Build_Discriminal_Array_Constraint;
 710
 711       -----------------------------------------
 712       -- Build_Discriminal_Record_Constraint --
 713       -----------------------------------------
 714
 715       function Build_Discriminal_Record_Constraint return List_Id is
 716          Constraints : constant List_Id := New_List;
 717          D           : Elmt_Id;
 718          D_Val       : Node_Id;
 719
 720       begin
 721          D := First_Elmt (Discriminant_Constraint (T));
 722          while Present (D) loop
 723             if Denotes_Discriminant (Node (D)) then
 724                D_Val :=
 725                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
 726
 727             else
 728                D_Val := New_Copy_Tree (Node (D));
 729             end if;
 730
 731             Append (D_Val, Constraints);
 732             Next_Elmt (D);
 733          end loop;
 734
 735          return Constraints;
 736       end Build_Discriminal_Record_Constraint;
 737
 738    --  Start of processing for Build_Discriminal_Subtype_Of_Component
 739
 740    begin
 741       if Ekind (T) = E_Array_Subtype then
 742          Id := First_Index (T);
 743          while Present (Id) loop
 744             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
 745                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
 746             then
 747                return Build_Component_Subtype
 748                  (Build_Discriminal_Array_Constraint, Loc, T);
 749             end if;
 750
 751             Next_Index (Id);
 752          end loop;
 753
 754       elsif Ekind (T) = E_Record_Subtype
 755         and then Has_Discriminants (T)
 756         and then not Has_Unknown_Discriminants (T)
 757       then
 758          D := First_Elmt (Discriminant_Constraint (T));
 759          while Present (D) loop
 760             if Denotes_Discriminant (Node (D)) then
 761                return Build_Component_Subtype
 762                  (Build_Discriminal_Record_Constraint, Loc, T);
 763             end if;
 764
 765             Next_Elmt (D);
 766          end loop;
 767       end if;
 768
 769       --  If none of the above, the actual and nominal subtypes are the same
 770
 771       return Empty;
 772    end Build_Discriminal_Subtype_Of_Component;
 773
 774    ------------------------------
 775    -- Build_Elaboration_Entity --
 776    ------------------------------
 777
 778    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
 779       Loc      : constant Source_Ptr := Sloc (N);
 780       Decl     : Node_Id;
 781       Elab_Ent : Entity_Id;
 782
 783       procedure Set_Package_Name (Ent : Entity_Id);
 784       --  Given an entity, sets the fully qualified name of the entity in
 785       --  Name_Buffer, with components separated by double underscores. This
 786       --  is a recursive routine that climbs the scope chain to Standard.
 787
 788       ----------------------
 789       -- Set_Package_Name --
 790       ----------------------
 791
 792       procedure Set_Package_Name (Ent : Entity_Id) is
 793       begin
 794          if Scope (Ent) /= Standard_Standard then
 795             Set_Package_Name (Scope (Ent));
 796
 797             declare
 798                Nam : constant String := Get_Name_String (Chars (Ent));
 799             begin
 800                Name_Buffer (Name_Len + 1) := '_';
 801                Name_Buffer (Name_Len + 2) := '_';
 802                Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
 803                Name_Len := Name_Len + Nam'Length + 2;
 804             end;
 805
 806          else
 807             Get_Name_String (Chars (Ent));
 808          end if;
 809       end Set_Package_Name;
 810
 811    --  Start of processing for Build_Elaboration_Entity
 812
 813    begin
 814       --  Ignore if already constructed
 815
 816       if Present (Elaboration_Entity (Spec_Id)) then
 817          return;
 818       end if;
 819
 820       --  Construct name of elaboration entity as xxx_E, where xxx is the unit
 821       --  name with dots replaced by double underscore. We have to manually
 822       --  construct this name, since it will be elaborated in the outer scope,
 823       --  and thus will not have the unit name automatically prepended.
 824
 825       Set_Package_Name (Spec_Id);
 826
 827       --  Append _E
 828
 829       Name_Buffer (Name_Len + 1) := '_';
 830       Name_Buffer (Name_Len + 2) := 'E';
 831       Name_Len := Name_Len + 2;
 832
 833       --  Create elaboration flag
 834
 835       Elab_Ent :=
 836         Make_Defining_Identifier (Loc, Chars => Name_Find);
 837       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
 838
 839       Decl :=
 840          Make_Object_Declaration (Loc,
 841            Defining_Identifier => Elab_Ent,
 842            Object_Definition   =>
 843              New_Occurrence_Of (Standard_Boolean, Loc),
 844            Expression          =>
 845              New_Occurrence_Of (Standard_False, Loc));
 846
 847       Push_Scope (Standard_Standard);
 848       Add_Global_Declaration (Decl);
 849       Pop_Scope;
 850
 851       --  Reset True_Constant indication, since we will indeed assign a value
 852       --  to the variable in the binder main. We also kill the Current_Value
 853       --  and Last_Assignment fields for the same reason.
 854
 855       Set_Is_True_Constant (Elab_Ent, False);
 856       Set_Current_Value    (Elab_Ent, Empty);
 857       Set_Last_Assignment  (Elab_Ent, Empty);
 858
 859       --  We do not want any further qualification of the name (if we did
 860       --  not do this, we would pick up the name of the generic package
 861       --  in the case of a library level generic instantiation).
 862
 863       Set_Has_Qualified_Name       (Elab_Ent);
 864       Set_Has_Fully_Qualified_Name (Elab_Ent);
 865    end Build_Elaboration_Entity;
 866
 867    -----------------------------------
 868    -- Cannot_Raise_Constraint_Error --
 869    -----------------------------------
 870
 871    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
 872    begin
 873       if Compile_Time_Known_Value (Expr) then
 874          return True;
 875
 876       elsif Do_Range_Check (Expr) then
 877          return False;
 878
 879       elsif Raises_Constraint_Error (Expr) then
 880          return False;
 881
 882       else
 883          case Nkind (Expr) is
 884             when N_Identifier =>
 885                return True;
 886
 887             when N_Expanded_Name =>
 888                return True;
 889
 890             when N_Selected_Component =>
 891                return not Do_Discriminant_Check (Expr);
 892
 893             when N_Attribute_Reference =>
 894                if Do_Overflow_Check (Expr) then
 895                   return False;
 896
 897                elsif No (Expressions (Expr)) then
 898                   return True;
 899
 900                else
 901                   declare
 902                      N : Node_Id;
 903
 904                   begin
 905                      N := First (Expressions (Expr));
 906                      while Present (N) loop
 907                         if Cannot_Raise_Constraint_Error (N) then
 908                            Next (N);
 909                         else
 910                            return False;
 911                         end if;
 912                      end loop;
 913
 914                      return True;
 915                   end;
 916                end if;
 917
 918             when N_Type_Conversion =>
 919                if Do_Overflow_Check (Expr)
 920                  or else Do_Length_Check (Expr)
 921                  or else Do_Tag_Check (Expr)
 922                then
 923                   return False;
 924                else
 925                   return
 926                     Cannot_Raise_Constraint_Error (Expression (Expr));
 927                end if;
 928
 929             when N_Unchecked_Type_Conversion =>
 930                return Cannot_Raise_Constraint_Error (Expression (Expr));
 931
 932             when N_Unary_Op =>
 933                if Do_Overflow_Check (Expr) then
 934                   return False;
 935                else
 936                   return
 937                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
 938                end if;
 939
 940             when N_Op_Divide |
 941                  N_Op_Mod    |
 942                  N_Op_Rem
 943             =>
 944                if Do_Division_Check (Expr)
 945                  or else Do_Overflow_Check (Expr)
 946                then
 947                   return False;
 948                else
 949                   return
 950                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
 951                       and then
 952                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
 953                end if;
 954
 955             when N_Op_Add                    |
 956                  N_Op_And                    |
 957                  N_Op_Concat                 |
 958                  N_Op_Eq                     |
 959                  N_Op_Expon                  |
 960                  N_Op_Ge                     |
 961                  N_Op_Gt                     |
 962                  N_Op_Le                     |
 963                  N_Op_Lt                     |
 964                  N_Op_Multiply               |
 965                  N_Op_Ne                     |
 966                  N_Op_Or                     |
 967                  N_Op_Rotate_Left            |
 968                  N_Op_Rotate_Right           |
 969                  N_Op_Shift_Left             |
 970                  N_Op_Shift_Right            |
 971                  N_Op_Shift_Right_Arithmetic |
 972                  N_Op_Subtract               |
 973                  N_Op_Xor
 974             =>
 975                if Do_Overflow_Check (Expr) then
 976                   return False;
 977                else
 978                   return
 979                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
 980                       and then
 981                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
 982                end if;
 983
 984             when others =>
 985                return False;
 986          end case;
 987       end if;
 988    end Cannot_Raise_Constraint_Error;
 989
 990    --------------------------
 991    -- Check_Fully_Declared --
 992    --------------------------
 993
 994    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
 995    begin
 996       if Ekind (T) = E_Incomplete_Type then
 997
 998          --  Ada 2005 (AI-50217): If the type is available through a limited
 999          --  with_clause, verify that its full view has been analyzed.
1000
1001          if From_With_Type (T)
1002            and then Present (Non_Limited_View (T))
1003            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1004          then
1005             --  The non-limited view is fully declared
1006             null;
1007
1008          else
1009             Error_Msg_NE
1010               ("premature usage of incomplete}", N, First_Subtype (T));
1011          end if;
1012
1013       elsif Has_Private_Component (T)
1014         and then not Is_Generic_Type (Root_Type (T))
1015         and then not In_Default_Expression
1016       then
1017
1018          --  Special case: if T is the anonymous type created for a single
1019          --  task or protected object, use the name of the source object.
1020
1021          if Is_Concurrent_Type (T)
1022            and then not Comes_From_Source (T)
1023            and then Nkind (N) = N_Object_Declaration
1024          then
1025             Error_Msg_NE ("type of& has incomplete component", N,
1026               Defining_Identifier (N));
1027
1028          else
1029             Error_Msg_NE
1030               ("premature usage of incomplete}", N, First_Subtype (T));
1031          end if;
1032       end if;
1033    end Check_Fully_Declared;
1034
1035    -------------------------
1036    -- Check_Nested_Access --
1037    -------------------------
1038
1039    procedure Check_Nested_Access (Ent : Entity_Id) is
1040       Scop         : constant Entity_Id := Current_Scope;
1041       Current_Subp : Entity_Id;
1042       Enclosing    : Entity_Id;
1043
1044    begin
1045       --  Currently only enabled for VM back-ends for efficiency, should we
1046       --  enable it more systematically ???
1047
1048       if VM_Target /= No_VM
1049         and then (Ekind (Ent) = E_Variable
1050                     or else
1051                   Ekind (Ent) = E_Constant
1052                     or else
1053                   Ekind (Ent) = E_Loop_Parameter)
1054         and then Scope (Ent) /= Empty
1055         and then not Is_Library_Level_Entity (Ent)
1056       then
1057          if Is_Subprogram (Scop)
1058            or else Is_Generic_Subprogram (Scop)
1059            or else Is_Entry (Scop)
1060          then
1061             Current_Subp := Scop;
1062          else
1063             Current_Subp := Current_Subprogram;
1064          end if;
1065
1066          Enclosing := Enclosing_Subprogram (Ent);
1067
1068          if Enclosing /= Empty
1069            and then Enclosing /= Current_Subp
1070          then
1071             Set_Has_Up_Level_Access (Ent, True);
1072          end if;
1073       end if;
1074    end Check_Nested_Access;
1075
1076    ------------------------------------------
1077    -- Check_Potentially_Blocking_Operation --
1078    ------------------------------------------
1079
1080    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
1081       S : Entity_Id;
1082    begin
1083       --  N is one of the potentially blocking operations listed in 9.5.1(8).
1084       --  When pragma Detect_Blocking is active, the run time will raise
1085       --  Program_Error. Here we only issue a warning, since we generally
1086       --  support the use of potentially blocking operations in the absence
1087       --  of the pragma.
1088
1089       --  Indirect blocking through a subprogram call cannot be diagnosed
1090       --  statically without interprocedural analysis, so we do not attempt
1091       --  to do it here.
1092
1093       S := Scope (Current_Scope);
1094       while Present (S) and then S /= Standard_Standard loop
1095          if Is_Protected_Type (S) then
1096             Error_Msg_N
1097               ("potentially blocking operation in protected operation?", N);
1098
1099             return;
1100          end if;
1101
1102          S := Scope (S);
1103       end loop;
1104    end Check_Potentially_Blocking_Operation;
1105
1106    ---------------
1107    -- Check_VMS --
1108    ---------------
1109
1110    procedure Check_VMS (Construct : Node_Id) is
1111    begin
1112       if not OpenVMS_On_Target then
1113          Error_Msg_N
1114            ("this construct is allowed only in Open'V'M'S", Construct);
1115       end if;
1116    end Check_VMS;
1117
1118    ---------------------------------
1119    -- Collect_Abstract_Interfaces --
1120    ---------------------------------
1121
1122    procedure Collect_Abstract_Interfaces
1123      (T                         : Entity_Id;
1124       Ifaces_List               : out Elist_Id;
1125       Exclude_Parent_Interfaces : Boolean := False;
1126       Use_Full_View             : Boolean := True)
1127    is
1128       procedure Add_Interface (Iface : Entity_Id);
1129       --  Add the interface it if is not already in the list
1130
1131       procedure Collect (Typ : Entity_Id);
1132       --  Subsidiary subprogram used to traverse the whole list
1133       --  of directly and indirectly implemented interfaces
1134
1135       function Interface_Present_In_Parent
1136          (Typ   : Entity_Id;
1137           Iface : Entity_Id) return Boolean;
1138       --  Typ must be a tagged record type/subtype and Iface must be an
1139       --  abstract interface type. This function is used to check if Typ
1140       --  or some parent of Typ implements Iface.
1141
1142       -------------------
1143       -- Add_Interface --
1144       -------------------
1145
1146       procedure Add_Interface (Iface : Entity_Id) is
1147          Elmt : Elmt_Id;
1148
1149       begin
1150          Elmt := First_Elmt (Ifaces_List);
1151          while Present (Elmt) and then Node (Elmt) /= Iface loop
1152             Next_Elmt (Elmt);
1153          end loop;
1154
1155          if No (Elmt) then
1156             Append_Elmt (Iface, Ifaces_List);
1157          end if;
1158       end Add_Interface;
1159
1160       -------------
1161       -- Collect --
1162       -------------
1163
1164       procedure Collect (Typ : Entity_Id) is
1165          Ancestor   : Entity_Id;
1166          Full_T     : Entity_Id;
1167          Iface_List : List_Id;
1168          Id         : Node_Id;
1169          Iface      : Entity_Id;
1170
1171       begin
1172          Full_T := Typ;
1173
1174          --  Handle private types
1175
1176          if Use_Full_View
1177            and then Is_Private_Type (Typ)
1178            and then Present (Full_View (Typ))
1179          then
1180             Full_T := Full_View (Typ);
1181          end if;
1182
1183          Iface_List := Abstract_Interface_List (Full_T);
1184
1185          --  Include the ancestor if we are generating the whole list of
1186          --  abstract interfaces.
1187
1188          --  In concurrent types the ancestor interface (if any) is the
1189          --  first element of the list of interface types.
1190
1191          if Is_Concurrent_Type (Full_T)
1192            or else Is_Concurrent_Record_Type (Full_T)
1193          then
1194             if Is_Non_Empty_List (Iface_List) then
1195                Ancestor := Etype (First (Iface_List));
1196                Collect (Ancestor);
1197
1198                if not Exclude_Parent_Interfaces then
1199                   Add_Interface (Ancestor);
1200                end if;
1201             end if;
1202
1203          elsif Etype (Full_T) /= Typ
1204
1205             --  Protect the frontend against wrong sources. For example:
1206
1207             --    package P is
1208             --      type A is tagged null record;
1209             --      type B is new A with private;
1210             --      type C is new A with private;
1211             --    private
1212             --      type B is new C with null record;
1213             --      type C is new B with null record;
1214             --    end P;
1215
1216            and then Etype (Full_T) /= T
1217          then
1218             Ancestor := Etype (Full_T);
1219             Collect (Ancestor);
1220
1221             if Is_Interface (Ancestor)
1222               and then not Exclude_Parent_Interfaces
1223             then
1224                Add_Interface (Ancestor);
1225             end if;
1226          end if;
1227
1228          --  Traverse the graph of ancestor interfaces
1229
1230          if Is_Non_Empty_List (Iface_List) then
1231             Id := First (Iface_List);
1232
1233             --  In concurrent types the ancestor interface (if any) is the
1234             --  first element of the list of interface types and we have
1235             --  already processed them while climbing to the root type.
1236
1237             if Is_Concurrent_Type (Full_T)
1238               or else Is_Concurrent_Record_Type (Full_T)
1239             then
1240                Next (Id);
1241             end if;
1242
1243             while Present (Id) loop
1244                Iface := Etype (Id);
1245
1246                --  Protect against wrong uses. For example:
1247                --    type I is interface;
1248                --    type O is tagged null record;
1249                --    type Wrong is new I and O with null record; -- ERROR
1250
1251                if Is_Interface (Iface) then
1252                   if Exclude_Parent_Interfaces
1253                     and then Interface_Present_In_Parent (T, Iface)
1254                   then
1255                      null;
1256                   else
1257                      Collect       (Iface);
1258                      Add_Interface (Iface);
1259                   end if;
1260                end if;
1261
1262                Next (Id);
1263             end loop;
1264          end if;
1265       end Collect;
1266
1267       ---------------------------------
1268       -- Interface_Present_In_Parent --
1269       ---------------------------------
1270
1271       function Interface_Present_In_Parent
1272          (Typ   : Entity_Id;
1273           Iface : Entity_Id) return Boolean
1274       is
1275          Aux        : Entity_Id := Typ;
1276          Iface_List : List_Id;
1277
1278       begin
1279          if Is_Concurrent_Type (Typ)
1280            or else Is_Concurrent_Record_Type (Typ)
1281          then
1282             Iface_List := Abstract_Interface_List (Typ);
1283
1284             if Is_Non_Empty_List (Iface_List) then
1285                Aux := Etype (First (Iface_List));
1286             else
1287                return False;
1288             end if;
1289          end if;
1290
1291          return Interface_Present_In_Ancestor (Aux, Iface);
1292       end Interface_Present_In_Parent;
1293
1294    --  Start of processing for Collect_Abstract_Interfaces
1295
1296    begin
1297       pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
1298       Ifaces_List := New_Elmt_List;
1299       Collect (T);
1300    end Collect_Abstract_Interfaces;
1301
1302    ----------------------------------
1303    -- Collect_Interface_Components --
1304    ----------------------------------
1305
1306    procedure Collect_Interface_Components
1307      (Tagged_Type     : Entity_Id;
1308       Components_List : out Elist_Id)
1309    is
1310       procedure Collect (Typ : Entity_Id);
1311       --  Subsidiary subprogram used to climb to the parents
1312
1313       -------------
1314       -- Collect --
1315       -------------
1316
1317       procedure Collect (Typ : Entity_Id) is
1318          Tag_Comp : Entity_Id;
1319
1320       begin
1321          if Etype (Typ) /= Typ
1322
1323             --  Protect the frontend against wrong sources. For example:
1324
1325             --    package P is
1326             --      type A is tagged null record;
1327             --      type B is new A with private;
1328             --      type C is new A with private;
1329             --    private
1330             --      type B is new C with null record;
1331             --      type C is new B with null record;
1332             --    end P;
1333
1334            and then Etype (Typ) /= Tagged_Type
1335          then
1336             Collect (Etype (Typ));
1337          end if;
1338
1339          --  Collect the components containing tags of secondary dispatch
1340          --  tables.
1341
1342          Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
1343          while Present (Tag_Comp) loop
1344             pragma Assert (Present (Related_Type (Tag_Comp)));
1345             Append_Elmt (Tag_Comp, Components_List);
1346
1347             Tag_Comp := Next_Tag_Component (Tag_Comp);
1348          end loop;
1349       end Collect;
1350
1351    --  Start of processing for Collect_Interface_Components
1352
1353    begin
1354       pragma Assert (Ekind (Tagged_Type) = E_Record_Type
1355         and then Is_Tagged_Type (Tagged_Type));
1356
1357       Components_List := New_Elmt_List;
1358       Collect (Tagged_Type);
1359    end Collect_Interface_Components;
1360
1361    -----------------------------
1362    -- Collect_Interfaces_Info --
1363    -----------------------------
1364
1365    procedure Collect_Interfaces_Info
1366      (T               : Entity_Id;
1367       Ifaces_List     : out Elist_Id;
1368       Components_List : out Elist_Id;
1369       Tags_List       : out Elist_Id)
1370    is
1371       Comps_List : Elist_Id;
1372       Comp_Elmt  : Elmt_Id;
1373       Comp_Iface : Entity_Id;
1374       Iface_Elmt : Elmt_Id;
1375       Iface      : Entity_Id;
1376
1377       function Search_Tag (Iface : Entity_Id) return Entity_Id;
1378       --  Search for the secondary tag associated with the interface type
1379       --  Iface that is implemented by T.
1380
1381       ----------------
1382       -- Search_Tag --
1383       ----------------
1384
1385       function Search_Tag (Iface : Entity_Id) return Entity_Id is
1386          ADT : Elmt_Id;
1387
1388       begin
1389          ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
1390          while Present (ADT)
1391             and then Ekind (Node (ADT)) = E_Constant
1392             and then Related_Type (Node (ADT)) /= Iface
1393          loop
1394             --  Skip the secondary dispatch tables of Iface
1395
1396             Next_Elmt (ADT);
1397             Next_Elmt (ADT);
1398             Next_Elmt (ADT);
1399             Next_Elmt (ADT);
1400          end loop;
1401
1402          pragma Assert (Ekind (Node (ADT)) = E_Constant);
1403          return Node (ADT);
1404       end Search_Tag;
1405
1406    --  Start of processing for Collect_Interfaces_Info
1407
1408    begin
1409       Collect_Abstract_Interfaces  (T, Ifaces_List);
1410       Collect_Interface_Components (T, Comps_List);
1411
1412       --  Search for the record component and tag associated with each
1413       --  interface type of T.
1414
1415       Components_List := New_Elmt_List;
1416       Tags_List       := New_Elmt_List;
1417
1418       Iface_Elmt := First_Elmt (Ifaces_List);
1419       while Present (Iface_Elmt) loop
1420          Iface := Node (Iface_Elmt);
1421
1422          --  Associate the primary tag component and the primary dispatch table
1423          --  with all the interfaces that are parents of T
1424
1425          if Is_Parent (Iface, T) then
1426             Append_Elmt (First_Tag_Component (T), Components_List);
1427             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
1428
1429          --  Otherwise search for the tag component and secondary dispatch
1430          --  table of Iface
1431
1432          else
1433             Comp_Elmt := First_Elmt (Comps_List);
1434             while Present (Comp_Elmt) loop
1435                Comp_Iface := Related_Type (Node (Comp_Elmt));
1436
1437                if Comp_Iface = Iface
1438                  or else Is_Parent (Iface, Comp_Iface)
1439                then
1440                   Append_Elmt (Node (Comp_Elmt), Components_List);
1441                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
1442                   exit;
1443                end if;
1444
1445                Next_Elmt (Comp_Elmt);
1446             end loop;
1447             pragma Assert (Present (Comp_Elmt));
1448          end if;
1449
1450          Next_Elmt (Iface_Elmt);
1451       end loop;
1452    end Collect_Interfaces_Info;
1453
1454    ----------------------------------
1455    -- Collect_Primitive_Operations --
1456    ----------------------------------
1457
1458    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
1459       B_Type         : constant Entity_Id := Base_Type (T);
1460       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
1461       B_Scope        : Entity_Id          := Scope (B_Type);
1462       Op_List        : Elist_Id;
1463       Formal         : Entity_Id;
1464       Is_Prim        : Boolean;
1465       Formal_Derived : Boolean := False;
1466       Id             : Entity_Id;
1467
1468    begin
1469       --  For tagged types, the primitive operations are collected as they
1470       --  are declared, and held in an explicit list which is simply returned.
1471
1472       if Is_Tagged_Type (B_Type) then
1473          return Primitive_Operations (B_Type);
1474
1475       --  An untagged generic type that is a derived type inherits the
1476       --  primitive operations of its parent type. Other formal types only
1477       --  have predefined operators, which are not explicitly represented.
1478
1479       elsif Is_Generic_Type (B_Type) then
1480          if Nkind (B_Decl) = N_Formal_Type_Declaration
1481            and then Nkind (Formal_Type_Definition (B_Decl))
1482              = N_Formal_Derived_Type_Definition
1483          then
1484             Formal_Derived := True;
1485          else
1486             return New_Elmt_List;
1487          end if;
1488       end if;
1489
1490       Op_List := New_Elmt_List;
1491
1492       if B_Scope = Standard_Standard then
1493          if B_Type = Standard_String then
1494             Append_Elmt (Standard_Op_Concat, Op_List);
1495
1496          elsif B_Type = Standard_Wide_String then
1497             Append_Elmt (Standard_Op_Concatw, Op_List);
1498
1499          else
1500             null;
1501          end if;
1502
1503       elsif (Is_Package_Or_Generic_Package (B_Scope)
1504               and then
1505                 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
1506                                                             N_Package_Body)
1507         or else Is_Derived_Type (B_Type)
1508       then
1509          --  The primitive operations appear after the base type, except
1510          --  if the derivation happens within the private part of B_Scope
1511          --  and the type is a private type, in which case both the type
1512          --  and some primitive operations may appear before the base
1513          --  type, and the list of candidates starts after the type.
1514
1515          if In_Open_Scopes (B_Scope)
1516            and then Scope (T) = B_Scope
1517            and then In_Private_Part (B_Scope)
1518          then
1519             Id := Next_Entity (T);
1520          else
1521             Id := Next_Entity (B_Type);
1522          end if;
1523
1524          while Present (Id) loop
1525
1526             --  Note that generic formal subprograms are not
1527             --  considered to be primitive operations and thus
1528             --  are never inherited.
1529
1530             if Is_Overloadable (Id)
1531               and then Nkind (Parent (Parent (Id)))
1532                          not in N_Formal_Subprogram_Declaration
1533             then
1534                Is_Prim := False;
1535
1536                if Base_Type (Etype (Id)) = B_Type then
1537                   Is_Prim := True;
1538                else
1539                   Formal := First_Formal (Id);
1540                   while Present (Formal) loop
1541                      if Base_Type (Etype (Formal)) = B_Type then
1542                         Is_Prim := True;
1543                         exit;
1544
1545                      elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
1546                        and then Base_Type
1547                          (Designated_Type (Etype (Formal))) = B_Type
1548                      then
1549                         Is_Prim := True;
1550                         exit;
1551                      end if;
1552
1553                      Next_Formal (Formal);
1554                   end loop;
1555                end if;
1556
1557                --  For a formal derived type, the only primitives are the
1558                --  ones inherited from the parent type. Operations appearing
1559                --  in the package declaration are not primitive for it.
1560
1561                if Is_Prim
1562                  and then (not Formal_Derived
1563                             or else Present (Alias (Id)))
1564                then
1565                   Append_Elmt (Id, Op_List);
1566                end if;
1567             end if;
1568
1569             Next_Entity (Id);
1570
1571             --  For a type declared in System, some of its operations
1572             --  may appear in  the target-specific extension to System.
1573
1574             if No (Id)
1575               and then Chars (B_Scope) = Name_System
1576               and then Scope (B_Scope) = Standard_Standard
1577               and then Present_System_Aux
1578             then
1579                B_Scope := System_Aux_Id;
1580                Id := First_Entity (System_Aux_Id);
1581             end if;
1582          end loop;
1583       end if;
1584
1585       return Op_List;
1586    end Collect_Primitive_Operations;
1587
1588    -----------------------------------
1589    -- Compile_Time_Constraint_Error --
1590    -----------------------------------
1591
1592    function Compile_Time_Constraint_Error
1593      (N    : Node_Id;
1594       Msg  : String;
1595       Ent  : Entity_Id  := Empty;
1596       Loc  : Source_Ptr := No_Location;
1597       Warn : Boolean    := False) return Node_Id
1598    is
1599       Msgc : String (1 .. Msg'Length + 2);
1600       --  Copy of message, with room for possible ? and ! at end
1601
1602       Msgl : Natural;
1603       Wmsg : Boolean;
1604       P    : Node_Id;
1605       OldP : Node_Id;
1606       Msgs : Boolean;
1607       Eloc : Source_Ptr;
1608
1609    begin
1610       --  A static constraint error in an instance body is not a fatal error.
1611       --  we choose to inhibit the message altogether, because there is no
1612       --  obvious node (for now) on which to post it. On the other hand the
1613       --  offending node must be replaced with a constraint_error in any case.
1614
1615       --  No messages are generated if we already posted an error on this node
1616
1617       if not Error_Posted (N) then
1618          if Loc /= No_Location then
1619             Eloc := Loc;
1620          else
1621             Eloc := Sloc (N);
1622          end if;
1623
1624          Msgc (1 .. Msg'Length) := Msg;
1625          Msgl := Msg'Length;
1626
1627          --  Message is a warning, even in Ada 95 case
1628
1629          if Msg (Msg'Last) = '?' then
1630             Wmsg := True;
1631
1632          --  In Ada 83, all messages are warnings. In the private part and
1633          --  the body of an instance, constraint_checks are only warnings.
1634          --  We also make this a warning if the Warn parameter is set.
1635
1636          elsif Warn
1637            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
1638          then
1639             Msgl := Msgl + 1;
1640             Msgc (Msgl) := '?';
1641             Wmsg := True;
1642
1643          elsif In_Instance_Not_Visible then
1644             Msgl := Msgl + 1;
1645             Msgc (Msgl) := '?';
1646             Wmsg := True;
1647
1648          --  Otherwise we have a real error message (Ada 95 static case)
1649          --  and we make this an unconditional message. Note that in the
1650          --  warning case we do not make the message unconditional, it seems
1651          --  quite reasonable to delete messages like this (about exceptions
1652          --  that will be raised) in dead code.
1653
1654          else
1655             Wmsg := False;
1656             Msgl := Msgl + 1;
1657             Msgc (Msgl) := '!';
1658          end if;
1659
1660          --  Should we generate a warning? The answer is not quite yes. The
1661          --  very annoying exception occurs in the case of a short circuit
1662          --  operator where the left operand is static and decisive. Climb
1663          --  parents to see if that is the case we have here. Conditional
1664          --  expressions with decisive conditions are a similar situation.
1665
1666          Msgs := True;
1667          P := N;
1668          loop
1669             OldP := P;
1670             P := Parent (P);
1671
1672             --  And then with False as left operand
1673
1674             if Nkind (P) = N_And_Then
1675               and then Compile_Time_Known_Value (Left_Opnd (P))
1676               and then Is_False (Expr_Value (Left_Opnd (P)))
1677             then
1678                Msgs := False;
1679                exit;
1680
1681             --  OR ELSE with True as left operand
1682
1683             elsif Nkind (P) = N_Or_Else
1684               and then Compile_Time_Known_Value (Left_Opnd (P))
1685               and then Is_True (Expr_Value (Left_Opnd (P)))
1686             then
1687                Msgs := False;
1688                exit;
1689
1690             --  Conditional expression
1691
1692             elsif Nkind (P) = N_Conditional_Expression then
1693                declare
1694                   Cond : constant Node_Id := First (Expressions (P));
1695                   Texp : constant Node_Id := Next (Cond);
1696                   Fexp : constant Node_Id := Next (Texp);
1697
1698                begin
1699                   if Compile_Time_Known_Value (Cond) then
1700
1701                      --  Condition is True and we are in the right operand
1702
1703                      if Is_True (Expr_Value (Cond))
1704                        and then OldP = Fexp
1705                      then
1706                         Msgs := False;
1707                         exit;
1708
1709                      --  Condition is False and we are in the left operand
1710
1711                      elsif Is_False (Expr_Value (Cond))
1712                        and then OldP = Texp
1713                      then
1714                         Msgs := False;
1715                         exit;
1716                      end if;
1717                   end if;
1718                end;
1719
1720             --  Special case for component association in aggregates, where
1721             --  we want to keep climbing up to the parent aggregate.
1722
1723             elsif Nkind (P) = N_Component_Association
1724               and then Nkind (Parent (P)) = N_Aggregate
1725             then
1726                null;
1727
1728             --  Keep going if within subexpression
1729
1730             else
1731                exit when Nkind (P) not in N_Subexpr;
1732             end if;
1733          end loop;
1734
1735          if Msgs then
1736             if Present (Ent) then
1737                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
1738             else
1739                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
1740             end if;
1741
1742             if Wmsg then
1743                if Inside_Init_Proc then
1744                   Error_Msg_NEL
1745                     ("\?& will be raised for objects of this type",
1746                      N, Standard_Constraint_Error, Eloc);
1747                else
1748                   Error_Msg_NEL
1749                     ("\?& will be raised at run time",
1750                      N, Standard_Constraint_Error, Eloc);
1751                end if;
1752
1753             else
1754                Error_Msg
1755                  ("\static expression fails Constraint_Check", Eloc);
1756                Set_Error_Posted (N);
1757             end if;
1758          end if;
1759       end if;
1760
1761       return N;
1762    end Compile_Time_Constraint_Error;
1763
1764    -----------------------
1765    -- Conditional_Delay --
1766    -----------------------
1767
1768    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
1769    begin
1770       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
1771          Set_Has_Delayed_Freeze (New_Ent);
1772       end if;
1773    end Conditional_Delay;
1774
1775    --------------------
1776    -- Current_Entity --
1777    --------------------
1778
1779    --  The currently visible definition for a given identifier is the
1780    --  one most chained at the start of the visibility chain, i.e. the
1781    --  one that is referenced by the Node_Id value of the name of the
1782    --  given identifier.
1783
1784    function Current_Entity (N : Node_Id) return Entity_Id is
1785    begin
1786       return Get_Name_Entity_Id (Chars (N));
1787    end Current_Entity;
1788
1789    -----------------------------
1790    -- Current_Entity_In_Scope --
1791    -----------------------------
1792
1793    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
1794       E  : Entity_Id;
1795       CS : constant Entity_Id := Current_Scope;
1796
1797       Transient_Case : constant Boolean := Scope_Is_Transient;
1798
1799    begin
1800       E := Get_Name_Entity_Id (Chars (N));
1801       while Present (E)
1802         and then Scope (E) /= CS
1803         and then (not Transient_Case or else Scope (E) /= Scope (CS))
1804       loop
1805          E := Homonym (E);
1806       end loop;
1807
1808       return E;
1809    end Current_Entity_In_Scope;
1810
1811    -------------------
1812    -- Current_Scope --
1813    -------------------
1814
1815    function Current_Scope return Entity_Id is
1816    begin
1817       if Scope_Stack.Last = -1 then
1818          return Standard_Standard;
1819       else
1820          declare
1821             C : constant Entity_Id :=
1822                   Scope_Stack.Table (Scope_Stack.Last).Entity;
1823          begin
1824             if Present (C) then
1825                return C;
1826             else
1827                return Standard_Standard;
1828             end if;
1829          end;
1830       end if;
1831    end Current_Scope;
1832
1833    ------------------------
1834    -- Current_Subprogram --
1835    ------------------------
1836
1837    function Current_Subprogram return Entity_Id is
1838       Scop : constant Entity_Id := Current_Scope;
1839
1840    begin
1841       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
1842          return Scop;
1843       else
1844          return Enclosing_Subprogram (Scop);
1845       end if;
1846    end Current_Subprogram;
1847
1848    ---------------------
1849    -- Defining_Entity --
1850    ---------------------
1851
1852    function Defining_Entity (N : Node_Id) return Entity_Id is
1853       K   : constant Node_Kind := Nkind (N);
1854       Err : Entity_Id := Empty;
1855
1856    begin
1857       case K is
1858          when
1859            N_Subprogram_Declaration                 |
1860            N_Abstract_Subprogram_Declaration        |
1861            N_Subprogram_Body                        |
1862            N_Package_Declaration                    |
1863            N_Subprogram_Renaming_Declaration        |
1864            N_Subprogram_Body_Stub                   |
1865            N_Generic_Subprogram_Declaration         |
1866            N_Generic_Package_Declaration            |
1867            N_Formal_Subprogram_Declaration
1868          =>
1869             return Defining_Entity (Specification (N));
1870
1871          when
1872            N_Component_Declaration                  |
1873            N_Defining_Program_Unit_Name             |
1874            N_Discriminant_Specification             |
1875            N_Entry_Body                             |
1876            N_Entry_Declaration                      |
1877            N_Entry_Index_Specification              |
1878            N_Exception_Declaration                  |
1879            N_Exception_Renaming_Declaration         |
1880            N_Formal_Object_Declaration              |
1881            N_Formal_Package_Declaration             |
1882            N_Formal_Type_Declaration                |
1883            N_Full_Type_Declaration                  |
1884            N_Implicit_Label_Declaration             |
1885            N_Incomplete_Type_Declaration            |
1886            N_Loop_Parameter_Specification           |
1887            N_Number_Declaration                     |
1888            N_Object_Declaration                     |
1889            N_Object_Renaming_Declaration            |
1890            N_Package_Body_Stub                      |
1891            N_Parameter_Specification                |
1892            N_Private_Extension_Declaration          |
1893            N_Private_Type_Declaration               |
1894            N_Protected_Body                         |
1895            N_Protected_Body_Stub                    |
1896            N_Protected_Type_Declaration             |
1897            N_Single_Protected_Declaration           |
1898            N_Single_Task_Declaration                |
1899            N_Subtype_Declaration                    |
1900            N_Task_Body                              |
1901            N_Task_Body_Stub                         |
1902            N_Task_Type_Declaration
1903          =>
1904             return Defining_Identifier (N);
1905
1906          when N_Subunit =>
1907             return Defining_Entity (Proper_Body (N));
1908
1909          when
1910            N_Function_Instantiation                 |
1911            N_Function_Specification                 |
1912            N_Generic_Function_Renaming_Declaration  |
1913            N_Generic_Package_Renaming_Declaration   |
1914            N_Generic_Procedure_Renaming_Declaration |
1915            N_Package_Body                           |
1916            N_Package_Instantiation                  |
1917            N_Package_Renaming_Declaration           |
1918            N_Package_Specification                  |
1919            N_Procedure_Instantiation                |
1920            N_Procedure_Specification
1921          =>
1922             declare
1923                Nam : constant Node_Id := Defining_Unit_Name (N);
1924
1925             begin
1926                if Nkind (Nam) in N_Entity then
1927                   return Nam;
1928
1929                --  For Error, make up a name and attach to declaration
1930                --  so we can continue semantic analysis
1931
1932                elsif Nam = Error then
1933                   Err :=
1934                     Make_Defining_Identifier (Sloc (N),
1935                       Chars => New_Internal_Name ('T'));
1936                   Set_Defining_Unit_Name (N, Err);
1937
1938                   return Err;
1939                --  If not an entity, get defining identifier
1940
1941                else
1942                   return Defining_Identifier (Nam);
1943                end if;
1944             end;
1945
1946          when N_Block_Statement =>
1947             return Entity (Identifier (N));
1948
1949          when others =>
1950             raise Program_Error;
1951
1952       end case;
1953    end Defining_Entity;
1954
1955    --------------------------
1956    -- Denotes_Discriminant --
1957    --------------------------
1958
1959    function Denotes_Discriminant
1960      (N                : Node_Id;
1961       Check_Concurrent : Boolean := False) return Boolean
1962    is
1963       E : Entity_Id;
1964    begin
1965       if not Is_Entity_Name (N)
1966         or else No (Entity (N))
1967       then
1968          return False;
1969       else
1970          E := Entity (N);
1971       end if;
1972
1973       --  If we are checking for a protected type, the discriminant may have
1974       --  been rewritten as the corresponding discriminal of the original type
1975       --  or of the corresponding concurrent record, depending on whether we
1976       --  are in the spec or body of the protected type.
1977
1978       return Ekind (E) = E_Discriminant
1979         or else
1980           (Check_Concurrent
1981             and then Ekind (E) = E_In_Parameter
1982             and then Present (Discriminal_Link (E))
1983             and then
1984               (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
1985                 or else
1986                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
1987
1988    end Denotes_Discriminant;
1989
1990    -----------------------------
1991    -- Depends_On_Discriminant --
1992    -----------------------------
1993
1994    function Depends_On_Discriminant (N : Node_Id) return Boolean is
1995       L : Node_Id;
1996       H : Node_Id;
1997
1998    begin
1999       Get_Index_Bounds (N, L, H);
2000       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
2001    end Depends_On_Discriminant;
2002
2003    -------------------------
2004    -- Designate_Same_Unit --
2005    -------------------------
2006
2007    function Designate_Same_Unit
2008      (Name1 : Node_Id;
2009       Name2 : Node_Id) return Boolean
2010    is
2011       K1 : constant Node_Kind := Nkind (Name1);
2012       K2 : constant Node_Kind := Nkind (Name2);
2013
2014       function Prefix_Node (N : Node_Id) return Node_Id;
2015       --  Returns the parent unit name node of a defining program unit name
2016       --  or the prefix if N is a selected component or an expanded name.
2017
2018       function Select_Node (N : Node_Id) return Node_Id;
2019       --  Returns the defining identifier node of a defining program unit
2020       --  name or  the selector node if N is a selected component or an
2021       --  expanded name.
2022
2023       -----------------
2024       -- Prefix_Node --
2025       -----------------
2026
2027       function Prefix_Node (N : Node_Id) return Node_Id is
2028       begin
2029          if Nkind (N) = N_Defining_Program_Unit_Name then
2030             return Name (N);
2031
2032          else
2033             return Prefix (N);
2034          end if;
2035       end Prefix_Node;
2036
2037       -----------------
2038       -- Select_Node --
2039       -----------------
2040
2041       function Select_Node (N : Node_Id) return Node_Id is
2042       begin
2043          if Nkind (N) = N_Defining_Program_Unit_Name then
2044             return Defining_Identifier (N);
2045
2046          else
2047             return Selector_Name (N);
2048          end if;
2049       end Select_Node;
2050
2051    --  Start of processing for Designate_Next_Unit
2052
2053    begin
2054       if (K1 = N_Identifier or else
2055           K1 = N_Defining_Identifier)
2056         and then
2057          (K2 = N_Identifier or else
2058           K2 = N_Defining_Identifier)
2059       then
2060          return Chars (Name1) = Chars (Name2);
2061
2062       elsif
2063          (K1 = N_Expanded_Name      or else
2064           K1 = N_Selected_Component or else
2065           K1 = N_Defining_Program_Unit_Name)
2066         and then
2067          (K2 = N_Expanded_Name      or else
2068           K2 = N_Selected_Component or else
2069           K2 = N_Defining_Program_Unit_Name)
2070       then
2071          return
2072            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
2073              and then
2074                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
2075
2076       else
2077          return False;
2078       end if;
2079    end Designate_Same_Unit;
2080
2081    ----------------------------
2082    -- Enclosing_Generic_Body --
2083    ----------------------------
2084
2085    function Enclosing_Generic_Body
2086      (N : Node_Id) return Node_Id
2087    is
2088       P    : Node_Id;
2089       Decl : Node_Id;
2090       Spec : Node_Id;
2091
2092    begin
2093       P := Parent (N);
2094       while Present (P) loop
2095          if Nkind (P) = N_Package_Body
2096            or else Nkind (P) = N_Subprogram_Body
2097          then
2098             Spec := Corresponding_Spec (P);
2099
2100             if Present (Spec) then
2101                Decl := Unit_Declaration_Node (Spec);
2102
2103                if Nkind (Decl) = N_Generic_Package_Declaration
2104                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
2105                then
2106                   return P;
2107                end if;
2108             end if;
2109          end if;
2110
2111          P := Parent (P);
2112       end loop;
2113
2114       return Empty;
2115    end Enclosing_Generic_Body;
2116
2117    ----------------------------
2118    -- Enclosing_Generic_Unit --
2119    ----------------------------
2120
2121    function Enclosing_Generic_Unit
2122      (N : Node_Id) return Node_Id
2123    is
2124       P    : Node_Id;
2125       Decl : Node_Id;
2126       Spec : Node_Id;
2127
2128    begin
2129       P := Parent (N);
2130       while Present (P) loop
2131          if Nkind (P) = N_Generic_Package_Declaration
2132            or else Nkind (P) = N_Generic_Subprogram_Declaration
2133          then
2134             return P;
2135
2136          elsif Nkind (P) = N_Package_Body
2137            or else Nkind (P) = N_Subprogram_Body
2138          then
2139             Spec := Corresponding_Spec (P);
2140
2141             if Present (Spec) then
2142                Decl := Unit_Declaration_Node (Spec);
2143
2144                if Nkind (Decl) = N_Generic_Package_Declaration
2145                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
2146                then
2147                   return Decl;
2148                end if;
2149             end if;
2150          end if;
2151
2152          P := Parent (P);
2153       end loop;
2154
2155       return Empty;
2156    end Enclosing_Generic_Unit;
2157
2158    -------------------------------
2159    -- Enclosing_Lib_Unit_Entity --
2160    -------------------------------
2161
2162    function Enclosing_Lib_Unit_Entity return Entity_Id is
2163       Unit_Entity : Entity_Id;
2164
2165    begin
2166       --  Look for enclosing library unit entity by following scope links.
2167       --  Equivalent to, but faster than indexing through the scope stack.
2168
2169       Unit_Entity := Current_Scope;
2170       while (Present (Scope (Unit_Entity))
2171         and then Scope (Unit_Entity) /= Standard_Standard)
2172         and not Is_Child_Unit (Unit_Entity)
2173       loop
2174          Unit_Entity := Scope (Unit_Entity);
2175       end loop;
2176
2177       return Unit_Entity;
2178    end Enclosing_Lib_Unit_Entity;
2179
2180    -----------------------------
2181    -- Enclosing_Lib_Unit_Node --
2182    -----------------------------
2183
2184    function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
2185       Current_Node : Node_Id;
2186
2187    begin
2188       Current_Node := N;
2189       while Present (Current_Node)
2190         and then Nkind (Current_Node) /= N_Compilation_Unit
2191       loop
2192          Current_Node := Parent (Current_Node);
2193       end loop;
2194
2195       if Nkind (Current_Node) /= N_Compilation_Unit then
2196          return Empty;
2197       end if;
2198
2199       return Current_Node;
2200    end Enclosing_Lib_Unit_Node;
2201
2202    --------------------------
2203    -- Enclosing_Subprogram --
2204    --------------------------
2205
2206    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
2207       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
2208
2209    begin
2210       if Dynamic_Scope = Standard_Standard then
2211          return Empty;
2212
2213       elsif Dynamic_Scope = Empty then
2214          return Empty;
2215
2216       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
2217          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
2218
2219       elsif Ekind (Dynamic_Scope) = E_Block
2220         or else Ekind (Dynamic_Scope) = E_Return_Statement
2221       then
2222          return Enclosing_Subprogram (Dynamic_Scope);
2223
2224       elsif Ekind (Dynamic_Scope) = E_Task_Type then
2225          return Get_Task_Body_Procedure (Dynamic_Scope);
2226
2227       elsif Convention (Dynamic_Scope) = Convention_Protected then
2228          return Protected_Body_Subprogram (Dynamic_Scope);
2229
2230       else
2231          return Dynamic_Scope;
2232       end if;
2233    end Enclosing_Subprogram;
2234
2235    ------------------------
2236    -- Ensure_Freeze_Node --
2237    ------------------------
2238
2239    procedure Ensure_Freeze_Node (E : Entity_Id) is
2240       FN : Node_Id;
2241
2242    begin
2243       if No (Freeze_Node (E)) then
2244          FN := Make_Freeze_Entity (Sloc (E));
2245          Set_Has_Delayed_Freeze (E);
2246          Set_Freeze_Node (E, FN);
2247          Set_Access_Types_To_Process (FN, No_Elist);
2248          Set_TSS_Elist (FN, No_Elist);
2249          Set_Entity (FN, E);
2250       end if;
2251    end Ensure_Freeze_Node;
2252
2253    ----------------
2254    -- Enter_Name --
2255    ----------------
2256
2257    procedure Enter_Name (Def_Id : Entity_Id) is
2258       C : constant Entity_Id := Current_Entity (Def_Id);
2259       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
2260       S : constant Entity_Id := Current_Scope;
2261
2262       function Is_Private_Component_Renaming (N : Node_Id) return Boolean;
2263       --  Recognize a renaming declaration that is introduced for private
2264       --  components of a protected type. We treat these as weak declarations
2265       --  so that they are overridden by entities with the same name that
2266       --  come from source, such as formals or local variables of a given
2267       --  protected declaration.
2268
2269       -----------------------------------
2270       -- Is_Private_Component_Renaming --
2271       -----------------------------------
2272
2273       function Is_Private_Component_Renaming (N : Node_Id) return Boolean is
2274       begin
2275          return not Comes_From_Source (N)
2276            and then not Comes_From_Source (Current_Scope)
2277            and then Nkind (N) = N_Object_Renaming_Declaration;
2278       end Is_Private_Component_Renaming;
2279
2280    --  Start of processing for Enter_Name
2281
2282    begin
2283       Generate_Definition (Def_Id);
2284
2285       --  Add new name to current scope declarations. Check for duplicate
2286       --  declaration, which may or may not be a genuine error.
2287
2288       if Present (E) then
2289
2290          --  Case of previous entity entered because of a missing declaration
2291          --  or else a bad subtype indication. Best is to use the new entity,
2292          --  and make the previous one invisible.
2293
2294          if Etype (E) = Any_Type then
2295             Set_Is_Immediately_Visible (E, False);
2296
2297          --  Case of renaming declaration constructed for package instances.
2298          --  if there is an explicit declaration with the same identifier,
2299          --  the renaming is not immediately visible any longer, but remains
2300          --  visible through selected component notation.
2301
2302          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
2303            and then not Comes_From_Source (E)
2304          then
2305             Set_Is_Immediately_Visible (E, False);
2306
2307          --  The new entity may be the package renaming, which has the same
2308          --  same name as a generic formal which has been seen already.
2309
2310          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
2311             and then not Comes_From_Source (Def_Id)
2312          then
2313             Set_Is_Immediately_Visible (E, False);
2314
2315          --  For a fat pointer corresponding to a remote access to subprogram,
2316          --  we use the same identifier as the RAS type, so that the proper
2317          --  name appears in the stub. This type is only retrieved through
2318          --  the RAS type and never by visibility, and is not added to the
2319          --  visibility list (see below).
2320
2321          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
2322            and then Present (Corresponding_Remote_Type (Def_Id))
2323          then
2324             null;
2325
2326          --  A controller component for a type extension overrides the
2327          --  inherited component.
2328
2329          elsif Chars (E) = Name_uController then
2330             null;
2331
2332          --  Case of an implicit operation or derived literal. The new entity
2333          --  hides the implicit one,  which is removed from all visibility,
2334          --  i.e. the entity list of its scope, and homonym chain of its name.
2335
2336          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
2337            or else Is_Internal (E)
2338          then
2339             declare
2340                Prev     : Entity_Id;
2341                Prev_Vis : Entity_Id;
2342                Decl     : constant Node_Id := Parent (E);
2343
2344             begin
2345                --  If E is an implicit declaration, it cannot be the first
2346                --  entity in the scope.
2347
2348                Prev := First_Entity (Current_Scope);
2349                while Present (Prev)
2350                  and then Next_Entity (Prev) /= E
2351                loop
2352                   Next_Entity (Prev);
2353                end loop;
2354
2355                if No (Prev) then
2356
2357                   --  If E is not on the entity chain of the current scope,
2358                   --  it is an implicit declaration in the generic formal
2359                   --  part of a generic subprogram. When analyzing the body,
2360                   --  the generic formals are visible but not on the entity
2361                   --  chain of the subprogram. The new entity will become
2362                   --  the visible one in the body.
2363
2364                   pragma Assert
2365                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
2366                   null;
2367
2368                else
2369                   Set_Next_Entity (Prev, Next_Entity (E));
2370
2371                   if No (Next_Entity (Prev)) then
2372                      Set_Last_Entity (Current_Scope, Prev);
2373                   end if;
2374
2375                   if E = Current_Entity (E) then
2376                      Prev_Vis := Empty;
2377
2378                   else
2379                      Prev_Vis := Current_Entity (E);
2380                      while Homonym (Prev_Vis) /= E loop
2381                         Prev_Vis := Homonym (Prev_Vis);
2382                      end loop;
2383                   end if;
2384
2385                   if Present (Prev_Vis)  then
2386
2387                      --  Skip E in the visibility chain
2388
2389                      Set_Homonym (Prev_Vis, Homonym (E));
2390
2391                   else
2392                      Set_Name_Entity_Id (Chars (E), Homonym (E));
2393                   end if;
2394                end if;
2395             end;
2396
2397          --  This section of code could use a comment ???
2398
2399          elsif Present (Etype (E))
2400            and then Is_Concurrent_Type (Etype (E))
2401            and then E = Def_Id
2402          then
2403             return;
2404
2405          elsif Is_Private_Component_Renaming (Parent (Def_Id)) then
2406             return;
2407
2408          --  In the body or private part of an instance, a type extension
2409          --  may introduce a component with the same name as that of an
2410          --  actual. The legality rule is not enforced, but the semantics
2411          --  of the full type with two components of the same name are not
2412          --  clear at this point ???
2413
2414          elsif In_Instance_Not_Visible  then
2415             null;
2416
2417          --  When compiling a package body, some child units may have become
2418          --  visible. They cannot conflict with local entities that hide them.
2419
2420          elsif Is_Child_Unit (E)
2421            and then In_Open_Scopes (Scope (E))
2422            and then not Is_Immediately_Visible (E)
2423          then
2424             null;
2425
2426          --  Conversely, with front-end inlining we may compile the parent
2427          --  body first, and a child unit subsequently. The context is now
2428          --  the parent spec, and body entities are not visible.
2429
2430          elsif Is_Child_Unit (Def_Id)
2431            and then Is_Package_Body_Entity (E)
2432            and then not In_Package_Body (Current_Scope)
2433          then
2434             null;
2435
2436          --  Case of genuine duplicate declaration
2437
2438          else
2439             Error_Msg_Sloc := Sloc (E);
2440
2441             --  If the previous declaration is an incomplete type declaration
2442             --  this may be an attempt to complete it with a private type.
2443             --  The following avoids confusing cascaded errors.
2444
2445             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
2446               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
2447             then
2448                Error_Msg_N
2449                  ("incomplete type cannot be completed" &
2450                         " with a private declaration",
2451                     Parent (Def_Id));
2452                Set_Is_Immediately_Visible (E, False);
2453                Set_Full_View (E, Def_Id);
2454
2455             elsif Ekind (E) = E_Discriminant
2456               and then Present (Scope (Def_Id))
2457               and then Scope (Def_Id) /= Current_Scope
2458             then
2459                --  An inherited component of a record conflicts with
2460                --  a new discriminant. The discriminant is inserted first
2461                --  in the scope, but the error should be posted on it, not
2462                --  on the component.
2463
2464                Error_Msg_Sloc := Sloc (Def_Id);
2465                Error_Msg_N ("& conflicts with declaration#", E);
2466                return;
2467
2468             --  If the name of the unit appears in its own context clause,
2469             --  a dummy package with the name has already been created, and
2470             --  the error emitted. Try to continue quietly.
2471
2472             elsif Error_Posted (E)
2473               and then Sloc (E) = No_Location
2474               and then Nkind (Parent (E)) = N_Package_Specification
2475               and then Current_Scope = Standard_Standard
2476             then
2477                Set_Scope (Def_Id, Current_Scope);
2478                return;
2479
2480             else
2481                Error_Msg_N ("& conflicts with declaration#", Def_Id);
2482
2483                --  Avoid cascaded messages with duplicate components in
2484                --  derived types.
2485
2486                if Ekind (E) = E_Component
2487                  or else Ekind (E) = E_Discriminant
2488                then
2489                   return;
2490                end if;
2491             end if;
2492
2493             if Nkind (Parent (Parent (Def_Id)))
2494                  = N_Generic_Subprogram_Declaration
2495               and then Def_Id =
2496                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
2497             then
2498                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
2499             end if;
2500
2501             --  If entity is in standard, then we are in trouble, because
2502             --  it means that we have a library package with a duplicated
2503             --  name. That's hard to recover from, so abort!
2504
2505             if S = Standard_Standard then
2506                raise Unrecoverable_Error;
2507
2508             --  Otherwise we continue with the declaration. Having two
2509             --  identical declarations should not cause us too much trouble!
2510
2511             else
2512                null;
2513             end if;
2514          end if;
2515       end if;
2516
2517       --  If we fall through, declaration is OK , or OK enough to continue
2518
2519       --  If Def_Id is a discriminant or a record component we are in the
2520       --  midst of inheriting components in a derived record definition.
2521       --  Preserve their Ekind and Etype.
2522
2523       if Ekind (Def_Id) = E_Discriminant
2524         or else Ekind (Def_Id) = E_Component
2525       then
2526          null;
2527
2528       --  If a type is already set, leave it alone (happens whey a type
2529       --  declaration is reanalyzed following a call to the optimizer)
2530
2531       elsif Present (Etype (Def_Id)) then
2532          null;
2533
2534       --  Otherwise, the kind E_Void insures that premature uses of the entity
2535       --  will be detected. Any_Type insures that no cascaded errors will occur
2536
2537       else
2538          Set_Ekind (Def_Id, E_Void);
2539          Set_Etype (Def_Id, Any_Type);
2540       end if;
2541
2542       --  Inherited discriminants and components in derived record types are
2543       --  immediately visible. Itypes are not.
2544
2545       if Ekind (Def_Id) = E_Discriminant
2546         or else Ekind (Def_Id) = E_Component
2547         or else (No (Corresponding_Remote_Type (Def_Id))
2548                  and then not Is_Itype (Def_Id))
2549       then
2550          Set_Is_Immediately_Visible (Def_Id);
2551          Set_Current_Entity         (Def_Id);
2552       end if;
2553
2554       Set_Homonym       (Def_Id, C);
2555       Append_Entity     (Def_Id, S);
2556       Set_Public_Status (Def_Id);
2557
2558       --  Warn if new entity hides an old one
2559
2560       if Warn_On_Hiding and then Present (C)
2561
2562          --  Don't warn for record components since they always have a well
2563          --  defined scope which does not confuse other uses. Note that in
2564          --  some cases, Ekind has not been set yet.
2565
2566          and then Ekind (C) /= E_Component
2567          and then Ekind (C) /= E_Discriminant
2568          and then Nkind (Parent (C)) /= N_Component_Declaration
2569          and then Ekind (Def_Id) /= E_Component
2570          and then Ekind (Def_Id) /= E_Discriminant
2571          and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
2572
2573          --  Don't warn for one character variables. It is too common to use
2574          --  such variables as locals and will just cause too many false hits.
2575
2576          and then Length_Of_Name (Chars (C)) /= 1
2577
2578          --  Don't warn for non-source eneities
2579
2580          and then Comes_From_Source (C)
2581          and then Comes_From_Source (Def_Id)
2582
2583          --  Don't warn unless entity in question is in extended main source
2584
2585          and then In_Extended_Main_Source_Unit (Def_Id)
2586
2587          --  Finally, the hidden entity must be either immediately visible
2588          --  or use visible (from a used package)
2589
2590          and then
2591            (Is_Immediately_Visible (C)
2592               or else
2593             Is_Potentially_Use_Visible (C))
2594       then
2595          Error_Msg_Sloc := Sloc (C);
2596          Error_Msg_N ("declaration hides &#?", Def_Id);
2597       end if;
2598    end Enter_Name;
2599
2600    --------------------------
2601    -- Explain_Limited_Type --
2602    --------------------------
2603
2604    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
2605       C : Entity_Id;
2606
2607    begin
2608       --  For array, component type must be limited
2609
2610       if Is_Array_Type (T) then
2611          Error_Msg_Node_2 := T;
2612          Error_Msg_NE
2613            ("\component type& of type& is limited", N, Component_Type (T));
2614          Explain_Limited_Type (Component_Type (T), N);
2615
2616       elsif Is_Record_Type (T) then
2617
2618          --  No need for extra messages if explicit limited record
2619
2620          if Is_Limited_Record (Base_Type (T)) then
2621             return;
2622          end if;
2623
2624          --  Otherwise find a limited component. Check only components that
2625          --  come from source, or inherited components that appear in the
2626          --  source of the ancestor.
2627
2628          C := First_Component (T);
2629          while Present (C) loop
2630             if Is_Limited_Type (Etype (C))
2631               and then
2632                 (Comes_From_Source (C)
2633                    or else
2634                      (Present (Original_Record_Component (C))
2635                        and then
2636                          Comes_From_Source (Original_Record_Component (C))))
2637             then
2638                Error_Msg_Node_2 := T;
2639                Error_Msg_NE ("\component& of type& has limited type", N, C);
2640                Explain_Limited_Type (Etype (C), N);
2641                return;
2642             end if;
2643
2644             Next_Component (C);
2645          end loop;
2646
2647          --  The type may be declared explicitly limited, even if no component
2648          --  of it is limited, in which case we fall out of the loop.
2649          return;
2650       end if;
2651    end Explain_Limited_Type;
2652
2653    -----------------
2654    -- Find_Actual --
2655    -----------------
2656
2657    procedure Find_Actual
2658      (N        : Node_Id;
2659       Formal   : out Entity_Id;
2660       Call     : out Node_Id)
2661    is
2662       Parnt  : constant Node_Id := Parent (N);
2663       Actual : Node_Id;
2664
2665    begin
2666       if (Nkind (Parnt) = N_Indexed_Component
2667             or else
2668           Nkind (Parnt) = N_Selected_Component)
2669         and then N = Prefix (Parnt)
2670       then
2671          Find_Actual (Parnt, Formal, Call);
2672          return;
2673
2674       elsif Nkind (Parnt) = N_Parameter_Association
2675         and then N = Explicit_Actual_Parameter (Parnt)
2676       then
2677          Call := Parent (Parnt);
2678
2679       elsif Nkind (Parnt) = N_Procedure_Call_Statement then
2680          Call := Parnt;
2681
2682       else
2683          Formal := Empty;
2684          Call   := Empty;
2685          return;
2686       end if;
2687
2688       --  If we have a call to a subprogram look for the parameter. Note that
2689       --  we exclude overloaded calls, since we don't know enough to be sure
2690       --  of giving the right answer in this case.
2691
2692       if Is_Entity_Name (Name (Call))
2693         and then Present (Entity (Name (Call)))
2694         and then Is_Overloadable (Entity (Name (Call)))
2695         and then not Is_Overloaded (Name (Call))
2696       then
2697          --  Fall here if we are definitely a parameter
2698
2699          Actual := First_Actual (Call);
2700          Formal := First_Formal (Entity (Name (Call)));
2701          while Present (Formal) and then Present (Actual) loop
2702             if Actual = N then
2703                return;
2704             else
2705                Actual := Next_Actual (Actual);
2706                Formal := Next_Formal (Formal);
2707             end if;
2708          end loop;
2709       end if;
2710
2711       --  Fall through here if we did not find matching actual
2712
2713       Formal := Empty;
2714       Call   := Empty;
2715    end Find_Actual;
2716
2717    -------------------------------------
2718    -- Find_Corresponding_Discriminant --
2719    -------------------------------------
2720
2721    function Find_Corresponding_Discriminant
2722      (Id  : Node_Id;
2723       Typ : Entity_Id) return Entity_Id
2724    is
2725       Par_Disc : Entity_Id;
2726       Old_Disc : Entity_Id;
2727       New_Disc : Entity_Id;
2728
2729    begin
2730       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
2731
2732       --  The original type may currently be private, and the discriminant
2733       --  only appear on its full view.
2734
2735       if Is_Private_Type (Scope (Par_Disc))
2736         and then not Has_Discriminants (Scope (Par_Disc))
2737         and then Present (Full_View (Scope (Par_Disc)))
2738       then
2739          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
2740       else
2741          Old_Disc := First_Discriminant (Scope (Par_Disc));
2742       end if;
2743
2744       if Is_Class_Wide_Type (Typ) then
2745          New_Disc := First_Discriminant (Root_Type (Typ));
2746       else
2747          New_Disc := First_Discriminant (Typ);
2748       end if;
2749
2750       while Present (Old_Disc) and then Present (New_Disc) loop
2751          if Old_Disc = Par_Disc  then
2752             return New_Disc;
2753          else
2754             Next_Discriminant (Old_Disc);
2755             Next_Discriminant (New_Disc);
2756          end if;
2757       end loop;
2758
2759       --  Should always find it
2760
2761       raise Program_Error;
2762    end Find_Corresponding_Discriminant;
2763
2764    --------------------------
2765    -- Find_Overlaid_Object --
2766    --------------------------
2767
2768    function Find_Overlaid_Object (N : Node_Id) return Entity_Id is
2769       Expr  : Node_Id;
2770
2771    begin
2772       --  We are looking for one of the two following forms:
2773
2774       --    for X'Address use Y'Address
2775
2776       --  or
2777
2778       --    Const : constant Address := expr;
2779       --    ...
2780       --    for X'Address use Const;
2781
2782       --  In the second case, the expr is either Y'Address, or recursively a
2783       --  constant that eventually references Y'Address.
2784
2785       if Nkind (N) = N_Attribute_Definition_Clause
2786         and then Chars (N) = Name_Address
2787       then
2788          --  This loop checks the form of the expression for Y'Address where Y
2789          --  is an object entity name. The first loop checks the original
2790          --  expression in the attribute definition clause. Subsequent loops
2791          --  check referenced constants.
2792
2793          Expr := Expression (N);
2794          loop
2795             --  Check for Y'Address where Y is an object entity
2796
2797             if Nkind (Expr) = N_Attribute_Reference
2798               and then Attribute_Name (Expr) = Name_Address
2799               and then Is_Entity_Name (Prefix (Expr))
2800               and then Is_Object (Entity (Prefix (Expr)))
2801             then
2802                return Entity (Prefix (Expr));
2803
2804                --  Check for Const where Const is a constant entity
2805
2806             elsif Is_Entity_Name (Expr)
2807               and then Ekind (Entity (Expr)) = E_Constant
2808             then
2809                Expr := Constant_Value (Entity (Expr));
2810
2811             --  Anything else does not need checking
2812
2813             else
2814                exit;
2815             end if;
2816          end loop;
2817       end if;
2818
2819       return Empty;
2820    end Find_Overlaid_Object;
2821
2822    --------------------------------------------
2823    -- Find_Overridden_Synchronized_Primitive --
2824    --------------------------------------------
2825
2826    function Find_Overridden_Synchronized_Primitive
2827      (Def_Id      : Entity_Id;
2828       First_Hom   : Entity_Id;
2829       Ifaces_List : Elist_Id;
2830       In_Scope    : Boolean) return Entity_Id
2831    is
2832       Candidate : Entity_Id := Empty;
2833       Hom       : Entity_Id := Empty;
2834       Iface_Typ : Entity_Id;
2835       Subp      : Entity_Id := Empty;
2836       Tag_Typ   : Entity_Id;
2837
2838       function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean;
2839       --  For an overridden subprogram Subp, check whether the mode of its
2840       --  first parameter is correct depending on the kind of Tag_Typ.
2841
2842       function Matches_Prefixed_View_Profile
2843         (Prim_Params  : List_Id;
2844          Iface_Params : List_Id) return Boolean;
2845       --  Determine whether a subprogram's parameter profile Prim_Params
2846       --  matches that of a potentially overriden interface subprogram
2847       --  Iface_Params. Also determine if the type of first parameter of
2848       --  Iface_Params is an implemented interface.
2849
2850       -----------------------------
2851       -- Has_Correct_Formal_Mode --
2852       -----------------------------
2853
2854       function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean is
2855          Param : Node_Id;
2856
2857       begin
2858          Param := First_Formal (Subp);
2859
2860          --  In order for an entry or a protected procedure to override, the
2861          --  first parameter of the overridden routine must be of mode "out",
2862          --  "in out" or access-to-variable.
2863
2864          if (Ekind (Subp) = E_Entry
2865                or else Ekind (Subp) = E_Procedure)
2866            and then Is_Protected_Type (Tag_Typ)
2867            and then Ekind (Param) /= E_In_Out_Parameter
2868            and then Ekind (Param) /= E_Out_Parameter
2869            and then Nkind (Parameter_Type (Parent (Param))) /=
2870                       N_Access_Definition
2871          then
2872             return False;
2873          end if;
2874
2875          --  All other cases are OK since a task entry or routine does not
2876          --  have a restriction on the mode of the first parameter of the
2877          --  overridden interface routine.
2878
2879          return True;
2880       end Has_Correct_Formal_Mode;
2881
2882       -----------------------------------
2883       -- Matches_Prefixed_View_Profile --
2884       -----------------------------------
2885
2886       function Matches_Prefixed_View_Profile
2887         (Prim_Params  : List_Id;
2888          Iface_Params : List_Id) return Boolean
2889       is
2890          Iface_Id     : Entity_Id;
2891          Iface_Param  : Node_Id;
2892          Iface_Typ    : Entity_Id;
2893          Prim_Id      : Entity_Id;
2894          Prim_Param   : Node_Id;
2895          Prim_Typ     : Entity_Id;
2896
2897          function Is_Implemented (Iface : Entity_Id) return Boolean;
2898          --  Determine if Iface is implemented by the current task or
2899          --  protected type.
2900
2901          --------------------
2902          -- Is_Implemented --
2903          --------------------
2904
2905          function Is_Implemented (Iface : Entity_Id) return Boolean is
2906             Iface_Elmt : Elmt_Id;
2907
2908          begin
2909             Iface_Elmt := First_Elmt (Ifaces_List);
2910             while Present (Iface_Elmt) loop
2911                if Node (Iface_Elmt) = Iface then
2912                   return True;
2913                end if;
2914
2915                Next_Elmt (Iface_Elmt);
2916             end loop;
2917
2918             return False;
2919          end Is_Implemented;
2920
2921       --  Start of processing for Matches_Prefixed_View_Profile
2922
2923       begin
2924          Iface_Param := First (Iface_Params);
2925          Iface_Typ   := Find_Parameter_Type (Iface_Param);
2926          Prim_Param  := First (Prim_Params);
2927
2928          --  The first parameter of the potentially overriden subprogram
2929          --  must be an interface implemented by Prim.
2930
2931          if not Is_Interface (Iface_Typ)
2932            or else not Is_Implemented (Iface_Typ)
2933          then
2934             return False;
2935          end if;
2936
2937          --  The checks on the object parameters are done, move onto the rest
2938          --  of the parameters.
2939
2940          if not In_Scope then
2941             Prim_Param := Next (Prim_Param);
2942          end if;
2943
2944          Iface_Param := Next (Iface_Param);
2945          while Present (Iface_Param) and then Present (Prim_Param) loop
2946             Iface_Id  := Defining_Identifier (Iface_Param);
2947             Iface_Typ := Find_Parameter_Type (Iface_Param);
2948             Prim_Id   := Defining_Identifier (Prim_Param);
2949             Prim_Typ  := Find_Parameter_Type (Prim_Param);
2950
2951             --  Case of multiple interface types inside a parameter profile
2952
2953             --     (Obj_Param : in out Iface; ...; Param : Iface)
2954
2955             --  If the interface type is implemented, then the matching type
2956             --  in the primitive should be the implementing record type.
2957
2958             if Ekind (Iface_Typ) = E_Record_Type
2959               and then Is_Interface (Iface_Typ)
2960               and then Is_Implemented (Iface_Typ)
2961             then
2962                if Prim_Typ /= Tag_Typ then
2963                   return False;
2964                end if;
2965
2966             --  The two parameters must be both mode and subtype conformant
2967
2968             elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
2969               or else
2970                 not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
2971             then
2972                return False;
2973             end if;
2974
2975             Next (Iface_Param);
2976             Next (Prim_Param);
2977          end loop;
2978
2979          --  One of the two lists contains more parameters than the other
2980
2981          if Present (Iface_Param) or else Present (Prim_Param) then
2982             return False;
2983          end if;
2984
2985          return True;
2986       end Matches_Prefixed_View_Profile;
2987
2988    --  Start of processing for Find_Overridden_Synchronized_Primitive
2989
2990    begin
2991       --  At this point the caller should have collected the interfaces
2992       --  implemented by the synchronized type.
2993
2994       pragma Assert (Present (Ifaces_List));
2995
2996       --  Find the tagged type to which subprogram Def_Id is primitive. If the
2997       --  subprogram was declared within a protected or a task type, the type
2998       --  is the scope itself, otherwise it is the type of the first parameter.
2999
3000       if In_Scope then
3001          Tag_Typ := Scope (Def_Id);
3002
3003       elsif Present (First_Formal (Def_Id)) then
3004          Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id)));
3005
3006       --  A parameterless subprogram which is declared outside a synchronized
3007       --  type cannot act as a primitive, thus it cannot override anything.
3008
3009       else
3010          return Empty;
3011       end if;
3012
3013       --  Traverse the homonym chain, looking at a potentially overriden
3014       --  subprogram that belongs to an implemented interface.
3015
3016       Hom := First_Hom;
3017       while Present (Hom) loop
3018          Subp := Hom;
3019
3020          --  Entries can override abstract or null interface procedures
3021
3022          if Ekind (Def_Id) = E_Entry
3023            and then Ekind (Subp) = E_Procedure
3024            and then Nkind (Parent (Subp)) = N_Procedure_Specification
3025            and then (Is_Abstract_Subprogram (Subp)
3026                        or else Null_Present (Parent (Subp)))
3027          then
3028             while Present (Alias (Subp)) loop
3029                Subp := Alias (Subp);
3030             end loop;
3031
3032             if Matches_Prefixed_View_Profile
3033                  (Parameter_Specifications (Parent (Def_Id)),
3034                   Parameter_Specifications (Parent (Subp)))
3035             then
3036                Candidate := Subp;
3037
3038                --  Absolute match
3039
3040                if Has_Correct_Formal_Mode (Candidate) then
3041                   return Candidate;
3042                end if;
3043             end if;
3044
3045          --  Procedures can override abstract or null interface procedures
3046
3047          elsif Ekind (Def_Id) = E_Procedure
3048            and then Ekind (Subp) = E_Procedure
3049            and then Nkind (Parent (Subp)) = N_Procedure_Specification
3050            and then (Is_Abstract_Subprogram (Subp)
3051                        or else Null_Present (Parent (Subp)))
3052            and then Matches_Prefixed_View_Profile
3053                       (Parameter_Specifications (Parent (Def_Id)),
3054                        Parameter_Specifications (Parent (Subp)))
3055          then
3056             Candidate := Subp;
3057
3058             --  Absolute match
3059
3060             if Has_Correct_Formal_Mode (Candidate) then
3061                return Candidate;
3062             end if;
3063
3064          --  Functions can override abstract interface functions
3065
3066          elsif Ekind (Def_Id) = E_Function
3067            and then Ekind (Subp) = E_Function
3068            and then Nkind (Parent (Subp)) = N_Function_Specification
3069            and then Is_Abstract_Subprogram (Subp)
3070            and then Matches_Prefixed_View_Profile
3071                       (Parameter_Specifications (Parent (Def_Id)),
3072                        Parameter_Specifications (Parent (Subp)))
3073            and then Etype (Result_Definition (Parent (Def_Id))) =
3074                     Etype (Result_Definition (Parent (Subp)))
3075          then
3076             return Subp;
3077          end if;
3078
3079          Hom := Homonym (Hom);
3080       end loop;
3081
3082       --  After examining all candidates for overriding, we are left with
3083       --  the best match which is a mode incompatible interface routine.
3084       --  Do not emit an error if the Expander is active since this error
3085       --  will be detected later on after all concurrent types are expanded
3086       --  and all wrappers are built. This check is meant for spec-only
3087       --  compilations.
3088
3089       if Present (Candidate)
3090         and then not Expander_Active
3091       then
3092          Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate)));
3093
3094          --  Def_Id is primitive of a protected type, declared inside the type,
3095          --  and the candidate is primitive of a limited or synchronized
3096          --  interface.
3097
3098          if In_Scope
3099            and then Is_Protected_Type (Tag_Typ)
3100            and then
3101              (Is_Limited_Interface (Iface_Typ)
3102                 or else Is_Protected_Interface (Iface_Typ)
3103                 or else Is_Synchronized_Interface (Iface_Typ)
3104                 or else Is_Task_Interface (Iface_Typ))
3105          then
3106             --  Must reword this message, comma before to in -gnatj mode ???
3107
3108             Error_Msg_NE
3109               ("first formal of & must be of mode `OUT`, `IN OUT` or " &
3110                "access-to-variable", Tag_Typ, Candidate);
3111             Error_Msg_N
3112               ("\to be overridden by protected procedure or entry " &
3113                "(RM 9.4(11.9/2))", Tag_Typ);
3114          end if;
3115       end if;
3116
3117       return Candidate;
3118    end Find_Overridden_Synchronized_Primitive;
3119
3120    -------------------------
3121    -- Find_Parameter_Type --
3122    -------------------------
3123
3124    function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
3125    begin
3126       if Nkind (Param) /= N_Parameter_Specification then
3127          return Empty;
3128
3129       elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
3130          return Etype (Subtype_Mark (Parameter_Type (Param)));
3131
3132       else
3133          return Etype (Parameter_Type (Param));
3134       end if;
3135    end Find_Parameter_Type;
3136
3137    -----------------------------
3138    -- Find_Static_Alternative --
3139    -----------------------------
3140
3141    function Find_Static_Alternative (N : Node_Id) return Node_Id is
3142       Expr   : constant Node_Id := Expression (N);
3143       Val    : constant Uint    := Expr_Value (Expr);
3144       Alt    : Node_Id;
3145       Choice : Node_Id;
3146
3147    begin
3148       Alt := First (Alternatives (N));
3149
3150       Search : loop
3151          if Nkind (Alt) /= N_Pragma then
3152             Choice := First (Discrete_Choices (Alt));
3153             while Present (Choice) loop
3154
3155                --  Others choice, always matches
3156
3157                if Nkind (Choice) = N_Others_Choice then
3158                   exit Search;
3159
3160                --  Range, check if value is in the range
3161
3162                elsif Nkind (Choice) = N_Range then
3163                   exit Search when
3164                     Val >= Expr_Value (Low_Bound (Choice))
3165                       and then
3166                     Val <= Expr_Value (High_Bound (Choice));
3167
3168                --  Choice is a subtype name. Note that we know it must
3169                --  be a static subtype, since otherwise it would have
3170                --  been diagnosed as illegal.
3171
3172                elsif Is_Entity_Name (Choice)
3173                  and then Is_Type (Entity (Choice))
3174                then
3175                   exit Search when Is_In_Range (Expr, Etype (Choice));
3176
3177                --  Choice is a subtype indication
3178
3179                elsif Nkind (Choice) = N_Subtype_Indication then
3180                   declare
3181                      C : constant Node_Id := Constraint (Choice);
3182                      R : constant Node_Id := Range_Expression (C);
3183
3184                   begin
3185                      exit Search when
3186                        Val >= Expr_Value (Low_Bound (R))
3187                          and then
3188                        Val <= Expr_Value (High_Bound (R));
3189                   end;
3190
3191                --  Choice is a simple expression
3192
3193                else
3194                   exit Search when Val = Expr_Value (Choice);
3195                end if;
3196
3197                Next (Choice);
3198             end loop;
3199          end if;
3200
3201          Next (Alt);
3202          pragma Assert (Present (Alt));
3203       end loop Search;
3204
3205       --  The above loop *must* terminate by finding a match, since
3206       --  we know the case statement is valid, and the value of the
3207       --  expression is known at compile time. When we fall out of
3208       --  the loop, Alt points to the alternative that we know will
3209       --  be selected at run time.
3210
3211       return Alt;
3212    end Find_Static_Alternative;
3213
3214    ------------------
3215    -- First_Actual --
3216    ------------------
3217
3218    function First_Actual (Node : Node_Id) return Node_Id is
3219       N : Node_Id;
3220
3221    begin
3222       if No (Parameter_Associations (Node)) then
3223          return Empty;
3224       end if;
3225
3226       N := First (Parameter_Associations (Node));
3227
3228       if Nkind (N) = N_Parameter_Association then
3229          return First_Named_Actual (Node);
3230       else
3231          return N;
3232       end if;
3233    end First_Actual;
3234
3235    -------------------------
3236    -- Full_Qualified_Name --
3237    -------------------------
3238
3239    function Full_Qualified_Name (E : Entity_Id) return String_Id is
3240       Res : String_Id;
3241       pragma Warnings (Off, Res);
3242
3243       function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
3244       --  Compute recursively the qualified name without NUL at the end
3245
3246       ----------------------------------
3247       -- Internal_Full_Qualified_Name --
3248       ----------------------------------
3249
3250       function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
3251          Ent         : Entity_Id := E;
3252          Parent_Name : String_Id := No_String;
3253
3254       begin
3255          --  Deals properly with child units
3256
3257          if Nkind (Ent) = N_Defining_Program_Unit_Name then
3258             Ent := Defining_Identifier (Ent);
3259          end if;
3260
3261          --  Compute qualification recursively (only "Standard" has no scope)
3262
3263          if Present (Scope (Scope (Ent))) then
3264             Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
3265          end if;
3266
3267          --  Every entity should have a name except some expanded blocks
3268          --  don't bother about those.
3269
3270          if Chars (Ent) = No_Name then
3271             return Parent_Name;
3272          end if;
3273
3274          --  Add a period between Name and qualification
3275
3276          if Parent_Name /= No_String then
3277             Start_String (Parent_Name);
3278             Store_String_Char (Get_Char_Code ('.'));
3279
3280          else
3281             Start_String;
3282          end if;
3283
3284          --  Generates the entity name in upper case
3285
3286          Get_Decoded_Name_String (Chars (Ent));
3287          Set_All_Upper_Case;
3288          Store_String_Chars (Name_Buffer (1 .. Name_Len));
3289          return End_String;
3290       end Internal_Full_Qualified_Name;
3291
3292    --  Start of processing for Full_Qualified_Name
3293
3294    begin
3295       Res := Internal_Full_Qualified_Name (E);
3296       Store_String_Char (Get_Char_Code (ASCII.nul));
3297       return End_String;
3298    end Full_Qualified_Name;
3299
3300    -----------------------
3301    -- Gather_Components --
3302    -----------------------
3303
3304    procedure Gather_Components
3305      (Typ           : Entity_Id;
3306       Comp_List     : Node_Id;
3307       Governed_By   : List_Id;
3308       Into          : Elist_Id;
3309       Report_Errors : out Boolean)
3310    is
3311       Assoc           : Node_Id;
3312       Variant         : Node_Id;
3313       Discrete_Choice : Node_Id;
3314       Comp_Item       : Node_Id;
3315
3316       Discrim       : Entity_Id;
3317       Discrim_Name  : Node_Id;
3318       Discrim_Value : Node_Id;
3319
3320    begin
3321       Report_Errors := False;
3322
3323       if No (Comp_List) or else Null_Present (Comp_List) then
3324          return;
3325
3326       elsif Present (Component_Items (Comp_List)) then
3327          Comp_Item := First (Component_Items (Comp_List));
3328
3329       else
3330          Comp_Item := Empty;
3331       end if;
3332
3333       while Present (Comp_Item) loop
3334
3335          --  Skip the tag of a tagged record, the interface tags, as well
3336          --  as all items that are not user components (anonymous types,
3337          --  rep clauses, Parent field, controller field).
3338
3339          if Nkind (Comp_Item) = N_Component_Declaration then
3340             declare
3341                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
3342             begin
3343                if not Is_Tag (Comp)
3344                  and then Chars (Comp) /= Name_uParent
3345                  and then Chars (Comp) /= Name_uController
3346                then
3347                   Append_Elmt (Comp, Into);
3348                end if;
3349             end;
3350          end if;
3351
3352          Next (Comp_Item);
3353       end loop;
3354
3355       if No (Variant_Part (Comp_List)) then
3356          return;
3357       else
3358          Discrim_Name := Name (Variant_Part (Comp_List));
3359          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
3360       end if;
3361
3362       --  Look for the discriminant that governs this variant part.
3363       --  The discriminant *must* be in the Governed_By List
3364
3365       Assoc := First (Governed_By);
3366       Find_Constraint : loop
3367          Discrim := First (Choices (Assoc));
3368          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
3369            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
3370                       and then
3371                     Chars (Corresponding_Discriminant (Entity (Discrim)))
3372                          = Chars  (Discrim_Name))
3373            or else Chars (Original_Record_Component (Entity (Discrim)))
3374                          = Chars (Discrim_Name);
3375
3376          if No (Next (Assoc)) then
3377             if not Is_Constrained (Typ)
3378               and then Is_Derived_Type (Typ)
3379               and then Present (Stored_Constraint (Typ))
3380             then
3381                --  If the type is a tagged type with inherited discriminants,
3382                --  use the stored constraint on the parent in order to find
3383                --  the values of discriminants that are otherwise hidden by an
3384                --  explicit constraint. Renamed discriminants are handled in
3385                --  the code above.
3386
3387                --  If several parent discriminants are renamed by a single
3388                --  discriminant of the derived type, the call to obtain the
3389                --  Corresponding_Discriminant field only retrieves the last
3390                --  of them. We recover the constraint on the others from the
3391                --  Stored_Constraint as well.
3392
3393                declare
3394                   D : Entity_Id;
3395                   C : Elmt_Id;
3396
3397                begin
3398                   D := First_Discriminant (Etype (Typ));
3399                   C := First_Elmt (Stored_Constraint (Typ));
3400                   while Present (D) and then Present (C) loop
3401                      if Chars (Discrim_Name) = Chars (D) then
3402                         if Is_Entity_Name (Node (C))
3403                           and then Entity (Node (C)) = Entity (Discrim)
3404                         then
3405                            --  D is renamed by Discrim, whose value is given in
3406                            --  Assoc.
3407
3408                            null;
3409
3410                         else
3411                            Assoc :=
3412                              Make_Component_Association (Sloc (Typ),
3413                                New_List
3414                                  (New_Occurrence_Of (D, Sloc (Typ))),
3415                                   Duplicate_Subexpr_No_Checks (Node (C)));
3416                         end if;
3417                         exit Find_Constraint;
3418                      end if;
3419
3420                      Next_Discriminant (D);
3421                      Next_Elmt (C);
3422                   end loop;
3423                end;
3424             end if;
3425          end if;
3426
3427          if No (Next (Assoc)) then
3428             Error_Msg_NE (" missing value for discriminant&",
3429               First (Governed_By), Discrim_Name);
3430             Report_Errors := True;
3431             return;
3432          end if;
3433
3434          Next (Assoc);
3435       end loop Find_Constraint;
3436
3437       Discrim_Value := Expression (Assoc);
3438
3439       if not Is_OK_Static_Expression (Discrim_Value) then
3440          Error_Msg_FE
3441            ("value for discriminant & must be static!",
3442             Discrim_Value, Discrim);
3443          Why_Not_Static (Discrim_Value);
3444          Report_Errors := True;
3445          return;
3446       end if;
3447
3448       Search_For_Discriminant_Value : declare
3449          Low  : Node_Id;
3450          High : Node_Id;
3451
3452          UI_High          : Uint;
3453          UI_Low           : Uint;
3454          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
3455
3456       begin
3457          Find_Discrete_Value : while Present (Variant) loop
3458             Discrete_Choice := First (Discrete_Choices (Variant));
3459             while Present (Discrete_Choice) loop
3460
3461                exit Find_Discrete_Value when
3462                  Nkind (Discrete_Choice) = N_Others_Choice;
3463
3464                Get_Index_Bounds (Discrete_Choice, Low, High);
3465
3466                UI_Low  := Expr_Value (Low);
3467                UI_High := Expr_Value (High);
3468
3469                exit Find_Discrete_Value when
3470                  UI_Low <= UI_Discrim_Value
3471                    and then
3472                  UI_High >= UI_Discrim_Value;
3473
3474                Next (Discrete_Choice);
3475             end loop;
3476
3477             Next_Non_Pragma (Variant);
3478          end loop Find_Discrete_Value;
3479       end Search_For_Discriminant_Value;
3480
3481       if No (Variant) then
3482          Error_Msg_NE
3483            ("value of discriminant & is out of range", Discrim_Value, Discrim);
3484          Report_Errors := True;
3485          return;
3486       end  if;
3487
3488       --  If we have found the corresponding choice, recursively add its
3489       --  components to the Into list.
3490
3491       Gather_Components (Empty,
3492         Component_List (Variant), Governed_By, Into, Report_Errors);
3493    end Gather_Components;
3494
3495    ------------------------
3496    -- Get_Actual_Subtype --
3497    ------------------------
3498
3499    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
3500       Typ  : constant Entity_Id := Etype (N);
3501       Utyp : Entity_Id := Underlying_Type (Typ);
3502       Decl : Node_Id;
3503       Atyp : Entity_Id;
3504
3505    begin
3506       if No (Utyp) then
3507          Utyp := Typ;
3508       end if;
3509
3510       --  If what we have is an identifier that references a subprogram
3511       --  formal, or a variable or constant object, then we get the actual
3512       --  subtype from the referenced entity if one has been built.
3513
3514       if Nkind (N) = N_Identifier
3515         and then
3516           (Is_Formal (Entity (N))
3517             or else Ekind (Entity (N)) = E_Constant
3518             or else Ekind (Entity (N)) = E_Variable)
3519         and then Present (Actual_Subtype (Entity (N)))
3520       then
3521          return Actual_Subtype (Entity (N));
3522
3523       --  Actual subtype of unchecked union is always itself. We never need
3524       --  the "real" actual subtype. If we did, we couldn't get it anyway
3525       --  because the discriminant is not available. The restrictions on
3526       --  Unchecked_Union are designed to make sure that this is OK.
3527
3528       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
3529          return Typ;
3530
3531       --  Here for the unconstrained case, we must find actual subtype
3532       --  No actual subtype is available, so we must build it on the fly.
3533
3534       --  Checking the type, not the underlying type, for constrainedness
3535       --  seems to be necessary. Maybe all the tests should be on the type???
3536
3537       elsif (not Is_Constrained (Typ))
3538            and then (Is_Array_Type (Utyp)
3539                       or else (Is_Record_Type (Utyp)
3540                                 and then Has_Discriminants (Utyp)))
3541            and then not Has_Unknown_Discriminants (Utyp)
3542            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
3543       then
3544          --  Nothing to do if in default expression
3545
3546          if In_Default_Expression then
3547             return Typ;
3548
3549          elsif Is_Private_Type (Typ)
3550            and then not Has_Discriminants (Typ)
3551          then
3552             --  If the type has no discriminants, there is no subtype to
3553             --  build, even if the underlying type is discriminated.
3554
3555             return Typ;
3556
3557          --  Else build the actual subtype
3558
3559          else
3560             Decl := Build_Actual_Subtype (Typ, N);
3561             Atyp := Defining_Identifier (Decl);
3562
3563             --  If Build_Actual_Subtype generated a new declaration then use it
3564
3565             if Atyp /= Typ then
3566
3567                --  The actual subtype is an Itype, so analyze the declaration,
3568                --  but do not attach it to the tree, to get the type defined.
3569
3570                Set_Parent (Decl, N);
3571                Set_Is_Itype (Atyp);
3572                Analyze (Decl, Suppress => All_Checks);
3573                Set_Associated_Node_For_Itype (Atyp, N);
3574                Set_Has_Delayed_Freeze (Atyp, False);
3575
3576                --  We need to freeze the actual subtype immediately. This is
3577                --  needed, because otherwise this Itype will not get frozen
3578                --  at all, and it is always safe to freeze on creation because
3579                --  any associated types must be frozen at this point.
3580
3581                Freeze_Itype (Atyp, N);
3582                return Atyp;
3583
3584             --  Otherwise we did not build a declaration, so return original
3585
3586             else
3587                return Typ;
3588             end if;
3589          end if;
3590
3591       --  For all remaining cases, the actual subtype is the same as
3592       --  the nominal type.
3593
3594       else
3595          return Typ;
3596       end if;
3597    end Get_Actual_Subtype;
3598
3599    -------------------------------------
3600    -- Get_Actual_Subtype_If_Available --
3601    -------------------------------------
3602
3603    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
3604       Typ  : constant Entity_Id := Etype (N);
3605
3606    begin
3607       --  If what we have is an identifier that references a subprogram
3608       --  formal, or a variable or constant object, then we get the actual
3609       --  subtype from the referenced entity if one has been built.
3610
3611       if Nkind (N) = N_Identifier
3612         and then
3613           (Is_Formal (Entity (N))
3614             or else Ekind (Entity (N)) = E_Constant
3615             or else Ekind (Entity (N)) = E_Variable)
3616         and then Present (Actual_Subtype (Entity (N)))
3617       then
3618          return Actual_Subtype (Entity (N));
3619
3620       --  Otherwise the Etype of N is returned unchanged
3621
3622       else
3623          return Typ;
3624       end if;
3625    end Get_Actual_Subtype_If_Available;
3626
3627    -------------------------------
3628    -- Get_Default_External_Name --
3629    -------------------------------
3630
3631    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
3632    begin
3633       Get_Decoded_Name_String (Chars (E));
3634
3635       if Opt.External_Name_Imp_Casing = Uppercase then
3636          Set_Casing (All_Upper_Case);
3637       else
3638          Set_Casing (All_Lower_Case);
3639       end if;
3640
3641       return
3642         Make_String_Literal (Sloc (E),
3643           Strval => String_From_Name_Buffer);
3644    end Get_Default_External_Name;
3645
3646    ---------------------------
3647    -- Get_Enum_Lit_From_Pos --
3648    ---------------------------
3649
3650    function Get_Enum_Lit_From_Pos
3651      (T   : Entity_Id;
3652       Pos : Uint;
3653       Loc : Source_Ptr) return Node_Id
3654    is
3655       Lit : Node_Id;
3656
3657    begin
3658       --  In the case where the literal is of type Character, Wide_Character
3659       --  or Wide_Wide_Character or of a type derived from them, there needs
3660       --  to be some special handling since there is no explicit chain of
3661       --  literals to search. Instead, an N_Character_Literal node is created
3662       --  with the appropriate Char_Code and Chars fields.
3663
3664       if Root_Type (T) = Standard_Character
3665         or else Root_Type (T) = Standard_Wide_Character
3666         or else Root_Type (T) = Standard_Wide_Wide_Character
3667       then
3668          Set_Character_Literal_Name (UI_To_CC (Pos));
3669          return
3670            Make_Character_Literal (Loc,
3671              Chars              => Name_Find,
3672              Char_Literal_Value => Pos);
3673
3674       --  For all other cases, we have a complete table of literals, and
3675       --  we simply iterate through the chain of literal until the one
3676       --  with the desired position value is found.
3677       --
3678
3679       else
3680          Lit := First_Literal (Base_Type (T));
3681          for J in 1 .. UI_To_Int (Pos) loop
3682             Next_Literal (Lit);
3683          end loop;
3684
3685          return New_Occurrence_Of (Lit, Loc);
3686       end if;
3687    end Get_Enum_Lit_From_Pos;
3688
3689    ------------------------
3690    -- Get_Generic_Entity --
3691    ------------------------
3692
3693    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
3694       Ent : constant Entity_Id := Entity (Name (N));
3695    begin
3696       if Present (Renamed_Object (Ent)) then
3697          return Renamed_Object (Ent);
3698       else
3699          return Ent;
3700       end if;
3701    end Get_Generic_Entity;
3702
3703    ----------------------
3704    -- Get_Index_Bounds --
3705    ----------------------
3706
3707    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
3708       Kind : constant Node_Kind := Nkind (N);
3709       R    : Node_Id;
3710
3711    begin
3712       if Kind = N_Range then
3713          L := Low_Bound (N);
3714          H := High_Bound (N);
3715
3716       elsif Kind = N_Subtype_Indication then
3717          R := Range_Expression (Constraint (N));
3718
3719          if R = Error then
3720             L := Error;
3721             H := Error;
3722             return;
3723
3724          else
3725             L := Low_Bound  (Range_Expression (Constraint (N)));
3726             H := High_Bound (Range_Expression (Constraint (N)));
3727          end if;
3728
3729       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
3730          if Error_Posted (Scalar_Range (Entity (N))) then
3731             L := Error;
3732             H := Error;
3733
3734          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
3735             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
3736
3737          else
3738             L := Low_Bound  (Scalar_Range (Entity (N)));
3739             H := High_Bound (Scalar_Range (Entity (N)));
3740          end if;
3741
3742       else
3743          --  N is an expression, indicating a range with one value
3744
3745          L := N;
3746          H := N;
3747       end if;
3748    end Get_Index_Bounds;
3749
3750    ----------------------------------
3751    -- Get_Library_Unit_Name_string --
3752    ----------------------------------
3753
3754    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
3755       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
3756
3757    begin
3758       Get_Unit_Name_String (Unit_Name_Id);
3759
3760       --  Remove seven last character (" (spec)" or " (body)")
3761
3762       Name_Len := Name_Len - 7;
3763       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
3764    end Get_Library_Unit_Name_String;
3765
3766    ------------------------
3767    -- Get_Name_Entity_Id --
3768    ------------------------
3769
3770    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
3771    begin
3772       return Entity_Id (Get_Name_Table_Info (Id));
3773    end Get_Name_Entity_Id;
3774
3775    -------------------
3776    -- Get_Pragma_Id --
3777    -------------------
3778
3779    function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
3780    begin
3781       return Get_Pragma_Id (Pragma_Name (N));
3782    end Get_Pragma_Id;
3783
3784    ---------------------------
3785    -- Get_Referenced_Object --
3786    ---------------------------
3787
3788    function Get_Referenced_Object (N : Node_Id) return Node_Id is
3789       R : Node_Id;
3790
3791    begin
3792       R := N;
3793       while Is_Entity_Name (R)
3794         and then Present (Renamed_Object (Entity (R)))
3795       loop
3796          R := Renamed_Object (Entity (R));
3797       end loop;
3798
3799       return R;
3800    end Get_Referenced_Object;
3801
3802    ------------------------
3803    -- Get_Renamed_Entity --
3804    ------------------------
3805
3806    function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
3807       R : Entity_Id;
3808
3809    begin
3810       R := E;
3811       while Present (Renamed_Entity (R)) loop
3812          R := Renamed_Entity (R);
3813       end loop;
3814
3815       return R;
3816    end Get_Renamed_Entity;
3817
3818    -------------------------
3819    -- Get_Subprogram_Body --
3820    -------------------------
3821
3822    function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
3823       Decl : Node_Id;
3824
3825    begin
3826       Decl := Unit_Declaration_Node (E);
3827
3828       if Nkind (Decl) = N_Subprogram_Body then
3829          return Decl;
3830
3831       --  The below comment is bad, because it is possible for
3832       --  Nkind (Decl) to be an N_Subprogram_Body_Stub ???
3833
3834       else           --  Nkind (Decl) = N_Subprogram_Declaration
3835
3836          if Present (Corresponding_Body (Decl)) then
3837             return Unit_Declaration_Node (Corresponding_Body (Decl));
3838
3839          --  Imported subprogram case
3840
3841          else
3842             return Empty;
3843          end if;
3844       end if;
3845    end Get_Subprogram_Body;
3846
3847    ---------------------------
3848    -- Get_Subprogram_Entity --
3849    ---------------------------
3850
3851    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
3852       Nam  : Node_Id;
3853       Proc : Entity_Id;
3854
3855    begin
3856       if Nkind (Nod) = N_Accept_Statement then
3857          Nam := Entry_Direct_Name (Nod);
3858
3859       --  For an entry call, the prefix of the call is a selected component.
3860       --  Need additional code for internal calls ???
3861
3862       elsif Nkind (Nod) = N_Entry_Call_Statement then
3863          if Nkind (Name (Nod)) = N_Selected_Component then
3864             Nam := Entity (Selector_Name (Name (Nod)));
3865          else
3866             Nam := Empty;
3867          end if;
3868
3869       else
3870          Nam := Name (Nod);
3871       end if;
3872
3873       if Nkind (Nam) = N_Explicit_Dereference then
3874          Proc := Etype (Prefix (Nam));
3875       elsif Is_Entity_Name (Nam) then
3876          Proc := Entity (Nam);
3877       else
3878          return Empty;
3879       end if;
3880
3881       if Is_Object (Proc) then
3882          Proc := Etype (Proc);
3883       end if;
3884
3885       if Ekind (Proc) = E_Access_Subprogram_Type then
3886          Proc := Directly_Designated_Type (Proc);
3887       end if;
3888
3889       if not Is_Subprogram (Proc)
3890         and then Ekind (Proc) /= E_Subprogram_Type
3891       then
3892          return Empty;
3893       else
3894          return Proc;
3895       end if;
3896    end Get_Subprogram_Entity;
3897
3898    -----------------------------
3899    -- Get_Task_Body_Procedure --
3900    -----------------------------
3901
3902    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
3903    begin
3904       --  Note: A task type may be the completion of a private type with
3905       --  discriminants. when performing elaboration checks on a task
3906       --  declaration, the current view of the type may be the private one,
3907       --  and the procedure that holds the body of the task is held in its
3908       --  underlying type.
3909
3910       --  This is an odd function, why not have Task_Body_Procedure do
3911       --  the following digging???
3912
3913       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
3914    end Get_Task_Body_Procedure;
3915
3916    -----------------------------
3917    -- Has_Abstract_Interfaces --
3918    -----------------------------
3919
3920    function Has_Abstract_Interfaces
3921      (T             : Entity_Id;
3922       Use_Full_View : Boolean := True) return Boolean
3923    is
3924       Typ : Entity_Id;
3925
3926    begin
3927       --  Handle concurrent types
3928
3929       if Is_Concurrent_Type (T) then
3930          Typ := Corresponding_Record_Type (T);
3931       else
3932          Typ := T;
3933       end if;
3934
3935       if not Present (Typ)
3936         or else not Is_Tagged_Type (Typ)
3937       then
3938          return False;
3939       end if;
3940
3941       pragma Assert (Is_Record_Type (Typ));
3942
3943       --  Handle private types
3944
3945       if Use_Full_View
3946         and then Present (Full_View (Typ))
3947       then
3948          Typ := Full_View (Typ);
3949       end if;
3950
3951       --  Handle concurrent record types
3952
3953       if Is_Concurrent_Record_Type (Typ)
3954         and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
3955       then
3956          return True;
3957       end if;
3958
3959       loop
3960          if Is_Interface (Typ)
3961            or else
3962              (Is_Record_Type (Typ)
3963                and then Present (Abstract_Interfaces (Typ))
3964                and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
3965          then
3966             return True;
3967          end if;
3968
3969          exit when Etype (Typ) = Typ
3970
3971             --  Handle private types
3972
3973             or else (Present (Full_View (Etype (Typ)))
3974                        and then Full_View (Etype (Typ)) = Typ)
3975
3976             --  Protect the frontend against wrong source with cyclic
3977             --  derivations
3978
3979             or else Etype (Typ) = T;
3980
3981          --  Climb to the ancestor type handling private types
3982
3983          if Present (Full_View (Etype (Typ))) then
3984             Typ := Full_View (Etype (Typ));
3985          else
3986             Typ := Etype (Typ);
3987          end if;
3988       end loop;
3989
3990       return False;
3991    end Has_Abstract_Interfaces;
3992
3993    -----------------------
3994    -- Has_Access_Values --
3995    -----------------------
3996
3997    function Has_Access_Values (T : Entity_Id) return Boolean is
3998       Typ : constant Entity_Id := Underlying_Type (T);
3999
4000    begin
4001       --  Case of a private type which is not completed yet. This can only
4002       --  happen in the case of a generic format type appearing directly, or
4003       --  as a component of the type to which this function is being applied
4004       --  at the top level. Return False in this case, since we certainly do
4005       --  not know that the type contains access types.
4006
4007       if No (Typ) then
4008          return False;
4009
4010       elsif Is_Access_Type (Typ) then
4011          return True;
4012
4013       elsif Is_Array_Type (Typ) then
4014          return Has_Access_Values (Component_Type (Typ));
4015
4016       elsif Is_Record_Type (Typ) then
4017          declare
4018             Comp : Entity_Id;
4019
4020          begin
4021             Comp := First_Component_Or_Discriminant (Typ);
4022             while Present (Comp) loop
4023                if Has_Access_Values (Etype (Comp)) then
4024                   return True;
4025                end if;
4026
4027                Next_Component_Or_Discriminant (Comp);
4028             end loop;
4029          end;
4030
4031          return False;
4032
4033       else
4034          return False;
4035       end if;
4036    end Has_Access_Values;
4037
4038    ------------------------------
4039    -- Has_Compatible_Alignment --
4040    ------------------------------
4041
4042    function Has_Compatible_Alignment
4043      (Obj  : Entity_Id;
4044       Expr : Node_Id) return Alignment_Result
4045    is
4046       function Has_Compatible_Alignment_Internal
4047         (Obj     : Entity_Id;
4048          Expr    : Node_Id;
4049          Default : Alignment_Result) return Alignment_Result;
4050       --  This is the internal recursive function that actually does the work.
4051       --  There is one additional parameter, which says what the result should
4052       --  be if no alignment information is found, and there is no definite
4053       --  indication of compatible alignments. At the outer level, this is set
4054       --  to Unknown, but for internal recursive calls in the case where types
4055       --  are known to be correct, it is set to Known_Compatible.
4056
4057       ---------------------------------------
4058       -- Has_Compatible_Alignment_Internal --
4059       ---------------------------------------
4060
4061       function Has_Compatible_Alignment_Internal
4062         (Obj     : Entity_Id;
4063          Expr    : Node_Id;
4064          Default : Alignment_Result) return Alignment_Result
4065       is
4066          Result : Alignment_Result := Known_Compatible;
4067          --  Set to result if Problem_Prefix or Problem_Offset returns True.
4068          --  Note that once a value of Known_Incompatible is set, it is sticky
4069          --  and does not get changed to Unknown (the value in Result only gets
4070          --  worse as we go along, never better).
4071
4072          procedure Check_Offset (Offs : Uint);
4073          --  Called when Expr is a selected or indexed component with Offs set
4074          --  to resp Component_First_Bit or Component_Size. Checks that if the
4075          --  offset is specified it is compatible with the object alignment
4076          --  requirements. The value in Result is modified accordingly.
4077
4078          procedure Check_Prefix;
4079          --  Checks the prefix recursively in the case where the expression
4080          --  is an indexed or selected component.
4081
4082          procedure Set_Result (R : Alignment_Result);
4083          --  If R represents a worse outcome (unknown instead of known
4084          --  compatible, or known incompatible), then set Result to R.
4085
4086          ------------------
4087          -- Check_Offset --
4088          ------------------
4089
4090          procedure Check_Offset (Offs : Uint) is
4091          begin
4092             --  Unspecified or zero offset is always OK
4093
4094             if Offs = No_Uint or else Offs = Uint_0 then
4095                null;
4096
4097             --  If we do not know required alignment, any non-zero offset is
4098             --  a potential problem (but certainly may be OK, so result is
4099             --  unknown).
4100
4101             elsif Unknown_Alignment (Obj) then
4102                Set_Result (Unknown);
4103
4104             --  If we know the required alignment, see if offset is compatible
4105
4106             else
4107                if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then
4108                   Set_Result (Known_Incompatible);
4109                end if;
4110             end if;
4111          end Check_Offset;
4112
4113          ------------------
4114          -- Check_Prefix --
4115          ------------------
4116
4117          procedure Check_Prefix is
4118          begin
4119             --  The subtlety here is that in doing a recursive call to check
4120             --  the prefix, we have to decide what to do in the case where we
4121             --  don't find any specific indication of an alignment problem.
4122
4123             --  At the outer level, we normally set Unknown as the result in
4124             --  this case, since we can only set Known_Compatible if we really
4125             --  know that the alignment value is OK, but for the recursive
4126             --  call, in the case where the types match, and we have not
4127             --  specified a peculiar alignment for the object, we are only
4128             --  concerned about suspicious rep clauses, the default case does
4129             --  not affect us, since the compiler will, in the absence of such
4130             --  rep clauses, ensure that the alignment is correct.
4131
4132             if Default = Known_Compatible
4133               or else
4134                 (Etype (Obj) = Etype (Expr)
4135                   and then (Unknown_Alignment (Obj)
4136                              or else
4137                                Alignment (Obj) = Alignment (Etype (Obj))))
4138             then
4139                Set_Result
4140                  (Has_Compatible_Alignment_Internal
4141                     (Obj, Prefix (Expr), Known_Compatible));
4142
4143             --  In all other cases, we need a full check on the prefix
4144
4145             else
4146                Set_Result
4147                  (Has_Compatible_Alignment_Internal
4148                     (Obj, Prefix (Expr), Unknown));
4149             end if;
4150          end Check_Prefix;
4151
4152          ----------------
4153          -- Set_Result --
4154          ----------------
4155
4156          procedure Set_Result (R : Alignment_Result) is
4157          begin
4158             if R > Result then
4159                Result := R;
4160             end if;
4161          end Set_Result;
4162
4163       --  Start of processing for Has_Compatible_Alignment_Internal
4164
4165       begin
4166          --  If Expr is a selected component, we must make sure there is no
4167          --  potentially troublesome component clause, and that the record is
4168          --  not packed.
4169
4170          if Nkind (Expr) = N_Selected_Component then
4171
4172             --  Packed record always generate unknown alignment
4173
4174             if Is_Packed (Etype (Prefix (Expr))) then
4175                Set_Result (Unknown);
4176             end if;
4177
4178             --  Check possible bad component offset and check prefix
4179
4180             Check_Offset
4181               (Component_Bit_Offset (Entity (Selector_Name (Expr))));
4182             Check_Prefix;
4183
4184          --  If Expr is an indexed component, we must make sure there is no
4185          --  potentially troublesome Component_Size clause and that the array
4186          --  is not bit-packed.
4187
4188          elsif Nkind (Expr) = N_Indexed_Component then
4189
4190             --  Bit packed array always generates unknown alignment
4191
4192             if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then
4193                Set_Result (Unknown);
4194             end if;
4195
4196             --  Check possible bad component size and check prefix
4197
4198             Check_Offset (Component_Size (Etype (Prefix (Expr))));
4199             Check_Prefix;
4200          end if;
4201
4202          --  Case where we know the alignment of the object
4203
4204          if Known_Alignment (Obj) then
4205             declare
4206                ObjA : constant Uint := Alignment (Obj);
4207                ExpA : Uint := No_Uint;
4208                SizA : Uint := No_Uint;
4209
4210             begin
4211                --  If alignment of Obj is 1, then we are always OK
4212
4213                if ObjA = 1 then
4214                   Set_Result (Known_Compatible);
4215
4216                --  Alignment of Obj is greater than 1, so we need to check
4217
4218                else
4219                   --  See if Expr is an object with known alignment
4220
4221                   if Is_Entity_Name (Expr)
4222                     and then Known_Alignment (Entity (Expr))
4223                   then
4224                      ExpA := Alignment (Entity (Expr));
4225
4226                      --  Otherwise, we can use the alignment of the type of
4227                      --  Expr given that we already checked for
4228                      --  discombobulating rep clauses for the cases of indexed
4229                      --  and selected components above.
4230
4231                   elsif Known_Alignment (Etype (Expr)) then
4232                      ExpA := Alignment (Etype (Expr));
4233                   end if;
4234
4235                   --  If we got an alignment, see if it is acceptable
4236
4237                   if ExpA /= No_Uint then
4238                      if ExpA < ObjA then
4239                         Set_Result (Known_Incompatible);
4240                      end if;
4241
4242                      --  Case of Expr alignment unknown
4243
4244                   else
4245                      Set_Result (Default);
4246                   end if;
4247
4248                   --  See if size is given. If so, check that it is not too
4249                   --  small for the required alignment.
4250                   --  See if Expr is an object with known alignment
4251
4252                   if Is_Entity_Name (Expr)
4253                     and then Known_Static_Esize (Entity (Expr))
4254                   then
4255                      SizA := Esize (Entity (Expr));
4256
4257                      --  Otherwise, we check the object size of the Expr type
4258
4259                   elsif Known_Static_Esize (Etype (Expr)) then
4260                      SizA := Esize (Etype (Expr));
4261                   end if;
4262
4263                   --  If we got a size, see if it is a multiple of the Obj
4264                   --  alignment, if not, then the alignment cannot be
4265                   --  acceptable, since the size is always a multiple of the
4266                   --  alignment.
4267
4268                   if SizA /= No_Uint then
4269                      if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
4270                         Set_Result (Known_Incompatible);
4271                      end if;
4272                   end if;
4273                end if;
4274             end;
4275
4276          --  If we can't find the result by direct comparison of alignment
4277          --  values, then there is still one case that we can determine known
4278          --  result, and that is when we can determine that the types are the
4279          --  same, and no alignments are specified. Then we known that the
4280          --  alignments are compatible, even if we don't know the alignment
4281          --  value in the front end.
4282
4283          elsif Etype (Obj) = Etype (Expr) then
4284
4285             --  Types are the same, but we have to check for possible size
4286             --  and alignments on the Expr object that may make the alignment
4287             --  different, even though the types are the same.
4288
4289             if Is_Entity_Name (Expr) then
4290
4291                --  First check alignment of the Expr object. Any alignment less
4292                --  than Maximum_Alignment is worrisome since this is the case
4293                --  where we do not know the alignment of Obj.
4294
4295                if Known_Alignment (Entity (Expr))
4296                  and then
4297                    UI_To_Int (Alignment (Entity (Expr)))
4298                                  < Ttypes.Maximum_Alignment
4299                then
4300                   Set_Result (Unknown);
4301
4302                   --  Now check size of Expr object. Any size that is not an
4303                   --  even multiple of Maxiumum_Alignment is also worrisome
4304                   --  since it may cause the alignment of the object to be less
4305                   --  than the alignment of the type.
4306
4307                elsif Known_Static_Esize (Entity (Expr))
4308                  and then
4309                    (UI_To_Int (Esize (Entity (Expr))) mod
4310                      (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
4311                          /= 0
4312                then
4313                   Set_Result (Unknown);
4314
4315                   --  Otherwise same type is decisive
4316
4317                else
4318                   Set_Result (Known_Compatible);
4319                end if;
4320             end if;
4321
4322          --  Another case to deal with is when there is an explicit size or
4323          --  alignment clause when the types are not the same. If so, then the
4324          --  result is Unknown. We don't need to do this test if the Default is
4325          --  Unknown, since that result will be set in any case.
4326
4327          elsif Default /= Unknown
4328            and then (Has_Size_Clause (Etype (Expr))
4329                       or else
4330                      Has_Alignment_Clause (Etype (Expr)))
4331          then
4332             Set_Result (Unknown);
4333
4334          --  If no indication found, set default
4335
4336          else
4337             Set_Result (Default);
4338          end if;
4339
4340          --  Return worst result found
4341
4342          return Result;
4343       end Has_Compatible_Alignment_Internal;
4344
4345    --  Start of processing for Has_Compatible_Alignment
4346
4347    begin
4348       --  If Obj has no specified alignment, then set alignment from the type
4349       --  alignment. Perhaps we should always do this, but for sure we should
4350       --  do it when there is an address clause since we can do more if the
4351       --  alignment is known.
4352
4353       if Unknown_Alignment (Obj) then
4354          Set_Alignment (Obj, Alignment (Etype (Obj)));
4355       end if;
4356
4357       --  Now do the internal call that does all the work
4358
4359       return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
4360    end Has_Compatible_Alignment;
4361
4362    ----------------------
4363    -- Has_Declarations --
4364    ----------------------
4365
4366    function Has_Declarations (N : Node_Id) return Boolean is
4367       K : constant Node_Kind := Nkind (N);
4368    begin
4369       return    K = N_Accept_Statement
4370         or else K = N_Block_Statement
4371         or else K = N_Compilation_Unit_Aux
4372         or else K = N_Entry_Body
4373         or else K = N_Package_Body
4374         or else K = N_Protected_Body
4375         or else K = N_Subprogram_Body
4376         or else K = N_Task_Body
4377         or else K = N_Package_Specification;
4378    end Has_Declarations;
4379
4380    -------------------------------------------
4381    -- Has_Discriminant_Dependent_Constraint --
4382    -------------------------------------------
4383
4384    function Has_Discriminant_Dependent_Constraint
4385      (Comp : Entity_Id) return Boolean
4386    is
4387       Comp_Decl  : constant Node_Id := Parent (Comp);
4388       Subt_Indic : constant Node_Id :=
4389                      Subtype_Indication (Component_Definition (Comp_Decl));
4390       Constr     : Node_Id;
4391       Assn       : Node_Id;
4392
4393    begin
4394       if Nkind (Subt_Indic) = N_Subtype_Indication then
4395          Constr := Constraint (Subt_Indic);
4396
4397          if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
4398             Assn := First (Constraints (Constr));
4399             while Present (Assn) loop
4400                case Nkind (Assn) is
4401                   when N_Subtype_Indication |
4402                        N_Range              |
4403                        N_Identifier
4404                   =>
4405                      if Depends_On_Discriminant (Assn) then
4406                         return True;
4407                      end if;
4408
4409                   when N_Discriminant_Association =>
4410                      if Depends_On_Discriminant (Expression (Assn)) then
4411                         return True;
4412                      end if;
4413
4414                   when others =>
4415                      null;
4416
4417                end case;
4418
4419                Next (Assn);
4420             end loop;
4421          end if;
4422       end if;
4423
4424       return False;
4425    end Has_Discriminant_Dependent_Constraint;
4426
4427    --------------------
4428    -- Has_Infinities --
4429    --------------------
4430
4431    function Has_Infinities (E : Entity_Id) return Boolean is
4432    begin
4433       return
4434         Is_Floating_Point_Type (E)
4435           and then Nkind (Scalar_Range (E)) = N_Range
4436           and then Includes_Infinities (Scalar_Range (E));
4437    end Has_Infinities;
4438
4439    ------------------------
4440    -- Has_Null_Exclusion --
4441    ------------------------
4442
4443    function Has_Null_Exclusion (N : Node_Id) return Boolean is
4444    begin
4445       case Nkind (N) is
4446          when N_Access_Definition               |
4447               N_Access_Function_Definition      |
4448               N_Access_Procedure_Definition     |
4449               N_Access_To_Object_Definition     |
4450               N_Allocator                       |
4451               N_Derived_Type_Definition         |
4452               N_Function_Specification          |
4453               N_Subtype_Declaration             =>
4454             return Null_Exclusion_Present (N);
4455
4456          when N_Component_Definition            |
4457               N_Formal_Object_Declaration       |
4458               N_Object_Renaming_Declaration     =>
4459             if Present (Subtype_Mark (N)) then
4460                return Null_Exclusion_Present (N);
4461             else pragma Assert (Present (Access_Definition (N)));
4462                return Null_Exclusion_Present (Access_Definition (N));
4463             end if;
4464
4465          when N_Discriminant_Specification =>
4466             if Nkind (Discriminant_Type (N)) = N_Access_Definition then
4467                return Null_Exclusion_Present (Discriminant_Type (N));
4468             else
4469                return Null_Exclusion_Present (N);
4470             end if;
4471
4472          when N_Object_Declaration =>
4473             if Nkind (Object_Definition (N)) = N_Access_Definition then
4474                return Null_Exclusion_Present (Object_Definition (N));
4475             else
4476                return Null_Exclusion_Present (N);
4477             end if;
4478
4479          when N_Parameter_Specification =>
4480             if Nkind (Parameter_Type (N)) = N_Access_Definition then
4481                return Null_Exclusion_Present (Parameter_Type (N));
4482             else
4483                return Null_Exclusion_Present (N);
4484             end if;
4485
4486          when others =>
4487             return False;
4488
4489       end case;
4490    end Has_Null_Exclusion;
4491
4492    ------------------------
4493    -- Has_Null_Extension --
4494    ------------------------
4495
4496    function Has_Null_Extension (T : Entity_Id) return Boolean is
4497       B     : constant Entity_Id := Base_Type (T);
4498       Comps : Node_Id;
4499       Ext   : Node_Id;
4500
4501    begin
4502       if Nkind (Parent (B)) = N_Full_Type_Declaration
4503         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
4504       then
4505          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
4506
4507          if Present (Ext) then
4508             if Null_Present (Ext) then
4509                return True;
4510             else
4511                Comps := Component_List (Ext);
4512
4513                --  The null component list is rewritten during analysis to
4514                --  include the parent component. Any other component indicates
4515                --  that the extension was not originally null.
4516
4517                return Null_Present (Comps)
4518                  or else No (Next (First (Component_Items (Comps))));
4519             end if;
4520          else
4521             return False;
4522          end if;
4523
4524       else
4525          return False;
4526       end if;
4527    end Has_Null_Extension;
4528
4529    --------------------------------------
4530    -- Has_Preelaborable_Initialization --
4531    --------------------------------------
4532
4533    function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
4534       Has_PE : Boolean;
4535
4536       procedure Check_Components (E : Entity_Id);
4537       --  Check component/discriminant chain, sets Has_PE False if a component
4538       --  or discriminant does not meet the preelaborable initialization rules.
4539
4540       ----------------------
4541       -- Check_Components --
4542       ----------------------
4543
4544       procedure Check_Components (E : Entity_Id) is
4545          Ent : Entity_Id;
4546          Exp : Node_Id;
4547
4548          function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
4549          --  Returns True if and only if the expression denoted by N does not
4550          --  violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
4551
4552          ---------------------------------
4553          -- Is_Preelaborable_Expression --
4554          ---------------------------------
4555
4556          function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
4557             Exp           : Node_Id;
4558             Assn          : Node_Id;
4559             Choice        : Node_Id;
4560             Comp_Type     : Entity_Id;
4561             Is_Array_Aggr : Boolean;
4562
4563          begin
4564             if Is_Static_Expression (N) then
4565                return True;
4566
4567             elsif Nkind (N) = N_Null then
4568                return True;
4569
4570             --  Attributes are allowed in general, even if their prefix is a
4571             --  formal type. (It seems that certain attributes known not to be
4572             --  static might not be allowed, but there are no rules to prevent
4573             --  them.)
4574
4575             elsif Nkind (N) = N_Attribute_Reference then
4576                return True;
4577
4578             --  The name of a discriminant evaluated within its parent type is
4579             --  defined to be preelaborable (10.2.1(8)). Note that we test for
4580             --  names that denote discriminals as well as discriminants to
4581             --  catch references occurring within init procs.
4582
4583             elsif Is_Entity_Name (N)
4584               and then
4585                 (Ekind (Entity (N)) = E_Discriminant
4586                   or else
4587                     ((Ekind (Entity (N)) = E_Constant
4588                        or else Ekind (Entity (N)) = E_In_Parameter)
4589                      and then Present (Discriminal_Link (Entity (N)))))
4590             then
4591                return True;
4592
4593             elsif Nkind (N) = N_Qualified_Expression then
4594                return Is_Preelaborable_Expression (Expression (N));
4595
4596             --  For aggregates we have to check that each of the associations
4597             --  is preelaborable.
4598
4599             elsif Nkind (N) = N_Aggregate
4600               or else Nkind (N) = N_Extension_Aggregate
4601             then
4602                Is_Array_Aggr := Is_Array_Type (Etype (N));
4603
4604                if Is_Array_Aggr then
4605                   Comp_Type := Component_Type (Etype (N));
4606                end if;
4607
4608                --  Check the ancestor part of extension aggregates, which must
4609                --  be either the name of a type that has preelaborable init or
4610                --  an expression that is preelaborable.
4611
4612                if Nkind (N) = N_Extension_Aggregate then
4613                   declare
4614                      Anc_Part : constant Node_Id := Ancestor_Part (N);
4615
4616                   begin
4617                      if Is_Entity_Name (Anc_Part)
4618                        and then Is_Type (Entity (Anc_Part))
4619                      then
4620                         if not Has_Preelaborable_Initialization
4621                                  (Entity (Anc_Part))
4622                         then
4623                            return False;
4624                         end if;
4625
4626                      elsif not Is_Preelaborable_Expression (Anc_Part) then
4627                         return False;
4628                      end if;
4629                   end;
4630                end if;
4631
4632                --  Check positional associations
4633
4634                Exp := First (Expressions (N));
4635                while Present (Exp) loop
4636                   if not Is_Preelaborable_Expression (Exp) then
4637                      return False;
4638                   end if;
4639
4640                   Next (Exp);
4641                end loop;
4642
4643                --  Check named associations
4644
4645                Assn := First (Component_Associations (N));
4646                while Present (Assn) loop
4647                   Choice := First (Choices (Assn));
4648                   while Present (Choice) loop
4649                      if Is_Array_Aggr then
4650                         if Nkind (Choice) = N_Others_Choice then
4651                            null;
4652
4653                         elsif Nkind (Choice) = N_Range then
4654                            if not Is_Static_Range (Choice) then
4655                               return False;
4656                            end if;
4657
4658                         elsif not Is_Static_Expression (Choice) then
4659                            return False;
4660                         end if;
4661
4662                      else
4663                         Comp_Type := Etype (Choice);
4664                      end if;
4665
4666                      Next (Choice);
4667                   end loop;
4668
4669                   --  If the association has a <> at this point, then we have
4670                   --  to check whether the component's type has preelaborable
4671                   --  initialization. Note that this only occurs when the
4672                   --  association's corresponding component does not have a
4673                   --  default expression, the latter case having already been
4674                   --  expanded as an expression for the association.
4675
4676                   if Box_Present (Assn) then
4677                      if not Has_Preelaborable_Initialization (Comp_Type) then
4678                         return False;
4679                      end if;
4680
4681                   --  In the expression case we check whether the expression
4682                   --  is preelaborable.
4683
4684                   elsif
4685                     not Is_Preelaborable_Expression (Expression (Assn))
4686                   then
4687                      return False;
4688                   end if;
4689
4690                   Next (Assn);
4691                end loop;
4692
4693                --  If we get here then aggregate as a whole is preelaborable
4694
4695                return True;
4696
4697             --  All other cases are not preelaborable
4698
4699             else
4700                return False;
4701             end if;
4702          end Is_Preelaborable_Expression;
4703
4704       --  Start of processing for Check_Components
4705
4706       begin
4707          --  Loop through entities of record or protected type
4708
4709          Ent := E;
4710          while Present (Ent) loop
4711
4712             --  We are interested only in components and discriminants
4713
4714             if Ekind (Ent) = E_Component
4715                 or else
4716                Ekind (Ent) = E_Discriminant
4717             then
4718                --  Get default expression if any. If there is no declaration
4719                --  node, it means we have an internal entity. The parent and
4720                --  tag fields are examples of such entitires. For these cases,
4721                --  we just test the type of the entity.
4722
4723                if Present (Declaration_Node (Ent)) then
4724                   Exp := Expression (Declaration_Node (Ent));
4725                else
4726                   Exp := Empty;
4727                end if;
4728
4729                --  A component has PI if it has no default expression and the
4730                --  component type has PI.
4731
4732                if No (Exp) then
4733                   if not Has_Preelaborable_Initialization (Etype (Ent)) then
4734                      Has_PE := False;
4735                      exit;
4736                   end if;
4737
4738                --  Require the default expression to be preelaborable
4739
4740                elsif not Is_Preelaborable_Expression (Exp) then
4741                   Has_PE := False;
4742                   exit;
4743                end if;
4744             end if;
4745
4746             Next_Entity (Ent);
4747          end loop;
4748       end Check_Components;
4749
4750    --  Start of processing for Has_Preelaborable_Initialization
4751
4752    begin
4753       --  Immediate return if already marked as known preelaborable init. This
4754       --  covers types for which this function has already been called once
4755       --  and returned True (in which case the result is cached), and also
4756       --  types to which a pragma Preelaborable_Initialization applies.
4757
4758       if Known_To_Have_Preelab_Init (E) then
4759          return True;
4760       end if;
4761
4762       --  If the type is a subtype representing a generic actual type, then
4763       --  test whether its base type has preelaborable initialization since
4764       --  the subtype representing the actual does not inherit this attribute
4765       --  from the actual or formal. (but maybe it should???)
4766
4767       if Is_Generic_Actual_Type (E) then
4768          return Has_Preelaborable_Initialization (Base_Type (E));
4769       end if;
4770
4771       --  Other private types never have preelaborable initialization
4772
4773       if Is_Private_Type (E) then
4774          return False;
4775       end if;
4776
4777       --  Here for all non-private view
4778
4779       --  All elementary types have preelaborable initialization
4780
4781       if Is_Elementary_Type (E) then
4782          Has_PE := True;
4783
4784       --  Array types have PI if the component type has PI
4785
4786       elsif Is_Array_Type (E) then
4787          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
4788
4789       --  A derived type has preelaborable initialization if its parent type
4790       --  has preelaborable initialization and (in the case of a derived record
4791       --  extension) if the non-inherited components all have preelaborable
4792       --  initialization. However, a user-defined controlled type with an
4793       --  overriding Initialize procedure does not have preelaborable
4794       --  initialization.
4795
4796       elsif Is_Derived_Type (E) then
4797
4798          --  First check whether ancestor type has preelaborable initialization
4799
4800          Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
4801
4802          --  If OK, check extension components (if any)
4803
4804          if Has_PE and then Is_Record_Type (E) then
4805             Check_Components (First_Entity (E));
4806          end if;
4807
4808          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
4809          --  with a user defined Initialize procedure does not have PI.
4810
4811          if Has_PE
4812            and then Is_Controlled (E)
4813            and then Present (Primitive_Operations (E))
4814          then
4815             declare
4816                P : Elmt_Id;
4817
4818             begin
4819                P := First_Elmt (Primitive_Operations (E));
4820                while Present (P) loop
4821                   if Chars (Node (P)) = Name_Initialize
4822                     and then Comes_From_Source (Node (P))
4823                   then
4824                      Has_PE := False;
4825                      exit;
4826                   end if;
4827
4828                   Next_Elmt (P);
4829                end loop;
4830             end;
4831          end if;
4832
4833       --  Record type has PI if it is non private and all components have PI
4834
4835       elsif Is_Record_Type (E) then
4836          Has_PE := True;
4837          Check_Components (First_Entity (E));
4838
4839       --  Protected types must not have entries, and components must meet
4840       --  same set of rules as for record components.
4841
4842       elsif Is_Protected_Type (E) then
4843          if Has_Entries (E) then
4844             Has_PE := False;
4845          else
4846             Has_PE := True;
4847             Check_Components (First_Entity (E));
4848             Check_Components (First_Private_Entity (E));
4849          end if;
4850
4851       --  Type System.Address always has preelaborable initialization
4852
4853       elsif Is_RTE (E, RE_Address) then
4854          Has_PE := True;
4855
4856       --  In all other cases, type does not have preelaborable initialization
4857
4858       else
4859          return False;
4860       end if;
4861
4862       --  If type has preelaborable initialization, cache result
4863
4864       if Has_PE then
4865          Set_Known_To_Have_Preelab_Init (E);
4866       end if;
4867
4868       return Has_PE;
4869    end Has_Preelaborable_Initialization;
4870
4871    ---------------------------
4872    -- Has_Private_Component --
4873    ---------------------------
4874
4875    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
4876       Btype     : Entity_Id := Base_Type (Type_Id);
4877       Component : Entity_Id;
4878
4879    begin
4880       if Error_Posted (Type_Id)
4881         or else Error_Posted (Btype)
4882       then
4883          return False;
4884       end if;
4885
4886       if Is_Class_Wide_Type (Btype) then
4887          Btype := Root_Type (Btype);
4888       end if;
4889
4890       if Is_Private_Type (Btype) then
4891          declare
4892             UT : constant Entity_Id := Underlying_Type (Btype);
4893          begin
4894             if No (UT) then
4895                if No (Full_View (Btype)) then
4896                   return not Is_Generic_Type (Btype)
4897                     and then not Is_Generic_Type (Root_Type (Btype));
4898                else
4899                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
4900                end if;
4901             else
4902                return not Is_Frozen (UT) and then Has_Private_Component (UT);
4903             end if;
4904          end;
4905
4906       elsif Is_Array_Type (Btype) then
4907          return Has_Private_Component (Component_Type (Btype));
4908
4909       elsif Is_Record_Type (Btype) then
4910          Component := First_Component (Btype);
4911          while Present (Component) loop
4912             if Has_Private_Component (Etype (Component)) then
4913                return True;
4914             end if;
4915
4916             Next_Component (Component);
4917          end loop;
4918
4919          return False;
4920
4921       elsif Is_Protected_Type (Btype)
4922         and then Present (Corresponding_Record_Type (Btype))
4923       then
4924          return Has_Private_Component (Corresponding_Record_Type (Btype));
4925
4926       else
4927          return False;
4928       end if;
4929    end Has_Private_Component;
4930
4931    ----------------
4932    -- Has_Stream --
4933    ----------------
4934
4935    function Has_Stream (T : Entity_Id) return Boolean is
4936       E : Entity_Id;
4937
4938    begin
4939       if No (T) then
4940          return False;
4941
4942       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
4943          return True;
4944
4945       elsif Is_Array_Type (T) then
4946          return Has_Stream (Component_Type (T));
4947
4948       elsif Is_Record_Type (T) then
4949          E := First_Component (T);
4950          while Present (E) loop
4951             if Has_Stream (Etype (E)) then
4952                return True;
4953             else
4954                Next_Component (E);
4955             end if;
4956          end loop;
4957
4958          return False;
4959
4960       elsif Is_Private_Type (T) then
4961          return Has_Stream (Underlying_Type (T));
4962
4963       else
4964          return False;
4965       end if;
4966    end Has_Stream;
4967
4968    --------------------------
4969    -- Has_Tagged_Component --
4970    --------------------------
4971
4972    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
4973       Comp : Entity_Id;
4974
4975    begin
4976       if Is_Private_Type (Typ)
4977         and then Present (Underlying_Type (Typ))
4978       then
4979          return Has_Tagged_Component (Underlying_Type (Typ));
4980
4981       elsif Is_Array_Type (Typ) then
4982          return Has_Tagged_Component (Component_Type (Typ));
4983
4984       elsif Is_Tagged_Type (Typ) then
4985          return True;
4986
4987       elsif Is_Record_Type (Typ) then
4988          Comp := First_Component (Typ);
4989          while Present (Comp) loop
4990             if Has_Tagged_Component (Etype (Comp)) then
4991                return True;
4992             end if;
4993
4994             Comp := Next_Component (Typ);
4995          end loop;
4996
4997          return False;
4998
4999       else
5000          return False;
5001       end if;
5002    end Has_Tagged_Component;
5003
5004    -----------------
5005    -- In_Instance --
5006    -----------------
5007
5008    function In_Instance return Boolean is
5009       Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
5010       S         : Entity_Id;
5011
5012    begin
5013       S := Current_Scope;
5014       while Present (S)
5015         and then S /= Standard_Standard
5016       loop
5017          if (Ekind (S) = E_Function
5018               or else Ekind (S) = E_Package
5019               or else Ekind (S) = E_Procedure)
5020            and then Is_Generic_Instance (S)
5021          then
5022             --  A child instance is always compiled in the context of a parent
5023             --  instance. Nevertheless, the actuals are not analyzed in an
5024             --  instance context. We detect this case by examining the current
5025             --  compilation unit, which must be a child instance, and checking
5026             --  that it is not currently on the scope stack.
5027
5028             if Is_Child_Unit (Curr_Unit)
5029               and then
5030                 Nkind (Unit (Cunit (Current_Sem_Unit)))
5031                   = N_Package_Instantiation
5032               and then not In_Open_Scopes (Curr_Unit)
5033             then
5034                return False;
5035             else
5036                return True;
5037             end if;
5038          end if;
5039
5040          S := Scope (S);
5041       end loop;
5042
5043       return False;
5044    end In_Instance;
5045
5046    ----------------------
5047    -- In_Instance_Body --
5048    ----------------------
5049
5050    function In_Instance_Body return Boolean is
5051       S : Entity_Id;
5052
5053    begin
5054       S := Current_Scope;
5055       while Present (S)
5056         and then S /= Standard_Standard
5057       loop
5058          if (Ekind (S) = E_Function
5059               or else Ekind (S) = E_Procedure)
5060            and then Is_Generic_Instance (S)
5061          then
5062             return True;
5063
5064          elsif Ekind (S) = E_Package
5065            and then In_Package_Body (S)
5066            and then Is_Generic_Instance (S)
5067          then
5068             return True;
5069          end if;
5070
5071          S := Scope (S);
5072       end loop;
5073
5074       return False;
5075    end In_Instance_Body;
5076
5077    -----------------------------
5078    -- In_Instance_Not_Visible --
5079    -----------------------------
5080
5081    function In_Instance_Not_Visible return Boolean is
5082       S : Entity_Id;
5083
5084    begin
5085       S := Current_Scope;
5086       while Present (S)
5087         and then S /= Standard_Standard
5088       loop
5089          if (Ekind (S) = E_Function
5090               or else Ekind (S) = E_Procedure)
5091            and then Is_Generic_Instance (S)
5092          then
5093             return True;
5094
5095          elsif Ekind (S) = E_Package
5096            and then (In_Package_Body (S) or else In_Private_Part (S))
5097            and then Is_Generic_Instance (S)
5098          then
5099             return True;
5100          end if;
5101
5102          S := Scope (S);
5103       end loop;
5104
5105       return False;
5106    end In_Instance_Not_Visible;
5107
5108    ------------------------------
5109    -- In_Instance_Visible_Part --
5110    ------------------------------
5111
5112    function In_Instance_Visible_Part return Boolean is
5113       S : Entity_Id;
5114
5115    begin
5116       S := Current_Scope;
5117       while Present (S)
5118         and then S /= Standard_Standard
5119       loop
5120          if Ekind (S) = E_Package
5121            and then Is_Generic_Instance (S)
5122            and then not In_Package_Body (S)
5123            and then not In_Private_Part (S)
5124          then
5125             return True;
5126          end if;
5127
5128          S := Scope (S);
5129       end loop;
5130
5131       return False;
5132    end In_Instance_Visible_Part;
5133
5134    ----------------------
5135    -- In_Packiage_Body --
5136    ----------------------
5137
5138    function In_Package_Body return Boolean is
5139       S : Entity_Id;
5140
5141    begin
5142       S := Current_Scope;
5143       while Present (S)
5144         and then S /= Standard_Standard
5145       loop
5146          if Ekind (S) = E_Package
5147            and then In_Package_Body (S)
5148          then
5149             return True;
5150          else
5151             S := Scope (S);
5152          end if;
5153       end loop;
5154
5155       return False;
5156    end In_Package_Body;
5157
5158    --------------------------------------
5159    -- In_Subprogram_Or_Concurrent_Unit --
5160    --------------------------------------
5161
5162    function In_Subprogram_Or_Concurrent_Unit return Boolean is
5163       E : Entity_Id;
5164       K : Entity_Kind;
5165
5166    begin
5167       --  Use scope chain to check successively outer scopes
5168
5169       E := Current_Scope;
5170       loop
5171          K := Ekind (E);
5172
5173          if K in Subprogram_Kind
5174            or else K in Concurrent_Kind
5175            or else K in Generic_Subprogram_Kind
5176          then
5177             return True;
5178
5179          elsif E = Standard_Standard then
5180             return False;
5181          end if;
5182
5183          E := Scope (E);
5184       end loop;
5185    end In_Subprogram_Or_Concurrent_Unit;
5186
5187    ---------------------
5188    -- In_Visible_Part --
5189    ---------------------
5190
5191    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
5192    begin
5193       return
5194         Is_Package_Or_Generic_Package (Scope_Id)
5195           and then In_Open_Scopes (Scope_Id)
5196           and then not In_Package_Body (Scope_Id)
5197           and then not In_Private_Part (Scope_Id);
5198    end In_Visible_Part;
5199
5200    ---------------------------------
5201    -- Insert_Explicit_Dereference --
5202    ---------------------------------
5203
5204    procedure Insert_Explicit_Dereference (N : Node_Id) is
5205       New_Prefix : constant Node_Id := Relocate_Node (N);
5206       Ent        : Entity_Id := Empty;
5207       Pref       : Node_Id;
5208       I          : Interp_Index;
5209       It         : Interp;
5210       T          : Entity_Id;
5211
5212    begin
5213       Save_Interps (N, New_Prefix);
5214       Rewrite (N,
5215         Make_Explicit_Dereference (Sloc (N),
5216           Prefix => New_Prefix));
5217
5218       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
5219
5220       if Is_Overloaded (New_Prefix) then
5221
5222          --  The deference is also overloaded, and its interpretations are the
5223          --  designated types of the interpretations of the original node.
5224
5225          Set_Etype (N, Any_Type);
5226
5227          Get_First_Interp (New_Prefix, I, It);
5228          while Present (It.Nam) loop
5229             T := It.Typ;
5230
5231             if Is_Access_Type (T) then
5232                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
5233             end if;
5234
5235             Get_Next_Interp (I, It);
5236          end loop;
5237
5238          End_Interp_List;
5239
5240       else
5241          --  Prefix is unambiguous: mark the original prefix (which might
5242          --  Come_From_Source) as a reference, since the new (relocated) one
5243          --  won't be taken into account.
5244
5245          if Is_Entity_Name (New_Prefix) then
5246             Ent := Entity (New_Prefix);
5247
5248          --  For a retrieval of a subcomponent of some composite object,
5249          --  retrieve the ultimate entity if there is one.
5250
5251          elsif Nkind (New_Prefix) = N_Selected_Component
5252            or else Nkind (New_Prefix) = N_Indexed_Component
5253          then
5254             Pref := Prefix (New_Prefix);
5255             while Present (Pref)
5256               and then
5257                 (Nkind (Pref) = N_Selected_Component
5258                   or else Nkind (Pref) = N_Indexed_Component)
5259             loop
5260                Pref := Prefix (Pref);
5261             end loop;
5262
5263             if Present (Pref) and then Is_Entity_Name (Pref) then
5264                Ent := Entity (Pref);
5265             end if;
5266          end if;
5267
5268          if Present (Ent) then
5269             Generate_Reference (Ent, New_Prefix);
5270          end if;
5271       end if;
5272    end Insert_Explicit_Dereference;
5273
5274    -------------------
5275    -- Is_AAMP_Float --
5276    -------------------
5277
5278    function Is_AAMP_Float (E : Entity_Id) return Boolean is
5279       pragma Assert (Is_Type (E));
5280    begin
5281       return AAMP_On_Target
5282          and then Is_Floating_Point_Type (E)
5283          and then E = Base_Type (E);
5284    end Is_AAMP_Float;
5285
5286    -------------------------
5287    -- Is_Actual_Parameter --
5288    -------------------------
5289
5290    function Is_Actual_Parameter (N : Node_Id) return Boolean is
5291       PK : constant Node_Kind := Nkind (Parent (N));
5292
5293    begin
5294       case PK is
5295          when N_Parameter_Association =>
5296             return N = Explicit_Actual_Parameter (Parent (N));
5297
5298          when N_Function_Call | N_Procedure_Call_Statement =>
5299             return Is_List_Member (N)
5300               and then
5301                 List_Containing (N) = Parameter_Associations (Parent (N));
5302
5303          when others =>
5304             return False;
5305       end case;
5306    end Is_Actual_Parameter;
5307
5308    ---------------------
5309    -- Is_Aliased_View --
5310    ---------------------
5311
5312    function Is_Aliased_View (Obj : Node_Id) return Boolean is
5313       E : Entity_Id;
5314
5315    begin
5316       if Is_Entity_Name (Obj) then
5317
5318          E := Entity (Obj);
5319
5320          return
5321            (Is_Object (E)
5322              and then
5323                (Is_Aliased (E)
5324                   or else (Present (Renamed_Object (E))
5325                              and then Is_Aliased_View (Renamed_Object (E)))))
5326
5327            or else ((Is_Formal (E)
5328                       or else Ekind (E) = E_Generic_In_Out_Parameter
5329                       or else Ekind (E) = E_Generic_In_Parameter)
5330                     and then Is_Tagged_Type (Etype (E)))
5331
5332            or else (Is_Concurrent_Type (E)
5333                      and then In_Open_Scopes (E))
5334
5335             --  Current instance of type, either directly or as rewritten
5336             --  reference to the current object.
5337
5338            or else (Is_Entity_Name (Original_Node (Obj))
5339                      and then Present (Entity (Original_Node (Obj)))
5340                      and then Is_Type (Entity (Original_Node (Obj))))
5341
5342            or else (Is_Type (E) and then E = Current_Scope)
5343
5344            or else (Is_Incomplete_Or_Private_Type (E)
5345                      and then Full_View (E) = Current_Scope);
5346
5347       elsif Nkind (Obj) = N_Selected_Component then
5348          return Is_Aliased (Entity (Selector_Name (Obj)));
5349
5350       elsif Nkind (Obj) = N_Indexed_Component then
5351          return Has_Aliased_Components (Etype (Prefix (Obj)))
5352            or else
5353              (Is_Access_Type (Etype (Prefix (Obj)))
5354                and then
5355               Has_Aliased_Components
5356                 (Designated_Type (Etype (Prefix (Obj)))));
5357
5358       elsif Nkind (Obj) = N_Unchecked_Type_Conversion
5359         or else Nkind (Obj) = N_Type_Conversion
5360       then
5361          return Is_Tagged_Type (Etype (Obj))
5362            and then Is_Aliased_View (Expression (Obj));
5363
5364       elsif Nkind (Obj) = N_Explicit_Dereference then
5365          return Nkind (Original_Node (Obj)) /= N_Function_Call;
5366
5367       else
5368          return False;
5369       end if;
5370    end Is_Aliased_View;
5371
5372    -------------------------
5373    -- Is_Ancestor_Package --
5374    -------------------------
5375
5376    function Is_Ancestor_Package
5377      (E1 : Entity_Id;
5378       E2 : Entity_Id) return Boolean
5379    is
5380       Par : Entity_Id;
5381
5382    begin
5383       Par := E2;
5384       while Present (Par)
5385         and then Par /= Standard_Standard
5386       loop
5387          if Par = E1 then
5388             return True;
5389          end if;
5390
5391          Par := Scope (Par);
5392       end loop;
5393
5394       return False;
5395    end Is_Ancestor_Package;
5396
5397    ----------------------
5398    -- Is_Atomic_Object --
5399    ----------------------
5400
5401    function Is_Atomic_Object (N : Node_Id) return Boolean is
5402
5403       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
5404       --  Determines if given object has atomic components
5405
5406       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
5407       --  If prefix is an implicit dereference, examine designated type
5408
5409       ----------------------
5410       -- Is_Atomic_Prefix --
5411       ----------------------
5412
5413       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
5414       begin
5415          if Is_Access_Type (Etype (N)) then
5416             return
5417               Has_Atomic_Components (Designated_Type (Etype (N)));
5418          else
5419             return Object_Has_Atomic_Components (N);
5420          end if;
5421       end Is_Atomic_Prefix;
5422
5423       ----------------------------------
5424       -- Object_Has_Atomic_Components --
5425       ----------------------------------
5426
5427       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
5428       begin
5429          if Has_Atomic_Components (Etype (N))
5430            or else Is_Atomic (Etype (N))
5431          then
5432             return True;
5433
5434          elsif Is_Entity_Name (N)
5435            and then (Has_Atomic_Components (Entity (N))
5436                       or else Is_Atomic (Entity (N)))
5437          then
5438             return True;
5439
5440          elsif Nkind (N) = N_Indexed_Component
5441            or else Nkind (N) = N_Selected_Component
5442          then
5443             return Is_Atomic_Prefix (Prefix (N));
5444
5445          else
5446             return False;
5447          end if;
5448       end Object_Has_Atomic_Components;
5449
5450    --  Start of processing for Is_Atomic_Object
5451
5452    begin
5453       if Is_Atomic (Etype (N))
5454         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
5455       then
5456          return True;
5457
5458       elsif Nkind (N) = N_Indexed_Component
5459         or else Nkind (N) = N_Selected_Component
5460       then
5461          return Is_Atomic_Prefix (Prefix (N));
5462
5463       else
5464          return False;
5465       end if;
5466    end Is_Atomic_Object;
5467
5468    -------------------------
5469    -- Is_Coextension_Root --
5470    -------------------------
5471
5472    function Is_Coextension_Root (N : Node_Id) return Boolean is
5473    begin
5474       return
5475         Nkind (N) = N_Allocator
5476           and then Present (Coextensions (N))
5477
5478          --  Anonymous access discriminants carry a list of all nested
5479          --  controlled coextensions.
5480
5481           and then not Is_Dynamic_Coextension (N)
5482           and then not Is_Static_Coextension (N);
5483    end Is_Coextension_Root;
5484
5485    -----------------------------
5486    -- Is_Concurrent_Interface --
5487    -----------------------------
5488
5489    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
5490    begin
5491       return
5492         Is_Interface (T)
5493           and then
5494             (Is_Protected_Interface (T)
5495                or else Is_Synchronized_Interface (T)
5496                or else Is_Task_Interface (T));
5497    end Is_Concurrent_Interface;
5498
5499    --------------------------------------
5500    -- Is_Controlling_Limited_Procedure --
5501    --------------------------------------
5502
5503    function Is_Controlling_Limited_Procedure
5504      (Proc_Nam : Entity_Id) return Boolean
5505    is
5506       Param_Typ : Entity_Id := Empty;
5507
5508    begin
5509       if Ekind (Proc_Nam) = E_Procedure
5510         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
5511       then
5512          Param_Typ := Etype (Parameter_Type (First (
5513                         Parameter_Specifications (Parent (Proc_Nam)))));
5514
5515       --  In this case where an Itype was created, the procedure call has been
5516       --  rewritten.
5517
5518       elsif Present (Associated_Node_For_Itype (Proc_Nam))
5519         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
5520         and then
5521           Present (Parameter_Associations
5522                      (Associated_Node_For_Itype (Proc_Nam)))
5523       then
5524          Param_Typ :=
5525            Etype (First (Parameter_Associations
5526                           (Associated_Node_For_Itype (Proc_Nam))));
5527       end if;
5528
5529       if Present (Param_Typ) then
5530          return
5531            Is_Interface (Param_Typ)
5532              and then Is_Limited_Record (Param_Typ);
5533       end if;
5534
5535       return False;
5536    end Is_Controlling_Limited_Procedure;
5537
5538    ----------------------------------------------
5539    -- Is_Dependent_Component_Of_Mutable_Object --
5540    ----------------------------------------------
5541
5542    function Is_Dependent_Component_Of_Mutable_Object
5543      (Object : Node_Id) return   Boolean
5544    is
5545       P           : Node_Id;
5546       Prefix_Type : Entity_Id;
5547       P_Aliased   : Boolean := False;
5548       Comp        : Entity_Id;
5549
5550       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
5551       --  Returns True if and only if Comp is declared within a variant part
5552
5553       --------------------------------
5554       -- Is_Declared_Within_Variant --
5555       --------------------------------
5556
5557       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
5558          Comp_Decl : constant Node_Id   := Parent (Comp);
5559          Comp_List : constant Node_Id   := Parent (Comp_Decl);
5560       begin
5561          return Nkind (Parent (Comp_List)) = N_Variant;
5562       end Is_Declared_Within_Variant;
5563
5564    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
5565
5566    begin
5567       if Is_Variable (Object) then
5568
5569          if Nkind (Object) = N_Selected_Component then
5570             P := Prefix (Object);
5571             Prefix_Type := Etype (P);
5572
5573             if Is_Entity_Name (P) then
5574
5575                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
5576                   Prefix_Type := Base_Type (Prefix_Type);
5577                end if;
5578
5579                if Is_Aliased (Entity (P)) then
5580                   P_Aliased := True;
5581                end if;
5582
5583             --  A discriminant check on a selected component may be
5584             --  expanded into a dereference when removing side-effects.
5585             --  Recover the original node and its type, which may be
5586             --  unconstrained.
5587
5588             elsif Nkind (P) = N_Explicit_Dereference
5589               and then not (Comes_From_Source (P))
5590             then
5591                P := Original_Node (P);
5592                Prefix_Type := Etype (P);
5593
5594             else
5595                --  Check for prefix being an aliased component ???
5596                null;
5597
5598             end if;
5599
5600             --  A heap object is constrained by its initial value
5601
5602             --  Ada 2005 (AI-363): Always assume the object could be mutable in
5603             --  the dereferenced case, since the access value might denote an
5604             --  unconstrained aliased object, whereas in Ada 95 the designated
5605             --  object is guaranteed to be constrained. A worst-case assumption
5606             --  has to apply in Ada 2005 because we can't tell at compile time
5607             --  whether the object is "constrained by its initial value"
5608             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
5609             --  semantic rules -- these rules are acknowledged to need fixing).
5610
5611             if Ada_Version < Ada_05 then
5612                if Is_Access_Type (Prefix_Type)
5613                  or else Nkind (P) = N_Explicit_Dereference
5614                then
5615                   return False;
5616                end if;
5617
5618             elsif Ada_Version >= Ada_05 then
5619                if Is_Access_Type (Prefix_Type) then
5620
5621                   --  If the access type is pool-specific, and there is no
5622                   --  constrained partial view of the designated type, then the
5623                   --  designated object is known to be constrained.
5624
5625                   if Ekind (Prefix_Type) = E_Access_Type
5626                     and then not Has_Constrained_Partial_View
5627                                    (Designated_Type (Prefix_Type))
5628                   then
5629                      return False;
5630
5631                   --  Otherwise (general access type, or there is a constrained
5632                   --  partial view of the designated type), we need to check
5633                   --  based on the designated type.
5634
5635                   else
5636                      Prefix_Type := Designated_Type (Prefix_Type);
5637                   end if;
5638                end if;
5639             end if;
5640
5641             Comp :=
5642               Original_Record_Component (Entity (Selector_Name (Object)));
5643
5644             --  As per AI-0017, the renaming is illegal in a generic body,
5645             --  even if the subtype is indefinite.
5646
5647             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
5648
5649             if not Is_Constrained (Prefix_Type)
5650               and then (not Is_Indefinite_Subtype (Prefix_Type)
5651                          or else
5652                           (Is_Generic_Type (Prefix_Type)
5653                             and then Ekind (Current_Scope) = E_Generic_Package
5654                             and then In_Package_Body (Current_Scope)))
5655
5656               and then (Is_Declared_Within_Variant (Comp)
5657                           or else Has_Discriminant_Dependent_Constraint (Comp))
5658               and then (not P_Aliased or else Ada_Version >= Ada_05)
5659             then
5660                return True;
5661
5662             else
5663                return
5664                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
5665
5666             end if;
5667
5668          elsif Nkind (Object) = N_Indexed_Component
5669            or else Nkind (Object) = N_Slice
5670          then
5671             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
5672
5673          --  A type conversion that Is_Variable is a view conversion:
5674          --  go back to the denoted object.
5675
5676          elsif Nkind (Object) = N_Type_Conversion then
5677             return
5678               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
5679          end if;
5680       end if;
5681
5682       return False;
5683    end Is_Dependent_Component_Of_Mutable_Object;
5684
5685    ---------------------
5686    -- Is_Dereferenced --
5687    ---------------------
5688
5689    function Is_Dereferenced (N : Node_Id) return Boolean is
5690       P : constant Node_Id := Parent (N);
5691    begin
5692       return
5693          (Nkind (P) = N_Selected_Component
5694             or else
5695           Nkind (P) = N_Explicit_Dereference
5696             or else
5697           Nkind (P) = N_Indexed_Component
5698             or else
5699           Nkind (P) = N_Slice)
5700         and then Prefix (P) = N;
5701    end Is_Dereferenced;
5702
5703    ----------------------
5704    -- Is_Descendent_Of --
5705    ----------------------
5706
5707    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
5708       T    : Entity_Id;
5709       Etyp : Entity_Id;
5710
5711    begin
5712       pragma Assert (Nkind (T1) in N_Entity);
5713       pragma Assert (Nkind (T2) in N_Entity);
5714
5715       T := Base_Type (T1);
5716
5717       --  Immediate return if the types match
5718
5719       if T = T2 then
5720          return True;
5721
5722       --  Comment needed here ???
5723
5724       elsif Ekind (T) = E_Class_Wide_Type then
5725          return Etype (T) = T2;
5726
5727       --  All other cases
5728
5729       else
5730          loop
5731             Etyp := Etype (T);
5732
5733             --  Done if we found the type we are looking for
5734
5735             if Etyp = T2 then
5736                return True;
5737
5738             --  Done if no more derivations to check
5739
5740             elsif T = T1
5741               or else T = Etyp
5742             then
5743                return False;
5744
5745             --  Following test catches error cases resulting from prev errors
5746
5747             elsif No (Etyp) then
5748                return False;
5749
5750             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
5751                return False;
5752
5753             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
5754                return False;
5755             end if;
5756
5757             T := Base_Type (Etyp);
5758          end loop;
5759       end if;
5760
5761       raise Program_Error;
5762    end Is_Descendent_Of;
5763
5764    --------------
5765    -- Is_False --
5766    --------------
5767
5768    function Is_False (U : Uint) return Boolean is
5769    begin
5770       return (U = 0);
5771    end Is_False;
5772
5773    ---------------------------
5774    -- Is_Fixed_Model_Number --
5775    ---------------------------
5776
5777    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
5778       S : constant Ureal := Small_Value (T);
5779       M : Urealp.Save_Mark;
5780       R : Boolean;
5781    begin
5782       M := Urealp.Mark;
5783       R := (U = UR_Trunc (U / S) * S);
5784       Urealp.Release (M);
5785       return R;
5786    end Is_Fixed_Model_Number;
5787
5788    -------------------------------
5789    -- Is_Fully_Initialized_Type --
5790    -------------------------------
5791
5792    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
5793    begin
5794       if Is_Scalar_Type (Typ) then
5795          return False;
5796
5797       elsif Is_Access_Type (Typ) then
5798          return True;
5799
5800       elsif Is_Array_Type (Typ) then
5801          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
5802             return True;
5803          end if;
5804
5805          --  An interesting case, if we have a constrained type one of whose
5806          --  bounds is known to be null, then there are no elements to be
5807          --  initialized, so all the elements are initialized!
5808
5809          if Is_Constrained (Typ) then
5810             declare
5811                Indx     : Node_Id;
5812                Indx_Typ : Entity_Id;
5813                Lbd, Hbd : Node_Id;
5814
5815             begin
5816                Indx := First_Index (Typ);
5817                while Present (Indx) loop
5818                   if Etype (Indx) = Any_Type then
5819                      return False;
5820
5821                   --  If index is a range, use directly
5822
5823                   elsif Nkind (Indx) = N_Range then
5824                      Lbd := Low_Bound  (Indx);
5825                      Hbd := High_Bound (Indx);
5826
5827                   else
5828                      Indx_Typ := Etype (Indx);
5829
5830                      if Is_Private_Type (Indx_Typ)  then
5831                         Indx_Typ := Full_View (Indx_Typ);
5832                      end if;
5833
5834                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
5835                         return False;
5836                      else
5837                         Lbd := Type_Low_Bound  (Indx_Typ);
5838                         Hbd := Type_High_Bound (Indx_Typ);
5839                      end if;
5840                   end if;
5841
5842                   if Compile_Time_Known_Value (Lbd)
5843                     and then Compile_Time_Known_Value (Hbd)
5844                   then
5845                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
5846                         return True;
5847                      end if;
5848                   end if;
5849
5850                   Next_Index (Indx);
5851                end loop;
5852             end;
5853          end if;
5854
5855          --  If no null indexes, then type is not fully initialized
5856
5857          return False;
5858
5859       --  Record types
5860
5861       elsif Is_Record_Type (Typ) then
5862          if Has_Discriminants (Typ)
5863            and then
5864              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
5865            and then Is_Fully_Initialized_Variant (Typ)
5866          then
5867             return True;
5868          end if;
5869
5870          --  Controlled records are considered to be fully initialized if
5871          --  there is a user defined Initialize routine. This may not be
5872          --  entirely correct, but as the spec notes, we are guessing here
5873          --  what is best from the point of view of issuing warnings.
5874
5875          if Is_Controlled (Typ) then
5876             declare
5877                Utyp : constant Entity_Id := Underlying_Type (Typ);
5878
5879             begin
5880                if Present (Utyp) then
5881                   declare
5882                      Init : constant Entity_Id :=
5883                               (Find_Prim_Op
5884                                  (Underlying_Type (Typ), Name_Initialize));
5885
5886                   begin
5887                      if Present (Init)
5888                        and then Comes_From_Source (Init)
5889                        and then not
5890                          Is_Predefined_File_Name
5891                            (File_Name (Get_Source_File_Index (Sloc (Init))))
5892                      then
5893                         return True;
5894
5895                      elsif Has_Null_Extension (Typ)
5896                         and then
5897                           Is_Fully_Initialized_Type
5898                             (Etype (Base_Type (Typ)))
5899                      then
5900                         return True;
5901                      end if;
5902                   end;
5903                end if;
5904             end;
5905          end if;
5906
5907          --  Otherwise see if all record components are initialized
5908
5909          declare
5910             Ent : Entity_Id;
5911
5912          begin
5913             Ent := First_Entity (Typ);
5914             while Present (Ent) loop
5915                if Chars (Ent) = Name_uController then
5916                   null;
5917
5918                elsif Ekind (Ent) = E_Component
5919                  and then (No (Parent (Ent))
5920                              or else No (Expression (Parent (Ent))))
5921                  and then not Is_Fully_Initialized_Type (Etype (Ent))
5922
5923                   --  Special VM case for uTag component, which needs to be
5924                   --  defined in this case, but is never initialized as VMs
5925                   --  are using other dispatching mechanisms. Ignore this
5926                   --  uninitialized case.
5927
5928                  and then (VM_Target = No_VM
5929                             or else Chars (Ent) /= Name_uTag)
5930                then
5931                   return False;
5932                end if;
5933
5934                Next_Entity (Ent);
5935             end loop;
5936          end;
5937
5938          --  No uninitialized components, so type is fully initialized.
5939          --  Note that this catches the case of no components as well.
5940
5941          return True;
5942
5943       elsif Is_Concurrent_Type (Typ) then
5944          return True;
5945
5946       elsif Is_Private_Type (Typ) then
5947          declare
5948             U : constant Entity_Id := Underlying_Type (Typ);
5949
5950          begin
5951             if No (U) then
5952                return False;
5953             else
5954                return Is_Fully_Initialized_Type (U);
5955             end if;
5956          end;
5957
5958       else
5959          return False;
5960       end if;
5961    end Is_Fully_Initialized_Type;
5962
5963    ----------------------------------
5964    -- Is_Fully_Initialized_Variant --
5965    ----------------------------------
5966
5967    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
5968       Loc           : constant Source_Ptr := Sloc (Typ);
5969       Constraints   : constant List_Id    := New_List;
5970       Components    : constant Elist_Id   := New_Elmt_List;
5971       Comp_Elmt     : Elmt_Id;
5972       Comp_Id       : Node_Id;
5973       Comp_List     : Node_Id;
5974       Discr         : Entity_Id;
5975       Discr_Val     : Node_Id;
5976
5977       Report_Errors : Boolean;
5978       pragma Warnings (Off, Report_Errors);
5979
5980    begin
5981       if Serious_Errors_Detected > 0 then
5982          return False;
5983       end if;
5984
5985       if Is_Record_Type (Typ)
5986         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
5987         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
5988       then
5989          Comp_List := Component_List (Type_Definition (Parent (Typ)));
5990
5991          Discr := First_Discriminant (Typ);
5992          while Present (Discr) loop
5993             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
5994                Discr_Val := Expression (Parent (Discr));
5995
5996                if Present (Discr_Val)
5997                  and then Is_OK_Static_Expression (Discr_Val)
5998                then
5999                   Append_To (Constraints,
6000                     Make_Component_Association (Loc,
6001                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
6002                       Expression => New_Copy (Discr_Val)));
6003                else
6004                   return False;
6005                end if;
6006             else
6007                return False;
6008             end if;
6009
6010             Next_Discriminant (Discr);
6011          end loop;
6012
6013          Gather_Components
6014            (Typ           => Typ,
6015             Comp_List     => Comp_List,
6016             Governed_By   => Constraints,
6017             Into          => Components,
6018             Report_Errors => Report_Errors);
6019
6020          --  Check that each component present is fully initialized
6021
6022          Comp_Elmt := First_Elmt (Components);
6023          while Present (Comp_Elmt) loop
6024             Comp_Id := Node (Comp_Elmt);
6025
6026             if Ekind (Comp_Id) = E_Component
6027               and then (No (Parent (Comp_Id))
6028                          or else No (Expression (Parent (Comp_Id))))
6029               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
6030             then
6031                return False;
6032             end if;
6033
6034             Next_Elmt (Comp_Elmt);
6035          end loop;
6036
6037          return True;
6038
6039       elsif Is_Private_Type (Typ) then
6040          declare
6041             U : constant Entity_Id := Underlying_Type (Typ);
6042
6043          begin
6044             if No (U) then
6045                return False;
6046             else
6047                return Is_Fully_Initialized_Variant (U);
6048             end if;
6049          end;
6050       else
6051          return False;
6052       end if;
6053    end Is_Fully_Initialized_Variant;
6054
6055    ----------------------------
6056    -- Is_Inherited_Operation --
6057    ----------------------------
6058
6059    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
6060       Kind : constant Node_Kind := Nkind (Parent (E));
6061    begin
6062       pragma Assert (Is_Overloadable (E));
6063       return Kind = N_Full_Type_Declaration
6064         or else Kind = N_Private_Extension_Declaration
6065         or else Kind = N_Subtype_Declaration
6066         or else (Ekind (E) = E_Enumeration_Literal
6067                   and then Is_Derived_Type (Etype (E)));
6068    end Is_Inherited_Operation;
6069
6070    -----------------------------
6071    -- Is_Library_Level_Entity --
6072    -----------------------------
6073
6074    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
6075    begin
6076       --  The following is a small optimization, and it also properly handles
6077       --  discriminals, which in task bodies might appear in expressions before
6078       --  the corresponding procedure has been created, and which therefore do
6079       --  not have an assigned scope.
6080
6081       if Ekind (E) in Formal_Kind then
6082          return False;
6083       end if;
6084
6085       --  Normal test is simply that the enclosing dynamic scope is Standard
6086
6087       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
6088    end Is_Library_Level_Entity;
6089
6090    ---------------------------------
6091    -- Is_Local_Variable_Reference --
6092    ---------------------------------
6093
6094    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
6095    begin
6096       if not Is_Entity_Name (Expr) then
6097          return False;
6098
6099       else
6100          declare
6101             Ent : constant Entity_Id := Entity (Expr);
6102             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
6103          begin
6104             if Ekind (Ent) /= E_Variable
6105                  and then
6106                Ekind (Ent) /= E_In_Out_Parameter
6107             then
6108                return False;
6109             else
6110                return Present (Sub) and then Sub = Current_Subprogram;
6111             end if;
6112          end;
6113       end if;
6114    end Is_Local_Variable_Reference;
6115
6116    -------------------------
6117    -- Is_Object_Reference --
6118    -------------------------
6119
6120    function Is_Object_Reference (N : Node_Id) return Boolean is
6121    begin
6122       if Is_Entity_Name (N) then
6123          return Present (Entity (N)) and then Is_Object (Entity (N));
6124
6125       else
6126          case Nkind (N) is
6127             when N_Indexed_Component | N_Slice =>
6128                return
6129                  Is_Object_Reference (Prefix (N))
6130                    or else Is_Access_Type (Etype (Prefix (N)));
6131
6132             --  In Ada95, a function call is a constant object; a procedure
6133             --  call is not.
6134
6135             when N_Function_Call =>
6136                return Etype (N) /= Standard_Void_Type;
6137
6138             --  A reference to the stream attribute Input is a function call
6139
6140             when N_Attribute_Reference =>
6141                return Attribute_Name (N) = Name_Input;
6142
6143             when N_Selected_Component =>
6144                return
6145                  Is_Object_Reference (Selector_Name (N))
6146                    and then
6147                      (Is_Object_Reference (Prefix (N))
6148                         or else Is_Access_Type (Etype (Prefix (N))));
6149
6150             when N_Explicit_Dereference =>
6151                return True;
6152
6153             --  A view conversion of a tagged object is an object reference
6154
6155             when N_Type_Conversion =>
6156                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
6157                  and then Is_Tagged_Type (Etype (Expression (N)))
6158                  and then Is_Object_Reference (Expression (N));
6159
6160             --  An unchecked type conversion is considered to be an object if
6161             --  the operand is an object (this construction arises only as a
6162             --  result of expansion activities).
6163
6164             when N_Unchecked_Type_Conversion =>
6165                return True;
6166
6167             when others =>
6168                return False;
6169          end case;
6170       end if;
6171    end Is_Object_Reference;
6172
6173    -----------------------------------
6174    -- Is_OK_Variable_For_Out_Formal --
6175    -----------------------------------
6176
6177    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
6178    begin
6179       Note_Possible_Modification (AV);
6180
6181       --  We must reject parenthesized variable names. The check for
6182       --  Comes_From_Source is present because there are currently
6183       --  cases where the compiler violates this rule (e.g. passing
6184       --  a task object to its controlled Initialize routine).
6185
6186       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
6187          return False;
6188
6189       --  A variable is always allowed
6190
6191       elsif Is_Variable (AV) then
6192          return True;
6193
6194       --  Unchecked conversions are allowed only if they come from the
6195       --  generated code, which sometimes uses unchecked conversions for out
6196       --  parameters in cases where code generation is unaffected. We tell
6197       --  source unchecked conversions by seeing if they are rewrites of an
6198       --  original Unchecked_Conversion function call, or of an explicit
6199       --  conversion of a function call.
6200
6201       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
6202          if Nkind (Original_Node (AV)) = N_Function_Call then
6203             return False;
6204
6205          elsif Comes_From_Source (AV)
6206            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
6207          then
6208             return False;
6209
6210          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
6211             return Is_OK_Variable_For_Out_Formal (Expression (AV));
6212
6213          else
6214             return True;
6215          end if;
6216
6217       --  Normal type conversions are allowed if argument is a variable
6218
6219       elsif Nkind (AV) = N_Type_Conversion then
6220          if Is_Variable (Expression (AV))
6221            and then Paren_Count (Expression (AV)) = 0
6222          then
6223             Note_Possible_Modification (Expression (AV));
6224             return True;
6225
6226          --  We also allow a non-parenthesized expression that raises
6227          --  constraint error if it rewrites what used to be a variable
6228
6229          elsif Raises_Constraint_Error (Expression (AV))
6230             and then Paren_Count (Expression (AV)) = 0
6231             and then Is_Variable (Original_Node (Expression (AV)))
6232          then
6233             return True;
6234
6235          --  Type conversion of something other than a variable
6236
6237          else
6238             return False;
6239          end if;
6240
6241       --  If this node is rewritten, then test the original form, if that is
6242       --  OK, then we consider the rewritten node OK (for example, if the
6243       --  original node is a conversion, then Is_Variable will not be true
6244       --  but we still want to allow the conversion if it converts a variable).
6245
6246       elsif Original_Node (AV) /= AV then
6247          return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
6248
6249       --  All other non-variables are rejected
6250
6251       else
6252          return False;
6253       end if;
6254    end Is_OK_Variable_For_Out_Formal;
6255
6256    ---------------
6257    -- Is_Parent --
6258    ---------------
6259
6260    function Is_Parent
6261      (E1 : Entity_Id;
6262       E2 : Entity_Id) return Boolean
6263    is
6264       Iface_List : List_Id;
6265       T          : Entity_Id := E2;
6266
6267    begin
6268       if Is_Concurrent_Type (T)
6269         or else Is_Concurrent_Record_Type (T)
6270       then
6271          Iface_List := Abstract_Interface_List (E2);
6272
6273          if Is_Empty_List (Iface_List) then
6274             return False;
6275          end if;
6276
6277          T := Etype (First (Iface_List));
6278       end if;
6279
6280       return Is_Ancestor (E1, T);
6281    end Is_Parent;
6282
6283    -----------------------------------
6284    -- Is_Partially_Initialized_Type --
6285    -----------------------------------
6286
6287    function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean is
6288    begin
6289       if Is_Scalar_Type (Typ) then
6290          return False;
6291
6292       elsif Is_Access_Type (Typ) then
6293          return True;
6294
6295       elsif Is_Array_Type (Typ) then
6296
6297          --  If component type is partially initialized, so is array type
6298
6299          if Is_Partially_Initialized_Type (Component_Type (Typ)) then
6300             return True;
6301
6302          --  Otherwise we are only partially initialized if we are fully
6303          --  initialized (this is the empty array case, no point in us
6304          --  duplicating that code here).
6305
6306          else
6307             return Is_Fully_Initialized_Type (Typ);
6308          end if;
6309
6310       elsif Is_Record_Type (Typ) then
6311
6312          --  A discriminated type is always partially initialized
6313
6314          if Has_Discriminants (Typ) then
6315             return True;
6316
6317          --  A tagged type is always partially initialized
6318
6319          elsif Is_Tagged_Type (Typ) then
6320             return True;
6321
6322          --  Case of non-discriminated record
6323
6324          else
6325             declare
6326                Ent : Entity_Id;
6327
6328                Component_Present : Boolean := False;
6329                --  Set True if at least one component is present. If no
6330                --  components are present, then record type is fully
6331                --  initialized (another odd case, like the null array).
6332
6333             begin
6334                --  Loop through components
6335
6336                Ent := First_Entity (Typ);
6337                while Present (Ent) loop
6338                   if Ekind (Ent) = E_Component then
6339                      Component_Present := True;
6340
6341                      --  If a component has an initialization expression then
6342                      --  the enclosing record type is partially initialized
6343
6344                      if Present (Parent (Ent))
6345                        and then Present (Expression (Parent (Ent)))
6346                      then
6347                         return True;
6348
6349                      --  If a component is of a type which is itself partially
6350                      --  initialized, then the enclosing record type is also.
6351
6352                      elsif Is_Partially_Initialized_Type (Etype (Ent)) then
6353                         return True;
6354                      end if;
6355                   end if;
6356
6357                   Next_Entity (Ent);
6358                end loop;
6359
6360                --  No initialized components found. If we found any components
6361                --  they were all uninitialized so the result is false.
6362
6363                if Component_Present then
6364                   return False;
6365
6366                --  But if we found no components, then all the components are
6367                --  initialized so we consider the type to be initialized.
6368
6369                else
6370                   return True;
6371                end if;
6372             end;
6373          end if;
6374
6375       --  Concurrent types are always fully initialized
6376
6377       elsif Is_Concurrent_Type (Typ) then
6378          return True;
6379
6380       --  For a private type, go to underlying type. If there is no underlying
6381       --  type then just assume this partially initialized. Not clear if this
6382       --  can happen in a non-error case, but no harm in testing for this.
6383
6384       elsif Is_Private_Type (Typ) then
6385          declare
6386             U : constant Entity_Id := Underlying_Type (Typ);
6387          begin
6388             if No (U) then
6389                return True;
6390             else
6391                return Is_Partially_Initialized_Type (U);
6392             end if;
6393          end;
6394
6395       --  For any other type (are there any?) assume partially initialized
6396
6397       else
6398          return True;
6399       end if;
6400    end Is_Partially_Initialized_Type;
6401
6402    ------------------------------------
6403    -- Is_Potentially_Persistent_Type --
6404    ------------------------------------
6405
6406    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
6407       Comp : Entity_Id;
6408       Indx : Node_Id;
6409
6410    begin
6411       --  For private type, test corrresponding full type
6412
6413       if Is_Private_Type (T) then
6414          return Is_Potentially_Persistent_Type (Full_View (T));
6415
6416       --  Scalar types are potentially persistent
6417
6418       elsif Is_Scalar_Type (T) then
6419          return True;
6420
6421       --  Record type is potentially persistent if not tagged and the types of
6422       --  all it components are potentially persistent, and no component has
6423       --  an initialization expression.
6424
6425       elsif Is_Record_Type (T)
6426         and then not Is_Tagged_Type (T)
6427         and then not Is_Partially_Initialized_Type (T)
6428       then
6429          Comp := First_Component (T);
6430          while Present (Comp) loop
6431             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
6432                return False;
6433             else
6434                Next_Entity (Comp);
6435             end if;
6436          end loop;
6437
6438          return True;
6439
6440       --  Array type is potentially persistent if its component type is
6441       --  potentially persistent and if all its constraints are static.
6442
6443       elsif Is_Array_Type (T) then
6444          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
6445             return False;
6446          end if;
6447
6448          Indx := First_Index (T);
6449          while Present (Indx) loop
6450             if not Is_OK_Static_Subtype (Etype (Indx)) then
6451                return False;
6452             else
6453                Next_Index (Indx);
6454             end if;
6455          end loop;
6456
6457          return True;
6458
6459       --  All other types are not potentially persistent
6460
6461       else
6462          return False;
6463       end if;
6464    end Is_Potentially_Persistent_Type;
6465
6466    -----------------------------
6467    -- Is_RCI_Pkg_Spec_Or_Body --
6468    -----------------------------
6469
6470    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
6471
6472       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
6473       --  Return True if the unit of Cunit is an RCI package declaration
6474
6475       ---------------------------
6476       -- Is_RCI_Pkg_Decl_Cunit --
6477       ---------------------------
6478
6479       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
6480          The_Unit : constant Node_Id := Unit (Cunit);
6481
6482       begin
6483          if Nkind (The_Unit) /= N_Package_Declaration then
6484             return False;
6485          end if;
6486
6487          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
6488       end Is_RCI_Pkg_Decl_Cunit;
6489
6490    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
6491
6492    begin
6493       return Is_RCI_Pkg_Decl_Cunit (Cunit)
6494         or else
6495          (Nkind (Unit (Cunit)) = N_Package_Body
6496            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
6497    end Is_RCI_Pkg_Spec_Or_Body;
6498
6499    -----------------------------------------
6500    -- Is_Remote_Access_To_Class_Wide_Type --
6501    -----------------------------------------
6502
6503    function Is_Remote_Access_To_Class_Wide_Type
6504      (E : Entity_Id) return Boolean
6505    is
6506       D : Entity_Id;
6507
6508       function Comes_From_Limited_Private_Type_Declaration
6509         (E : Entity_Id) return Boolean;
6510       --  Check that the type is declared by a limited type declaration,
6511       --  or else is derived from a Remote_Type ancestor through private
6512       --  extensions.
6513
6514       -------------------------------------------------
6515       -- Comes_From_Limited_Private_Type_Declaration --
6516       -------------------------------------------------
6517
6518       function Comes_From_Limited_Private_Type_Declaration
6519         (E : Entity_Id) return Boolean
6520       is
6521          N : constant Node_Id := Declaration_Node (E);
6522
6523       begin
6524          if Nkind (N) = N_Private_Type_Declaration
6525            and then Limited_Present (N)
6526          then
6527             return True;
6528          end if;
6529
6530          if Nkind (N) = N_Private_Extension_Declaration then
6531             return
6532               Comes_From_Limited_Private_Type_Declaration (Etype (E))
6533                 or else
6534                  (Is_Remote_Types (Etype (E))
6535                     and then Is_Limited_Record (Etype (E))
6536                     and then Has_Private_Declaration (Etype (E)));
6537          end if;
6538
6539          return False;
6540       end Comes_From_Limited_Private_Type_Declaration;
6541
6542    --  Start of processing for Is_Remote_Access_To_Class_Wide_Type
6543
6544    begin
6545       if not (Is_Remote_Call_Interface (E)
6546                or else Is_Remote_Types (E))
6547         or else Ekind (E) /= E_General_Access_Type
6548       then
6549          return False;
6550       end if;
6551
6552       D := Designated_Type (E);
6553
6554       if Ekind (D) /= E_Class_Wide_Type then
6555          return False;
6556       end if;
6557
6558       return Comes_From_Limited_Private_Type_Declaration
6559                (Defining_Identifier (Parent (D)));
6560    end Is_Remote_Access_To_Class_Wide_Type;
6561
6562    -----------------------------------------
6563    -- Is_Remote_Access_To_Subprogram_Type --
6564    -----------------------------------------
6565
6566    function Is_Remote_Access_To_Subprogram_Type
6567      (E : Entity_Id) return Boolean
6568    is
6569    begin
6570       return (Ekind (E) = E_Access_Subprogram_Type
6571                 or else (Ekind (E) = E_Record_Type
6572                            and then Present (Corresponding_Remote_Type (E))))
6573         and then (Is_Remote_Call_Interface (E)
6574                    or else Is_Remote_Types (E));
6575    end Is_Remote_Access_To_Subprogram_Type;
6576
6577    --------------------
6578    -- Is_Remote_Call --
6579    --------------------
6580
6581    function Is_Remote_Call (N : Node_Id) return Boolean is
6582    begin
6583       if Nkind (N) /= N_Procedure_Call_Statement
6584         and then Nkind (N) /= N_Function_Call
6585       then
6586          --  An entry call cannot be remote
6587
6588          return False;
6589
6590       elsif Nkind (Name (N)) in N_Has_Entity
6591         and then Is_Remote_Call_Interface (Entity (Name (N)))
6592       then
6593          --  A subprogram declared in the spec of a RCI package is remote
6594
6595          return True;
6596
6597       elsif Nkind (Name (N)) = N_Explicit_Dereference
6598         and then Is_Remote_Access_To_Subprogram_Type
6599                    (Etype (Prefix (Name (N))))
6600       then
6601          --  The dereference of a RAS is a remote call
6602
6603          return True;
6604
6605       elsif Present (Controlling_Argument (N))
6606         and then Is_Remote_Access_To_Class_Wide_Type
6607           (Etype (Controlling_Argument (N)))
6608       then
6609          --  Any primitive operation call with a controlling argument of
6610          --  a RACW type is a remote call.
6611
6612          return True;
6613       end if;
6614
6615       --  All other calls are local calls
6616
6617       return False;
6618    end Is_Remote_Call;
6619
6620    ----------------------
6621    -- Is_Renamed_Entry --
6622    ----------------------
6623
6624    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
6625       Orig_Node : Node_Id := Empty;
6626       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
6627
6628       function Is_Entry (Nam : Node_Id) return Boolean;
6629       --  Determine whether Nam is an entry. Traverse selectors
6630       --  if there are nested selected components.
6631
6632       --------------
6633       -- Is_Entry --
6634       --------------
6635
6636       function Is_Entry (Nam : Node_Id) return Boolean is
6637       begin
6638          if Nkind (Nam) = N_Selected_Component then
6639             return Is_Entry (Selector_Name (Nam));
6640          end if;
6641
6642          return Ekind (Entity (Nam)) = E_Entry;
6643       end Is_Entry;
6644
6645    --  Start of processing for Is_Renamed_Entry
6646
6647    begin
6648       if Present (Alias (Proc_Nam)) then
6649          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
6650       end if;
6651
6652       --  Look for a rewritten subprogram renaming declaration
6653
6654       if Nkind (Subp_Decl) = N_Subprogram_Declaration
6655         and then Present (Original_Node (Subp_Decl))
6656       then
6657          Orig_Node := Original_Node (Subp_Decl);
6658       end if;
6659
6660       --  The rewritten subprogram is actually an entry
6661
6662       if Present (Orig_Node)
6663         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
6664         and then Is_Entry (Name (Orig_Node))
6665       then
6666          return True;
6667       end if;
6668
6669       return False;
6670    end Is_Renamed_Entry;
6671
6672    ----------------------
6673    -- Is_Selector_Name --
6674    ----------------------
6675
6676    function Is_Selector_Name (N : Node_Id) return Boolean is
6677    begin
6678       if not Is_List_Member (N) then
6679          declare
6680             P : constant Node_Id   := Parent (N);
6681             K : constant Node_Kind := Nkind (P);
6682          begin
6683             return
6684               (K = N_Expanded_Name          or else
6685                K = N_Generic_Association    or else
6686                K = N_Parameter_Association  or else
6687                K = N_Selected_Component)
6688               and then Selector_Name (P) = N;
6689          end;
6690
6691       else
6692          declare
6693             L : constant List_Id := List_Containing (N);
6694             P : constant Node_Id := Parent (L);
6695          begin
6696             return (Nkind (P) = N_Discriminant_Association
6697                      and then Selector_Names (P) = L)
6698               or else
6699                    (Nkind (P) = N_Component_Association
6700                      and then Choices (P) = L);
6701          end;
6702       end if;
6703    end Is_Selector_Name;
6704
6705    ------------------
6706    -- Is_Statement --
6707    ------------------
6708
6709    function Is_Statement (N : Node_Id) return Boolean is
6710    begin
6711       return
6712         Nkind (N) in N_Statement_Other_Than_Procedure_Call
6713           or else Nkind (N) = N_Procedure_Call_Statement;
6714    end Is_Statement;
6715
6716    ---------------------------------
6717    -- Is_Synchronized_Tagged_Type --
6718    ---------------------------------
6719
6720    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
6721       Kind : constant Entity_Kind := Ekind (Base_Type (E));
6722
6723    begin
6724       --  A task or protected type derived from an interface is a tagged type.
6725       --  Such a tagged type is called a synchronized tagged type, as are
6726       --  synchronized interfaces and private extensions whose declaration
6727       --  includes the reserved word synchronized.
6728
6729       return (Is_Tagged_Type (E)
6730                 and then (Kind = E_Task_Type
6731                            or else Kind = E_Protected_Type))
6732             or else
6733              (Is_Interface (E)
6734                 and then Is_Synchronized_Interface (E))
6735             or else
6736              (Ekind (E) = E_Record_Type_With_Private
6737                 and then (Synchronized_Present (Parent (E))
6738                            or else Is_Synchronized_Interface (Etype (E))));
6739    end Is_Synchronized_Tagged_Type;
6740
6741    -----------------
6742    -- Is_Transfer --
6743    -----------------
6744
6745    function Is_Transfer (N : Node_Id) return Boolean is
6746       Kind : constant Node_Kind := Nkind (N);
6747
6748    begin
6749       if Kind = N_Simple_Return_Statement
6750            or else
6751          Kind = N_Extended_Return_Statement
6752            or else
6753          Kind = N_Goto_Statement
6754            or else
6755          Kind = N_Raise_Statement
6756            or else
6757          Kind = N_Requeue_Statement
6758       then
6759          return True;
6760
6761       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
6762         and then No (Condition (N))
6763       then
6764          return True;
6765
6766       elsif Kind = N_Procedure_Call_Statement
6767         and then Is_Entity_Name (Name (N))
6768         and then Present (Entity (Name (N)))
6769         and then No_Return (Entity (Name (N)))
6770       then
6771          return True;
6772
6773       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
6774          return True;
6775
6776       else
6777          return False;
6778       end if;
6779    end Is_Transfer;
6780
6781    -------------
6782    -- Is_True --
6783    -------------
6784
6785    function Is_True (U : Uint) return Boolean is
6786    begin
6787       return (U /= 0);
6788    end Is_True;
6789
6790    -------------------
6791    -- Is_Value_Type --
6792    -------------------
6793
6794    function Is_Value_Type (T : Entity_Id) return Boolean is
6795    begin
6796       return VM_Target = CLI_Target
6797         and then Chars (T) /= No_Name
6798         and then Get_Name_String (Chars (T)) = "valuetype";
6799    end Is_Value_Type;
6800
6801    -----------------
6802    -- Is_Variable --
6803    -----------------
6804
6805    function Is_Variable (N : Node_Id) return Boolean is
6806
6807       Orig_Node : constant Node_Id := Original_Node (N);
6808       --  We do the test on the original node, since this is basically a
6809       --  test of syntactic categories, so it must not be disturbed by
6810       --  whatever rewriting might have occurred. For example, an aggregate,
6811       --  which is certainly NOT a variable, could be turned into a variable
6812       --  by expansion.
6813
6814       function In_Protected_Function (E : Entity_Id) return Boolean;
6815       --  Within a protected function, the private components of the
6816       --  enclosing protected type are constants. A function nested within
6817       --  a (protected) procedure is not itself protected.
6818
6819       function Is_Variable_Prefix (P : Node_Id) return Boolean;
6820       --  Prefixes can involve implicit dereferences, in which case we
6821       --  must test for the case of a reference of a constant access
6822       --  type, which can never be a variable.
6823
6824       ---------------------------
6825       -- In_Protected_Function --
6826       ---------------------------
6827
6828       function In_Protected_Function (E : Entity_Id) return Boolean is
6829          Prot : constant Entity_Id := Scope (E);
6830          S    : Entity_Id;
6831
6832       begin
6833          if not Is_Protected_Type (Prot) then
6834             return False;
6835          else
6836             S := Current_Scope;
6837             while Present (S) and then S /= Prot loop
6838                if Ekind (S) = E_Function
6839                  and then Scope (S) = Prot
6840                then
6841                   return True;
6842                end if;
6843
6844                S := Scope (S);
6845             end loop;
6846
6847             return False;
6848          end if;
6849       end In_Protected_Function;
6850
6851       ------------------------
6852       -- Is_Variable_Prefix --
6853       ------------------------
6854
6855       function Is_Variable_Prefix (P : Node_Id) return Boolean is
6856       begin
6857          if Is_Access_Type (Etype (P)) then
6858             return not Is_Access_Constant (Root_Type (Etype (P)));
6859
6860          --  For the case of an indexed component whose prefix has a packed
6861          --  array type, the prefix has been rewritten into a type conversion.
6862          --  Determine variable-ness from the converted expression.
6863
6864          elsif Nkind (P) = N_Type_Conversion
6865            and then not Comes_From_Source (P)
6866            and then Is_Array_Type (Etype (P))
6867            and then Is_Packed (Etype (P))
6868          then
6869             return Is_Variable (Expression (P));
6870
6871          else
6872             return Is_Variable (P);
6873          end if;
6874       end Is_Variable_Prefix;
6875
6876    --  Start of processing for Is_Variable
6877
6878    begin
6879       --  Definitely OK if Assignment_OK is set. Since this is something that
6880       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
6881
6882       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
6883          return True;
6884
6885       --  Normally we go to the original node, but there is one exception
6886       --  where we use the rewritten node, namely when it is an explicit
6887       --  dereference. The generated code may rewrite a prefix which is an
6888       --  access type with an explicit dereference. The dereference is a
6889       --  variable, even though the original node may not be (since it could
6890       --  be a constant of the access type).
6891
6892       --  In Ada 2005 we have a further case to consider: the prefix may be
6893       --  a function call given in prefix notation. The original node appears
6894       --  to be a selected component, but we need to examine the call.
6895
6896       elsif Nkind (N) = N_Explicit_Dereference
6897         and then Nkind (Orig_Node) /= N_Explicit_Dereference
6898         and then Present (Etype (Orig_Node))
6899         and then Is_Access_Type (Etype (Orig_Node))
6900       then
6901          return Is_Variable_Prefix (Original_Node (Prefix (N)))
6902            or else
6903              (Nkind (Orig_Node) = N_Function_Call
6904                and then not Is_Access_Constant (Etype (Prefix (N))));
6905
6906       --  A function call is never a variable
6907
6908       elsif Nkind (N) = N_Function_Call then
6909          return False;
6910
6911       --  All remaining checks use the original node
6912
6913       elsif Is_Entity_Name (Orig_Node)
6914         and then Present (Entity (Orig_Node))
6915       then
6916          declare
6917             E : constant Entity_Id := Entity (Orig_Node);
6918             K : constant Entity_Kind := Ekind (E);
6919
6920          begin
6921             return (K = E_Variable
6922                       and then Nkind (Parent (E)) /= N_Exception_Handler)
6923               or else  (K = E_Component
6924                           and then not In_Protected_Function (E))
6925               or else  K = E_Out_Parameter
6926               or else  K = E_In_Out_Parameter
6927               or else  K = E_Generic_In_Out_Parameter
6928
6929                --  Current instance of type:
6930
6931               or else (Is_Type (E) and then In_Open_Scopes (E))
6932               or else (Is_Incomplete_Or_Private_Type (E)
6933                         and then In_Open_Scopes (Full_View (E)));
6934          end;
6935
6936       else
6937          case Nkind (Orig_Node) is
6938             when N_Indexed_Component | N_Slice =>
6939                return Is_Variable_Prefix (Prefix (Orig_Node));
6940
6941             when N_Selected_Component =>
6942                return Is_Variable_Prefix (Prefix (Orig_Node))
6943                  and then Is_Variable (Selector_Name (Orig_Node));
6944
6945             --  For an explicit dereference, the type of the prefix cannot
6946             --  be an access to constant or an access to subprogram.
6947
6948             when N_Explicit_Dereference =>
6949                declare
6950                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
6951                begin
6952                   return Is_Access_Type (Typ)
6953                     and then not Is_Access_Constant (Root_Type (Typ))
6954                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
6955                end;
6956
6957             --  The type conversion is the case where we do not deal with the
6958             --  context dependent special case of an actual parameter. Thus
6959             --  the type conversion is only considered a variable for the
6960             --  purposes of this routine if the target type is tagged. However,
6961             --  a type conversion is considered to be a variable if it does not
6962             --  come from source (this deals for example with the conversions
6963             --  of expressions to their actual subtypes).
6964
6965             when N_Type_Conversion =>
6966                return Is_Variable (Expression (Orig_Node))
6967                  and then
6968                    (not Comes_From_Source (Orig_Node)
6969                       or else
6970                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
6971                           and then
6972                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
6973
6974             --  GNAT allows an unchecked type conversion as a variable. This
6975             --  only affects the generation of internal expanded code, since
6976             --  calls to instantiations of Unchecked_Conversion are never
6977             --  considered variables (since they are function calls).
6978             --  This is also true for expression actions.
6979
6980             when N_Unchecked_Type_Conversion =>
6981                return Is_Variable (Expression (Orig_Node));
6982
6983             when others =>
6984                return False;
6985          end case;
6986       end if;
6987    end Is_Variable;
6988
6989    ------------------------
6990    -- Is_Volatile_Object --
6991    ------------------------
6992
6993    function Is_Volatile_Object (N : Node_Id) return Boolean is
6994
6995       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
6996       --  Determines if given object has volatile components
6997
6998       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
6999       --  If prefix is an implicit dereference, examine designated type
7000
7001       ------------------------
7002       -- Is_Volatile_Prefix --
7003       ------------------------
7004
7005       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
7006          Typ  : constant Entity_Id := Etype (N);
7007
7008       begin
7009          if Is_Access_Type (Typ) then
7010             declare
7011                Dtyp : constant Entity_Id := Designated_Type (Typ);
7012
7013             begin
7014                return Is_Volatile (Dtyp)
7015                  or else Has_Volatile_Components (Dtyp);
7016             end;
7017
7018          else
7019             return Object_Has_Volatile_Components (N);
7020          end if;
7021       end Is_Volatile_Prefix;
7022
7023       ------------------------------------
7024       -- Object_Has_Volatile_Components --
7025       ------------------------------------
7026
7027       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
7028          Typ : constant Entity_Id := Etype (N);
7029
7030       begin
7031          if Is_Volatile (Typ)
7032            or else Has_Volatile_Components (Typ)
7033          then
7034             return True;
7035
7036          elsif Is_Entity_Name (N)
7037            and then (Has_Volatile_Components (Entity (N))
7038                       or else Is_Volatile (Entity (N)))
7039          then
7040             return True;
7041
7042          elsif Nkind (N) = N_Indexed_Component
7043            or else Nkind (N) = N_Selected_Component
7044          then
7045             return Is_Volatile_Prefix (Prefix (N));
7046
7047          else
7048             return False;
7049          end if;
7050       end Object_Has_Volatile_Components;
7051
7052    --  Start of processing for Is_Volatile_Object
7053
7054    begin
7055       if Is_Volatile (Etype (N))
7056         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
7057       then
7058          return True;
7059
7060       elsif Nkind (N) = N_Indexed_Component
7061         or else Nkind (N) = N_Selected_Component
7062       then
7063          return Is_Volatile_Prefix (Prefix (N));
7064
7065       else
7066          return False;
7067       end if;
7068    end Is_Volatile_Object;
7069
7070    -------------------------
7071    -- Kill_Current_Values --
7072    -------------------------
7073
7074    procedure Kill_Current_Values
7075      (Ent                  : Entity_Id;
7076       Last_Assignment_Only : Boolean := False)
7077    is
7078    begin
7079       if Is_Assignable (Ent) then
7080          Set_Last_Assignment (Ent, Empty);
7081       end if;
7082
7083       if not Last_Assignment_Only and then Is_Object (Ent) then
7084          Kill_Checks (Ent);
7085          Set_Current_Value (Ent, Empty);
7086
7087          if not Can_Never_Be_Null (Ent) then
7088             Set_Is_Known_Non_Null (Ent, False);
7089          end if;
7090
7091          Set_Is_Known_Null (Ent, False);
7092       end if;
7093    end Kill_Current_Values;
7094
7095    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
7096       S : Entity_Id;
7097
7098       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
7099       --  Clear current value for entity E and all entities chained to E
7100
7101       ------------------------------------------
7102       -- Kill_Current_Values_For_Entity_Chain --
7103       ------------------------------------------
7104
7105       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
7106          Ent : Entity_Id;
7107       begin
7108          Ent := E;
7109          while Present (Ent) loop
7110             Kill_Current_Values (Ent, Last_Assignment_Only);
7111             Next_Entity (Ent);
7112          end loop;
7113       end Kill_Current_Values_For_Entity_Chain;
7114
7115    --  Start of processing for Kill_Current_Values
7116
7117    begin
7118       --  Kill all saved checks, a special case of killing saved values
7119
7120       if not Last_Assignment_Only then
7121          Kill_All_Checks;
7122       end if;
7123
7124       --  Loop through relevant scopes, which includes the current scope and
7125       --  any parent scopes if the current scope is a block or a package.
7126
7127       S := Current_Scope;
7128       Scope_Loop : loop
7129
7130          --  Clear current values of all entities in current scope
7131
7132          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
7133
7134          --  If scope is a package, also clear current values of all
7135          --  private entities in the scope.
7136
7137          if Ekind (S) = E_Package
7138               or else
7139             Ekind (S) = E_Generic_Package
7140               or else
7141             Is_Concurrent_Type (S)
7142          then
7143             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
7144          end if;
7145
7146          --  If this is a not a subprogram, deal with parents
7147
7148          if not Is_Subprogram (S) then
7149             S := Scope (S);
7150             exit Scope_Loop when S = Standard_Standard;
7151          else
7152             exit Scope_Loop;
7153          end if;
7154       end loop Scope_Loop;
7155    end Kill_Current_Values;
7156
7157    --------------------------
7158    -- Kill_Size_Check_Code --
7159    --------------------------
7160
7161    procedure Kill_Size_Check_Code (E : Entity_Id) is
7162    begin
7163       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
7164         and then Present (Size_Check_Code (E))
7165       then
7166          Remove (Size_Check_Code (E));
7167          Set_Size_Check_Code (E, Empty);
7168       end if;
7169    end Kill_Size_Check_Code;
7170
7171    --------------------------
7172    -- Known_To_Be_Assigned --
7173    --------------------------
7174
7175    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
7176       P : constant Node_Id := Parent (N);
7177
7178    begin
7179       case Nkind (P) is
7180
7181          --  Test left side of assignment
7182
7183          when N_Assignment_Statement =>
7184             return N = Name (P);
7185
7186             --  Function call arguments are never lvalues
7187
7188          when N_Function_Call =>
7189             return False;
7190
7191          --  Positional parameter for procedure or accept call
7192
7193          when N_Procedure_Call_Statement |
7194               N_Accept_Statement
7195           =>
7196             declare
7197                Proc : Entity_Id;
7198                Form : Entity_Id;
7199                Act  : Node_Id;
7200
7201             begin
7202                Proc := Get_Subprogram_Entity (P);
7203
7204                if No (Proc) then
7205                   return False;
7206                end if;
7207
7208                --  If we are not a list member, something is strange, so
7209                --  be conservative and return False.
7210
7211                if not Is_List_Member (N) then
7212                   return False;
7213                end if;
7214
7215                --  We are going to find the right formal by stepping forward
7216                --  through the formals, as we step backwards in the actuals.
7217
7218                Form := First_Formal (Proc);
7219                Act  := N;
7220                loop
7221                   --  If no formal, something is weird, so be conservative
7222                   --  and return False.
7223
7224                   if No (Form) then
7225                      return False;
7226                   end if;
7227
7228                   Prev (Act);
7229                   exit when No (Act);
7230                   Next_Formal (Form);
7231                end loop;
7232
7233                return Ekind (Form) /= E_In_Parameter;
7234             end;
7235
7236          --  Named parameter for procedure or accept call
7237
7238          when N_Parameter_Association =>
7239             declare
7240                Proc : Entity_Id;
7241                Form : Entity_Id;
7242
7243             begin
7244                Proc := Get_Subprogram_Entity (Parent (P));
7245
7246                if No (Proc) then
7247                   return False;
7248                end if;
7249
7250                --  Loop through formals to find the one that matches
7251
7252                Form := First_Formal (Proc);
7253                loop
7254                   --  If no matching formal, that's peculiar, some kind of
7255                   --  previous error, so return False to be conservative.
7256
7257                   if No (Form) then
7258                      return False;
7259                   end if;
7260
7261                   --  Else test for match
7262
7263                   if Chars (Form) = Chars (Selector_Name (P)) then
7264                      return Ekind (Form) /= E_In_Parameter;
7265                   end if;
7266
7267                   Next_Formal (Form);
7268                end loop;
7269             end;
7270
7271          --  Test for appearing in a conversion that itself appears
7272          --  in an lvalue context, since this should be an lvalue.
7273
7274          when N_Type_Conversion =>
7275             return Known_To_Be_Assigned (P);
7276
7277          --  All other references are definitely not knwon to be modifications
7278
7279          when others =>
7280             return False;
7281
7282       end case;
7283    end Known_To_Be_Assigned;
7284
7285    -------------------
7286    -- May_Be_Lvalue --
7287    -------------------
7288
7289    function May_Be_Lvalue (N : Node_Id) return Boolean is
7290       P : constant Node_Id := Parent (N);
7291
7292    begin
7293       case Nkind (P) is
7294
7295          --  Test left side of assignment
7296
7297          when N_Assignment_Statement =>
7298             return N = Name (P);
7299
7300          --  Test prefix of component or attribute
7301
7302          when N_Attribute_Reference =>
7303             return N = Prefix (P)
7304               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
7305
7306          when N_Expanded_Name        |
7307               N_Explicit_Dereference |
7308               N_Indexed_Component    |
7309               N_Reference            |
7310               N_Selected_Component   |
7311               N_Slice                =>
7312             return N = Prefix (P);
7313
7314          --  Function call arguments are never lvalues
7315
7316          when N_Function_Call =>
7317             return False;
7318
7319          --  Positional parameter for procedure, entry,  or accept call
7320
7321          when N_Procedure_Call_Statement |
7322               N_Entry_Call_Statement     |
7323               N_Accept_Statement
7324          =>
7325             declare
7326                Proc : Entity_Id;
7327                Form : Entity_Id;
7328                Act  : Node_Id;
7329
7330             begin
7331                Proc := Get_Subprogram_Entity (P);
7332
7333                if No (Proc) then
7334                   return True;
7335                end if;
7336
7337                --  If we are not a list member, something is strange, so
7338                --  be conservative and return True.
7339
7340                if not Is_List_Member (N) then
7341                   return True;
7342                end if;
7343
7344                --  We are going to find the right formal by stepping forward
7345                --  through the formals, as we step backwards in the actuals.
7346
7347                Form := First_Formal (Proc);
7348                Act  := N;
7349                loop
7350                   --  If no formal, something is weird, so be conservative
7351                   --  and return True.
7352
7353                   if No (Form) then
7354                      return True;
7355                   end if;
7356
7357                   Prev (Act);
7358                   exit when No (Act);
7359                   Next_Formal (Form);
7360                end loop;
7361
7362                return Ekind (Form) /= E_In_Parameter;
7363             end;
7364
7365          --  Named parameter for procedure or accept call
7366
7367          when N_Parameter_Association =>
7368             declare
7369                Proc : Entity_Id;
7370                Form : Entity_Id;
7371
7372             begin
7373                Proc := Get_Subprogram_Entity (Parent (P));
7374
7375                if No (Proc) then
7376                   return True;
7377                end if;
7378
7379                --  Loop through formals to find the one that matches
7380
7381                Form := First_Formal (Proc);
7382                loop
7383                   --  If no matching formal, that's peculiar, some kind of
7384                   --  previous error, so return True to be conservative.
7385
7386                   if No (Form) then
7387                      return True;
7388                   end if;
7389
7390                   --  Else test for match
7391
7392                   if Chars (Form) = Chars (Selector_Name (P)) then
7393                      return Ekind (Form) /= E_In_Parameter;
7394                   end if;
7395
7396                   Next_Formal (Form);
7397                end loop;
7398             end;
7399
7400          --  Test for appearing in a conversion that itself appears in an
7401          --  lvalue context, since this should be an lvalue.
7402
7403          when N_Type_Conversion =>
7404             return May_Be_Lvalue (P);
7405
7406          --  Test for appearence in object renaming declaration
7407
7408          when N_Object_Renaming_Declaration =>
7409             return True;
7410
7411          --  All other references are definitely not Lvalues
7412
7413          when others =>
7414             return False;
7415
7416       end case;
7417    end May_Be_Lvalue;
7418
7419    -----------------------
7420    -- Mark_Coextensions --
7421    -----------------------
7422
7423    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
7424       Is_Dynamic : Boolean;
7425       --  Indicates whether the context causes nested coextensions to be
7426       --  dynamic or static
7427
7428       function Mark_Allocator (N : Node_Id) return Traverse_Result;
7429       --  Recognize an allocator node and label it as a dynamic coextension
7430
7431       --------------------
7432       -- Mark_Allocator --
7433       --------------------
7434
7435       function Mark_Allocator (N : Node_Id) return Traverse_Result is
7436       begin
7437          if Nkind (N) = N_Allocator then
7438             if Is_Dynamic then
7439                Set_Is_Dynamic_Coextension (N);
7440             else
7441                Set_Is_Static_Coextension (N);
7442             end if;
7443          end if;
7444
7445          return OK;
7446       end Mark_Allocator;
7447
7448       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
7449
7450    --  Start of processing Mark_Coextensions
7451
7452    begin
7453       case Nkind (Context_Nod) is
7454          when N_Assignment_Statement    |
7455               N_Simple_Return_Statement =>
7456             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
7457
7458          when N_Object_Declaration =>
7459             Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
7460
7461          --  This routine should not be called for constructs which may not
7462          --  contain coextensions.
7463
7464          when others =>
7465             raise Program_Error;
7466       end case;
7467
7468       Mark_Allocators (Root_Nod);
7469    end Mark_Coextensions;
7470
7471    ----------------------
7472    -- Needs_One_Actual --
7473    ----------------------
7474
7475    function Needs_One_Actual (E : Entity_Id) return Boolean is
7476       Formal : Entity_Id;
7477
7478    begin
7479       if Ada_Version >= Ada_05
7480         and then Present (First_Formal (E))
7481       then
7482          Formal := Next_Formal (First_Formal (E));
7483          while Present (Formal) loop
7484             if No (Default_Value (Formal)) then
7485                return False;
7486             end if;
7487
7488             Next_Formal (Formal);
7489          end loop;
7490
7491          return True;
7492
7493       else
7494          return False;
7495       end if;
7496    end Needs_One_Actual;
7497
7498    -------------------------
7499    -- New_External_Entity --
7500    -------------------------
7501
7502    function New_External_Entity
7503      (Kind         : Entity_Kind;
7504       Scope_Id     : Entity_Id;
7505       Sloc_Value   : Source_Ptr;
7506       Related_Id   : Entity_Id;
7507       Suffix       : Character;
7508       Suffix_Index : Nat := 0;
7509       Prefix       : Character := ' ') return Entity_Id
7510    is
7511       N : constant Entity_Id :=
7512             Make_Defining_Identifier (Sloc_Value,
7513               New_External_Name
7514                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
7515
7516    begin
7517       Set_Ekind          (N, Kind);
7518       Set_Is_Internal    (N, True);
7519       Append_Entity      (N, Scope_Id);
7520       Set_Public_Status  (N);
7521
7522       if Kind in Type_Kind then
7523          Init_Size_Align (N);
7524       end if;
7525
7526       return N;
7527    end New_External_Entity;
7528
7529    -------------------------
7530    -- New_Internal_Entity --
7531    -------------------------
7532
7533    function New_Internal_Entity
7534      (Kind       : Entity_Kind;
7535       Scope_Id   : Entity_Id;
7536       Sloc_Value : Source_Ptr;
7537       Id_Char    : Character) return Entity_Id
7538    is
7539       N : constant Entity_Id :=
7540             Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
7541
7542    begin
7543       Set_Ekind          (N, Kind);
7544       Set_Is_Internal    (N, True);
7545       Append_Entity      (N, Scope_Id);
7546
7547       if Kind in Type_Kind then
7548          Init_Size_Align (N);
7549       end if;
7550
7551       return N;
7552    end New_Internal_Entity;
7553
7554    -----------------
7555    -- Next_Actual --
7556    -----------------
7557
7558    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
7559       N  : Node_Id;
7560
7561    begin
7562       --  If we are pointing at a positional parameter, it is a member of a
7563       --  node list (the list of parameters), and the next parameter is the
7564       --  next node on the list, unless we hit a parameter association, then
7565       --  we shift to using the chain whose head is the First_Named_Actual in
7566       --  the parent, and then is threaded using the Next_Named_Actual of the
7567       --  Parameter_Association. All this fiddling is because the original node
7568       --  list is in the textual call order, and what we need is the
7569       --  declaration order.
7570
7571       if Is_List_Member (Actual_Id) then
7572          N := Next (Actual_Id);
7573
7574          if Nkind (N) = N_Parameter_Association then
7575             return First_Named_Actual (Parent (Actual_Id));
7576          else
7577             return N;
7578          end if;
7579
7580       else
7581          return Next_Named_Actual (Parent (Actual_Id));
7582       end if;
7583    end Next_Actual;
7584
7585    procedure Next_Actual (Actual_Id : in out Node_Id) is
7586    begin
7587       Actual_Id := Next_Actual (Actual_Id);
7588    end Next_Actual;
7589
7590    -----------------------
7591    -- Normalize_Actuals --
7592    -----------------------
7593
7594    --  Chain actuals according to formals of subprogram. If there are no named
7595    --  associations, the chain is simply the list of Parameter Associations,
7596    --  since the order is the same as the declaration order. If there are named
7597    --  associations, then the First_Named_Actual field in the N_Function_Call
7598    --  or N_Procedure_Call_Statement node points to the Parameter_Association
7599    --  node for the parameter that comes first in declaration order. The
7600    --  remaining named parameters are then chained in declaration order using
7601    --  Next_Named_Actual.
7602
7603    --  This routine also verifies that the number of actuals is compatible with
7604    --  the number and default values of formals, but performs no type checking
7605    --  (type checking is done by the caller).
7606
7607    --  If the matching succeeds, Success is set to True and the caller proceeds
7608    --  with type-checking. If the match is unsuccessful, then Success is set to
7609    --  False, and the caller attempts a different interpretation, if there is
7610    --  one.
7611
7612    --  If the flag Report is on, the call is not overloaded, and a failure to
7613    --  match can be reported here, rather than in the caller.
7614
7615    procedure Normalize_Actuals
7616      (N       : Node_Id;
7617       S       : Entity_Id;
7618       Report  : Boolean;
7619       Success : out Boolean)
7620    is
7621       Actuals     : constant List_Id := Parameter_Associations (N);
7622       Actual      : Node_Id := Empty;
7623       Formal      : Entity_Id;
7624       Last        : Node_Id := Empty;
7625       First_Named : Node_Id := Empty;
7626       Found       : Boolean;
7627
7628       Formals_To_Match : Integer := 0;
7629       Actuals_To_Match : Integer := 0;
7630
7631       procedure Chain (A : Node_Id);
7632       --  Add named actual at the proper place in the list, using the
7633       --  Next_Named_Actual link.
7634
7635       function Reporting return Boolean;
7636       --  Determines if an error is to be reported. To report an error, we
7637       --  need Report to be True, and also we do not report errors caused
7638       --  by calls to init procs that occur within other init procs. Such
7639       --  errors must always be cascaded errors, since if all the types are
7640       --  declared correctly, the compiler will certainly build decent calls!
7641
7642       -----------
7643       -- Chain --
7644       -----------
7645
7646       procedure Chain (A : Node_Id) is
7647       begin
7648          if No (Last) then
7649
7650             --  Call node points to first actual in list
7651
7652             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
7653
7654          else
7655             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
7656          end if;
7657
7658          Last := A;
7659          Set_Next_Named_Actual (Last, Empty);
7660       end Chain;
7661
7662       ---------------
7663       -- Reporting --
7664       ---------------
7665
7666       function Reporting return Boolean is
7667       begin
7668          if not Report then
7669             return False;
7670
7671          elsif not Within_Init_Proc then
7672             return True;
7673
7674          elsif Is_Init_Proc (Entity (Name (N))) then
7675             return False;
7676
7677          else
7678             return True;
7679          end if;
7680       end Reporting;
7681
7682    --  Start of processing for Normalize_Actuals
7683
7684    begin
7685       if Is_Access_Type (S) then
7686
7687          --  The name in the call is a function call that returns an access
7688          --  to subprogram. The designated type has the list of formals.
7689
7690          Formal := First_Formal (Designated_Type (S));
7691       else
7692          Formal := First_Formal (S);
7693       end if;
7694
7695       while Present (Formal) loop
7696          Formals_To_Match := Formals_To_Match + 1;
7697          Next_Formal (Formal);
7698       end loop;
7699
7700       --  Find if there is a named association, and verify that no positional
7701       --  associations appear after named ones.
7702
7703       if Present (Actuals) then
7704          Actual := First (Actuals);
7705       end if;
7706
7707       while Present (Actual)
7708         and then Nkind (Actual) /= N_Parameter_Association
7709       loop
7710          Actuals_To_Match := Actuals_To_Match + 1;
7711          Next (Actual);
7712       end loop;
7713
7714       if No (Actual) and Actuals_To_Match = Formals_To_Match then
7715
7716          --  Most common case: positional notation, no defaults
7717
7718          Success := True;
7719          return;
7720
7721       elsif Actuals_To_Match > Formals_To_Match then
7722
7723          --  Too many actuals: will not work
7724
7725          if Reporting then
7726             if Is_Entity_Name (Name (N)) then
7727                Error_Msg_N ("too many arguments in call to&", Name (N));
7728             else
7729                Error_Msg_N ("too many arguments in call", N);
7730             end if;
7731          end if;
7732
7733          Success := False;
7734          return;
7735       end if;
7736
7737       First_Named := Actual;
7738
7739       while Present (Actual) loop
7740          if Nkind (Actual) /= N_Parameter_Association then
7741             Error_Msg_N
7742               ("positional parameters not allowed after named ones", Actual);
7743             Success := False;
7744             return;
7745
7746          else
7747             Actuals_To_Match := Actuals_To_Match + 1;
7748          end if;
7749
7750          Next (Actual);
7751       end loop;
7752
7753       if Present (Actuals) then
7754          Actual := First (Actuals);
7755       end if;
7756
7757       Formal := First_Formal (S);
7758       while Present (Formal) loop
7759
7760          --  Match the formals in order. If the corresponding actual is
7761          --  positional, nothing to do. Else scan the list of named actuals
7762          --  to find the one with the right name.
7763
7764          if Present (Actual)
7765            and then Nkind (Actual) /= N_Parameter_Association
7766          then
7767             Next (Actual);
7768             Actuals_To_Match := Actuals_To_Match - 1;
7769             Formals_To_Match := Formals_To_Match - 1;
7770
7771          else
7772             --  For named parameters, search the list of actuals to find
7773             --  one that matches the next formal name.
7774
7775             Actual := First_Named;
7776             Found  := False;
7777             while Present (Actual) loop
7778                if Chars (Selector_Name (Actual)) = Chars (Formal) then
7779                   Found := True;
7780                   Chain (Actual);
7781                   Actuals_To_Match := Actuals_To_Match - 1;
7782                   Formals_To_Match := Formals_To_Match - 1;
7783                   exit;
7784                end if;
7785
7786                Next (Actual);
7787             end loop;
7788
7789             if not Found then
7790                if Ekind (Formal) /= E_In_Parameter
7791                  or else No (Default_Value (Formal))
7792                then
7793                   if Reporting then
7794                      if (Comes_From_Source (S)
7795                           or else Sloc (S) = Standard_Location)
7796                        and then Is_Overloadable (S)
7797                      then
7798                         if No (Actuals)
7799                           and then
7800                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
7801                              or else
7802                            (Nkind (Parent (N)) = N_Function_Call
7803                              or else
7804                             Nkind (Parent (N)) = N_Parameter_Association))
7805                           and then Ekind (S) /= E_Function
7806                         then
7807                            Set_Etype (N, Etype (S));
7808                         else
7809                            Error_Msg_Name_1 := Chars (S);
7810                            Error_Msg_Sloc := Sloc (S);
7811                            Error_Msg_NE
7812                              ("missing argument for parameter & " &
7813                                 "in call to % declared #", N, Formal);
7814                         end if;
7815
7816                      elsif Is_Overloadable (S) then
7817                         Error_Msg_Name_1 := Chars (S);
7818
7819                         --  Point to type derivation that generated the
7820                         --  operation.
7821
7822                         Error_Msg_Sloc := Sloc (Parent (S));
7823
7824                         Error_Msg_NE
7825                           ("missing argument for parameter & " &
7826                              "in call to % (inherited) #", N, Formal);
7827
7828                      else
7829                         Error_Msg_NE
7830                           ("missing argument for parameter &", N, Formal);
7831                      end if;
7832                   end if;
7833
7834                   Success := False;
7835                   return;
7836
7837                else
7838                   Formals_To_Match := Formals_To_Match - 1;
7839                end if;
7840             end if;
7841          end if;
7842
7843          Next_Formal (Formal);
7844       end loop;
7845
7846       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
7847          Success := True;
7848          return;
7849
7850       else
7851          if Reporting then
7852
7853             --  Find some superfluous named actual that did not get
7854             --  attached to the list of associations.
7855
7856             Actual := First (Actuals);
7857             while Present (Actual) loop
7858                if Nkind (Actual) = N_Parameter_Association
7859                  and then Actual /= Last
7860                  and then No (Next_Named_Actual (Actual))
7861                then
7862                   Error_Msg_N ("unmatched actual & in call",
7863                     Selector_Name (Actual));
7864                   exit;
7865                end if;
7866
7867                Next (Actual);
7868             end loop;
7869          end if;
7870
7871          Success := False;
7872          return;
7873       end if;
7874    end Normalize_Actuals;
7875
7876    --------------------------------
7877    -- Note_Possible_Modification --
7878    --------------------------------
7879
7880    procedure Note_Possible_Modification (N : Node_Id) is
7881       Modification_Comes_From_Source : constant Boolean :=
7882                                          Comes_From_Source (Parent (N));
7883
7884       Ent : Entity_Id;
7885       Exp : Node_Id;
7886
7887    begin
7888       --  Loop to find referenced entity, if there is one
7889
7890       Exp := N;
7891       loop
7892          <<Continue>>
7893          Ent := Empty;
7894
7895          if Is_Entity_Name (Exp) then
7896             Ent := Entity (Exp);
7897
7898             --  If the entity is missing, it is an undeclared identifier,
7899             --  and there is nothing to annotate.
7900
7901             if No (Ent) then
7902                return;
7903             end if;
7904
7905          elsif Nkind (Exp) = N_Explicit_Dereference then
7906             declare
7907                P : constant Node_Id := Prefix (Exp);
7908
7909             begin
7910                if Nkind (P) = N_Selected_Component
7911                  and then Present (
7912                    Entry_Formal (Entity (Selector_Name (P))))
7913                then
7914                   --  Case of a reference to an entry formal
7915
7916                   Ent := Entry_Formal (Entity (Selector_Name (P)));
7917
7918                elsif Nkind (P) = N_Identifier
7919                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
7920                  and then Present (Expression (Parent (Entity (P))))
7921                  and then Nkind (Expression (Parent (Entity (P))))
7922                    = N_Reference
7923                then
7924                   --  Case of a reference to a value on which side effects have
7925                   --  been removed.
7926
7927                   Exp := Prefix (Expression (Parent (Entity (P))));
7928                   goto Continue;
7929
7930                else
7931                   return;
7932
7933                end if;
7934             end;
7935
7936          elsif     Nkind (Exp) = N_Type_Conversion
7937            or else Nkind (Exp) = N_Unchecked_Type_Conversion
7938          then
7939             Exp := Expression (Exp);
7940             goto Continue;
7941
7942          elsif     Nkind (Exp) = N_Slice
7943            or else Nkind (Exp) = N_Indexed_Component
7944            or else Nkind (Exp) = N_Selected_Component
7945          then
7946             Exp := Prefix (Exp);
7947             goto Continue;
7948
7949          else
7950             return;
7951          end if;
7952
7953          --  Now look for entity being referenced
7954
7955          if Present (Ent) then
7956             if Is_Object (Ent) then
7957                if Comes_From_Source (Exp)
7958                  or else Modification_Comes_From_Source
7959                then
7960                   if Has_Pragma_Unmodified (Ent) then
7961                      Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
7962                   end if;
7963
7964                   Set_Never_Set_In_Source (Ent, False);
7965                end if;
7966
7967                Set_Is_True_Constant (Ent, False);
7968                Set_Current_Value    (Ent, Empty);
7969                Set_Is_Known_Null    (Ent, False);
7970
7971                if not Can_Never_Be_Null (Ent) then
7972                   Set_Is_Known_Non_Null (Ent, False);
7973                end if;
7974
7975                --  Follow renaming chain
7976
7977                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
7978                  and then Present (Renamed_Object (Ent))
7979                then
7980                   Exp := Renamed_Object (Ent);
7981                   goto Continue;
7982                end if;
7983
7984                --  Generate a reference only if the assignment comes from
7985                --  source. This excludes, for example, calls to a dispatching
7986                --  assignment operation when the left-hand side is tagged.
7987
7988                if Modification_Comes_From_Source then
7989                   Generate_Reference (Ent, Exp, 'm');
7990                end if;
7991
7992                Check_Nested_Access (Ent);
7993             end if;
7994
7995             Kill_Checks (Ent);
7996             return;
7997          end if;
7998       end loop;
7999    end Note_Possible_Modification;
8000
8001    -------------------------
8002    -- Object_Access_Level --
8003    -------------------------
8004
8005    function Object_Access_Level (Obj : Node_Id) return Uint is
8006       E : Entity_Id;
8007
8008    --  Returns the static accessibility level of the view denoted by Obj. Note
8009    --  that the value returned is the result of a call to Scope_Depth. Only
8010    --  scope depths associated with dynamic scopes can actually be returned.
8011    --  Since only relative levels matter for accessibility checking, the fact
8012    --  that the distance between successive levels of accessibility is not
8013    --  always one is immaterial (invariant: if level(E2) is deeper than
8014    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
8015
8016       function Reference_To (Obj : Node_Id) return Node_Id;
8017       --  An explicit dereference is created when removing side-effects from
8018       --  expressions for constraint checking purposes. In this case a local
8019       --  access type is created for it. The correct access level is that of
8020       --  the original source node. We detect this case by noting that the
8021       --  prefix of the dereference is created by an object declaration whose
8022       --  initial expression is a reference.
8023
8024       ------------------
8025       -- Reference_To --
8026       ------------------
8027
8028       function Reference_To (Obj : Node_Id) return Node_Id is
8029          Pref : constant Node_Id := Prefix (Obj);
8030       begin
8031          if Is_Entity_Name (Pref)
8032            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
8033            and then Present (Expression (Parent (Entity (Pref))))
8034            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
8035          then
8036             return (Prefix (Expression (Parent (Entity (Pref)))));
8037          else
8038             return Empty;
8039          end if;
8040       end Reference_To;
8041
8042    --  Start of processing for Object_Access_Level
8043
8044    begin
8045       if Is_Entity_Name (Obj) then
8046          E := Entity (Obj);
8047
8048          --  If E is a type then it denotes a current instance. For this case
8049          --  we add one to the normal accessibility level of the type to ensure
8050          --  that current instances are treated as always being deeper than
8051          --  than the level of any visible named access type (see 3.10.2(21)).
8052
8053          if Is_Type (E) then
8054             return Type_Access_Level (E) +  1;
8055
8056          elsif Present (Renamed_Object (E)) then
8057             return Object_Access_Level (Renamed_Object (E));
8058
8059          --  Similarly, if E is a component of the current instance of a
8060          --  protected type, any instance of it is assumed to be at a deeper
8061          --  level than the type. For a protected object (whose type is an
8062          --  anonymous protected type) its components are at the same level
8063          --  as the type itself.
8064
8065          elsif not Is_Overloadable (E)
8066            and then Ekind (Scope (E)) = E_Protected_Type
8067            and then Comes_From_Source (Scope (E))
8068          then
8069             return Type_Access_Level (Scope (E)) + 1;
8070
8071          else
8072             return Scope_Depth (Enclosing_Dynamic_Scope (E));
8073          end if;
8074
8075       elsif Nkind (Obj) = N_Selected_Component then
8076          if Is_Access_Type (Etype (Prefix (Obj))) then
8077             return Type_Access_Level (Etype (Prefix (Obj)));
8078          else
8079             return Object_Access_Level (Prefix (Obj));
8080          end if;
8081
8082       elsif Nkind (Obj) = N_Indexed_Component then
8083          if Is_Access_Type (Etype (Prefix (Obj))) then
8084             return Type_Access_Level (Etype (Prefix (Obj)));
8085          else
8086             return Object_Access_Level (Prefix (Obj));
8087          end if;
8088
8089       elsif Nkind (Obj) = N_Explicit_Dereference then
8090
8091          --  If the prefix is a selected access discriminant then we make a
8092          --  recursive call on the prefix, which will in turn check the level
8093          --  of the prefix object of the selected discriminant.
8094
8095          if Nkind (Prefix (Obj)) = N_Selected_Component
8096            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
8097            and then
8098              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
8099          then
8100             return Object_Access_Level (Prefix (Obj));
8101
8102          elsif not (Comes_From_Source (Obj)) then
8103             declare
8104                Ref : constant Node_Id := Reference_To (Obj);
8105             begin
8106                if Present (Ref) then
8107                   return Object_Access_Level (Ref);
8108                else
8109                   return Type_Access_Level (Etype (Prefix (Obj)));
8110                end if;
8111             end;
8112
8113          else
8114             return Type_Access_Level (Etype (Prefix (Obj)));
8115          end if;
8116
8117       elsif Nkind (Obj) = N_Type_Conversion
8118         or else Nkind (Obj) = N_Unchecked_Type_Conversion
8119       then
8120          return Object_Access_Level (Expression (Obj));
8121
8122       --  Function results are objects, so we get either the access level of
8123       --  the function or, in the case of an indirect call, the level of of the
8124       --  access-to-subprogram type.
8125
8126       elsif Nkind (Obj) = N_Function_Call then
8127          if Is_Entity_Name (Name (Obj)) then
8128             return Subprogram_Access_Level (Entity (Name (Obj)));
8129          else
8130             return Type_Access_Level (Etype (Prefix (Name (Obj))));
8131          end if;
8132
8133       --  For convenience we handle qualified expressions, even though
8134       --  they aren't technically object names.
8135
8136       elsif Nkind (Obj) = N_Qualified_Expression then
8137          return Object_Access_Level (Expression (Obj));
8138
8139       --  Otherwise return the scope level of Standard.
8140       --  (If there are cases that fall through
8141       --  to this point they will be treated as
8142       --  having global accessibility for now. ???)
8143
8144       else
8145          return Scope_Depth (Standard_Standard);
8146       end if;
8147    end Object_Access_Level;
8148
8149    -----------------------
8150    -- Private_Component --
8151    -----------------------
8152
8153    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
8154       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
8155
8156       function Trace_Components
8157         (T     : Entity_Id;
8158          Check : Boolean) return Entity_Id;
8159       --  Recursive function that does the work, and checks against circular
8160       --  definition for each subcomponent type.
8161
8162       ----------------------
8163       -- Trace_Components --
8164       ----------------------
8165
8166       function Trace_Components
8167          (T     : Entity_Id;
8168           Check : Boolean) return Entity_Id
8169        is
8170          Btype     : constant Entity_Id := Base_Type (T);
8171          Component : Entity_Id;
8172          P         : Entity_Id;
8173          Candidate : Entity_Id := Empty;
8174
8175       begin
8176          if Check and then Btype = Ancestor then
8177             Error_Msg_N ("circular type definition", Type_Id);
8178             return Any_Type;
8179          end if;
8180
8181          if Is_Private_Type (Btype)
8182            and then not Is_Generic_Type (Btype)
8183          then
8184             if Present (Full_View (Btype))
8185               and then Is_Record_Type (Full_View (Btype))
8186               and then not Is_Frozen (Btype)
8187             then
8188                --  To indicate that the ancestor depends on a private type, the
8189                --  current Btype is sufficient. However, to check for circular
8190                --  definition we must recurse on the full view.
8191
8192                Candidate := Trace_Components (Full_View (Btype), True);
8193
8194                if Candidate = Any_Type then
8195                   return Any_Type;
8196                else
8197                   return Btype;
8198                end if;
8199
8200             else
8201                return Btype;
8202             end if;
8203
8204          elsif Is_Array_Type (Btype) then
8205             return Trace_Components (Component_Type (Btype), True);
8206
8207          elsif Is_Record_Type (Btype) then
8208             Component := First_Entity (Btype);
8209             while Present (Component) loop
8210
8211                --  Skip anonymous types generated by constrained components
8212
8213                if not Is_Type (Component) then
8214                   P := Trace_Components (Etype (Component), True);
8215
8216                   if Present (P) then
8217                      if P = Any_Type then
8218                         return P;
8219                      else
8220                         Candidate := P;
8221                      end if;
8222                   end if;
8223                end if;
8224
8225                Next_Entity (Component);
8226             end loop;
8227
8228             return Candidate;
8229
8230          else
8231             return Empty;
8232          end if;
8233       end Trace_Components;
8234
8235    --  Start of processing for Private_Component
8236
8237    begin
8238       return Trace_Components (Type_Id, False);
8239    end Private_Component;
8240
8241    -----------------------
8242    -- Process_End_Label --
8243    -----------------------
8244
8245    procedure Process_End_Label
8246      (N   : Node_Id;
8247       Typ : Character;
8248       Ent  : Entity_Id)
8249    is
8250       Loc  : Source_Ptr;
8251       Nam  : Node_Id;
8252       Scop : Entity_Id;
8253
8254       Label_Ref : Boolean;
8255       --  Set True if reference to end label itself is required
8256
8257       Endl : Node_Id;
8258       --  Gets set to the operator symbol or identifier that references the
8259       --  entity Ent. For the child unit case, this is the identifier from the
8260       --  designator. For other cases, this is simply Endl.
8261
8262       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
8263       --  N is an identifier node that appears as a parent unit reference in
8264       --  the case where Ent is a child unit. This procedure generates an
8265       --  appropriate cross-reference entry. E is the corresponding entity.
8266
8267       -------------------------
8268       -- Generate_Parent_Ref --
8269       -------------------------
8270
8271       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
8272       begin
8273          --  If names do not match, something weird, skip reference
8274
8275          if Chars (E) = Chars (N) then
8276
8277             --  Generate the reference. We do NOT consider this as a reference
8278             --  for unreferenced symbol purposes.
8279
8280             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
8281
8282             if Style_Check then
8283                Style.Check_Identifier (N, E);
8284             end if;
8285          end if;
8286       end Generate_Parent_Ref;
8287
8288    --  Start of processing for Process_End_Label
8289
8290    begin
8291       --  If no node, ignore. This happens in some error situations, and
8292       --  also for some internally generated structures where no end label
8293       --  references are required in any case.
8294
8295       if No (N) then
8296          return;
8297       end if;
8298
8299       --  Nothing to do if no End_Label, happens for internally generated
8300       --  constructs where we don't want an end label reference anyway. Also
8301       --  nothing to do if Endl is a string literal, which means there was
8302       --  some prior error (bad operator symbol)
8303
8304       Endl := End_Label (N);
8305
8306       if No (Endl) or else Nkind (Endl) = N_String_Literal then
8307          return;
8308       end if;
8309
8310       --  Reference node is not in extended main source unit
8311
8312       if not In_Extended_Main_Source_Unit (N) then
8313
8314          --  Generally we do not collect references except for the extended
8315          --  main source unit. The one exception is the 'e' entry for a
8316          --  package spec, where it is useful for a client to have the
8317          --  ending information to define scopes.
8318
8319          if Typ /= 'e' then
8320             return;
8321
8322          else
8323             Label_Ref := False;
8324
8325             --  For this case, we can ignore any parent references, but we
8326             --  need the package name itself for the 'e' entry.
8327
8328             if Nkind (Endl) = N_Designator then
8329                Endl := Identifier (Endl);
8330             end if;
8331          end if;
8332
8333       --  Reference is in extended main source unit
8334
8335       else
8336          Label_Ref := True;
8337
8338          --  For designator, generate references for the parent entries
8339
8340          if Nkind (Endl) = N_Designator then
8341
8342             --  Generate references for the prefix if the END line comes from
8343             --  source (otherwise we do not need these references) We climb the
8344             --  scope stack to find the expected entities.
8345
8346             if Comes_From_Source (Endl) then
8347                Nam  := Name (Endl);
8348                Scop := Current_Scope;
8349                while Nkind (Nam) = N_Selected_Component loop
8350                   Scop := Scope (Scop);
8351                   exit when No (Scop);
8352                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
8353                   Nam := Prefix (Nam);
8354                end loop;
8355
8356                if Present (Scop) then
8357                   Generate_Parent_Ref (Nam, Scope (Scop));
8358                end if;
8359             end if;
8360
8361             Endl := Identifier (Endl);
8362          end if;
8363       end if;
8364
8365       --  If the end label is not for the given entity, then either we have
8366       --  some previous error, or this is a generic instantiation for which
8367       --  we do not need to make a cross-reference in this case anyway. In
8368       --  either case we simply ignore the call.
8369
8370       if Chars (Ent) /= Chars (Endl) then
8371          return;
8372       end if;
8373
8374       --  If label was really there, then generate a normal reference and then
8375       --  adjust the location in the end label to point past the name (which
8376       --  should almost always be the semicolon).
8377
8378       Loc := Sloc (Endl);
8379
8380       if Comes_From_Source (Endl) then
8381
8382          --  If a label reference is required, then do the style check and
8383          --  generate an l-type cross-reference entry for the label
8384
8385          if Label_Ref then
8386             if Style_Check then
8387                Style.Check_Identifier (Endl, Ent);
8388             end if;
8389
8390             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
8391          end if;
8392
8393          --  Set the location to point past the label (normally this will
8394          --  mean the semicolon immediately following the label). This is
8395          --  done for the sake of the 'e' or 't' entry generated below.
8396
8397          Get_Decoded_Name_String (Chars (Endl));
8398          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
8399       end if;
8400
8401       --  Now generate the e/t reference
8402
8403       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
8404
8405       --  Restore Sloc, in case modified above, since we have an identifier
8406       --  and the normal Sloc should be left set in the tree.
8407
8408       Set_Sloc (Endl, Loc);
8409    end Process_End_Label;
8410
8411    ------------------
8412    -- Real_Convert --
8413    ------------------
8414
8415    --  We do the conversion to get the value of the real string by using
8416    --  the scanner, see Sinput for details on use of the internal source
8417    --  buffer for scanning internal strings.
8418
8419    function Real_Convert (S : String) return Node_Id is
8420       Save_Src : constant Source_Buffer_Ptr := Source;
8421       Negative : Boolean;
8422
8423    begin
8424       Source := Internal_Source_Ptr;
8425       Scan_Ptr := 1;
8426
8427       for J in S'Range loop
8428          Source (Source_Ptr (J)) := S (J);
8429       end loop;
8430
8431       Source (S'Length + 1) := EOF;
8432
8433       if Source (Scan_Ptr) = '-' then
8434          Negative := True;
8435          Scan_Ptr := Scan_Ptr + 1;
8436       else
8437          Negative := False;
8438       end if;
8439
8440       Scan;
8441
8442       if Negative then
8443          Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
8444       end if;
8445
8446       Source := Save_Src;
8447       return Token_Node;
8448    end Real_Convert;
8449
8450    ---------------------
8451    -- Rep_To_Pos_Flag --
8452    ---------------------
8453
8454    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
8455    begin
8456       return New_Occurrence_Of
8457                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
8458    end Rep_To_Pos_Flag;
8459
8460    --------------------
8461    -- Require_Entity --
8462    --------------------
8463
8464    procedure Require_Entity (N : Node_Id) is
8465    begin
8466       if Is_Entity_Name (N) and then No (Entity (N)) then
8467          if Total_Errors_Detected /= 0 then
8468             Set_Entity (N, Any_Id);
8469          else
8470             raise Program_Error;
8471          end if;
8472       end if;
8473    end Require_Entity;
8474
8475    ------------------------------
8476    -- Requires_Transient_Scope --
8477    ------------------------------
8478
8479    --  A transient scope is required when variable-sized temporaries are
8480    --  allocated in the primary or secondary stack, or when finalization
8481    --  actions must be generated before the next instruction.
8482
8483    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
8484       Typ : constant Entity_Id := Underlying_Type (Id);
8485
8486    --  Start of processing for Requires_Transient_Scope
8487
8488    begin
8489       --  This is a private type which is not completed yet. This can only
8490       --  happen in a default expression (of a formal parameter or of a
8491       --  record component). Do not expand transient scope in this case
8492
8493       if No (Typ) then
8494          return False;
8495
8496       --  Do not expand transient scope for non-existent procedure return
8497
8498       elsif Typ = Standard_Void_Type then
8499          return False;
8500
8501       --  Elementary types do not require a transient scope
8502
8503       elsif Is_Elementary_Type (Typ) then
8504          return False;
8505
8506       --  Generally, indefinite subtypes require a transient scope, since the
8507       --  back end cannot generate temporaries, since this is not a valid type
8508       --  for declaring an object. It might be possible to relax this in the
8509       --  future, e.g. by declaring the maximum possible space for the type.
8510
8511       elsif Is_Indefinite_Subtype (Typ) then
8512          return True;
8513
8514       --  Functions returning tagged types may dispatch on result so their
8515       --  returned value is allocated on the secondary stack. Controlled
8516       --  type temporaries need finalization.
8517
8518       elsif Is_Tagged_Type (Typ)
8519         or else Has_Controlled_Component (Typ)
8520       then
8521          return not Is_Value_Type (Typ);
8522
8523       --  Record type
8524
8525       elsif Is_Record_Type (Typ) then
8526          declare
8527             Comp : Entity_Id;
8528          begin
8529             Comp := First_Entity (Typ);
8530             while Present (Comp) loop
8531                if Ekind (Comp) = E_Component
8532                   and then Requires_Transient_Scope (Etype (Comp))
8533                then
8534                   return True;
8535                else
8536                   Next_Entity (Comp);
8537                end if;
8538             end loop;
8539          end;
8540
8541          return False;
8542
8543       --  String literal types never require transient scope
8544
8545       elsif Ekind (Typ) = E_String_Literal_Subtype then
8546          return False;
8547
8548       --  Array type. Note that we already know that this is a constrained
8549       --  array, since unconstrained arrays will fail the indefinite test.
8550
8551       elsif Is_Array_Type (Typ) then
8552
8553          --  If component type requires a transient scope, the array does too
8554
8555          if Requires_Transient_Scope (Component_Type (Typ)) then
8556             return True;
8557
8558          --  Otherwise, we only need a transient scope if the size is not
8559          --  known at compile time.
8560
8561          else
8562             return not Size_Known_At_Compile_Time (Typ);
8563          end if;
8564
8565       --  All other cases do not require a transient scope
8566
8567       else
8568          return False;
8569       end if;
8570    end Requires_Transient_Scope;
8571
8572    --------------------------
8573    -- Reset_Analyzed_Flags --
8574    --------------------------
8575
8576    procedure Reset_Analyzed_Flags (N : Node_Id) is
8577
8578       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
8579       --  Function used to reset Analyzed flags in tree. Note that we do
8580       --  not reset Analyzed flags in entities, since there is no need to
8581       --  renalalyze entities, and indeed, it is wrong to do so, since it
8582       --  can result in generating auxiliary stuff more than once.
8583
8584       --------------------
8585       -- Clear_Analyzed --
8586       --------------------
8587
8588       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
8589       begin
8590          if not Has_Extension (N) then
8591             Set_Analyzed (N, False);
8592          end if;
8593
8594          return OK;
8595       end Clear_Analyzed;
8596
8597       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
8598
8599    --  Start of processing for Reset_Analyzed_Flags
8600
8601    begin
8602       Reset_Analyzed (N);
8603    end Reset_Analyzed_Flags;
8604
8605    ---------------------------
8606    -- Safe_To_Capture_Value --
8607    ---------------------------
8608
8609    function Safe_To_Capture_Value
8610      (N    : Node_Id;
8611       Ent  : Entity_Id;
8612       Cond : Boolean := False) return Boolean
8613    is
8614    begin
8615       --  The only entities for which we track constant values are variables
8616       --  which are not renamings, constants, out parameters, and in out
8617       --  parameters, so check if we have this case.
8618
8619       --  Note: it may seem odd to track constant values for constants, but in
8620       --  fact this routine is used for other purposes than simply capturing
8621       --  the value. In particular, the setting of Known[_Non]_Null.
8622
8623       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
8624             or else
8625           Ekind (Ent) = E_Constant
8626             or else
8627           Ekind (Ent) = E_Out_Parameter
8628             or else
8629           Ekind (Ent) = E_In_Out_Parameter
8630       then
8631          null;
8632
8633       --  For conditionals, we also allow loop parameters and all formals,
8634       --  including in parameters.
8635
8636       elsif Cond
8637         and then
8638           (Ekind (Ent) = E_Loop_Parameter
8639              or else
8640            Ekind (Ent) = E_In_Parameter)
8641       then
8642          null;
8643
8644       --  For all other cases, not just unsafe, but impossible to capture
8645       --  Current_Value, since the above are the only entities which have
8646       --  Current_Value fields.
8647
8648       else
8649          return False;
8650       end if;
8651
8652       --  Skip if volatile or aliased, since funny things might be going on in
8653       --  these cases which we cannot necessarily track. Also skip any variable
8654       --  for which an address clause is given, or whose address is taken. Also
8655       --  never capture value of library level variables (an attempt to do so
8656       --  can occur in the case of package elaboration code).
8657
8658       if Treat_As_Volatile (Ent)
8659         or else Is_Aliased (Ent)
8660         or else Present (Address_Clause (Ent))
8661         or else Address_Taken (Ent)
8662         or else (Is_Library_Level_Entity (Ent)
8663                    and then Ekind (Ent) = E_Variable)
8664       then
8665          return False;
8666       end if;
8667
8668       --  OK, all above conditions are met. We also require that the scope of
8669       --  the reference be the same as the scope of the entity, not counting
8670       --  packages and blocks and loops.
8671
8672       declare
8673          E_Scope : constant Entity_Id := Scope (Ent);
8674          R_Scope : Entity_Id;
8675
8676       begin
8677          R_Scope := Current_Scope;
8678          while R_Scope /= Standard_Standard loop
8679             exit when R_Scope = E_Scope;
8680
8681             if Ekind (R_Scope) /= E_Package
8682                   and then
8683                 Ekind (R_Scope) /= E_Block
8684                   and then
8685                 Ekind (R_Scope) /= E_Loop
8686             then
8687                return False;
8688             else
8689                R_Scope := Scope (R_Scope);
8690             end if;
8691          end loop;
8692       end;
8693
8694       --  We also require that the reference does not appear in a context
8695       --  where it is not sure to be executed (i.e. a conditional context
8696       --  or an exception handler). We skip this if Cond is True, since the
8697       --  capturing of values from conditional tests handles this ok.
8698
8699       if Cond then
8700          return True;
8701       end if;
8702
8703       declare
8704          Desc : Node_Id;
8705          P    : Node_Id;
8706
8707       begin
8708          Desc := N;
8709
8710          P := Parent (N);
8711          while Present (P) loop
8712             if Nkind (P) = N_If_Statement
8713               or else  Nkind (P) = N_Case_Statement
8714               or else (Nkind (P) = N_And_Then and then Desc = Right_Opnd (P))
8715               or else (Nkind (P) = N_Or_Else and then Desc = Right_Opnd (P))
8716               or else  Nkind (P) = N_Exception_Handler
8717               or else  Nkind (P) = N_Selective_Accept
8718               or else  Nkind (P) = N_Conditional_Entry_Call
8719               or else  Nkind (P) = N_Timed_Entry_Call
8720               or else  Nkind (P) = N_Asynchronous_Select
8721             then
8722                return False;
8723             else
8724                Desc := P;
8725                P    := Parent (P);
8726             end if;
8727          end loop;
8728       end;
8729
8730       --  OK, looks safe to set value
8731
8732       return True;
8733    end Safe_To_Capture_Value;
8734
8735    ---------------
8736    -- Same_Name --
8737    ---------------
8738
8739    function Same_Name (N1, N2 : Node_Id) return Boolean is
8740       K1 : constant Node_Kind := Nkind (N1);
8741       K2 : constant Node_Kind := Nkind (N2);
8742
8743    begin
8744       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
8745         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
8746       then
8747          return Chars (N1) = Chars (N2);
8748
8749       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
8750         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
8751       then
8752          return Same_Name (Selector_Name (N1), Selector_Name (N2))
8753            and then Same_Name (Prefix (N1), Prefix (N2));
8754
8755       else
8756          return False;
8757       end if;
8758    end Same_Name;
8759
8760    -----------------
8761    -- Same_Object --
8762    -----------------
8763
8764    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
8765       N1 : constant Node_Id := Original_Node (Node1);
8766       N2 : constant Node_Id := Original_Node (Node2);
8767       --  We do the tests on original nodes, since we are most interested
8768       --  in the original source, not any expansion that got in the way.
8769
8770       K1 : constant Node_Kind := Nkind (N1);
8771       K2 : constant Node_Kind := Nkind (N2);
8772
8773    begin
8774       --  First case, both are entities with same entity
8775
8776       if K1 in N_Has_Entity
8777         and then K2 in N_Has_Entity
8778         and then Present (Entity (N1))
8779         and then Present (Entity (N2))
8780         and then (Ekind (Entity (N1)) = E_Variable
8781                     or else
8782                   Ekind (Entity (N1)) = E_Constant)
8783         and then Entity (N1) = Entity (N2)
8784       then
8785          return True;
8786
8787       --  Second case, selected component with same selector, same record
8788
8789       elsif K1 = N_Selected_Component
8790         and then K2 = N_Selected_Component
8791         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
8792       then
8793          return Same_Object (Prefix (N1), Prefix (N2));
8794
8795       --  Third case, indexed component with same subscripts, same array
8796
8797       elsif K1 = N_Indexed_Component
8798         and then K2 = N_Indexed_Component
8799         and then Same_Object (Prefix (N1), Prefix (N2))
8800       then
8801          declare
8802             E1, E2 : Node_Id;
8803          begin
8804             E1 := First (Expressions (N1));
8805             E2 := First (Expressions (N2));
8806             while Present (E1) loop
8807                if not Same_Value (E1, E2) then
8808                   return False;
8809                else
8810                   Next (E1);
8811                   Next (E2);
8812                end if;
8813             end loop;
8814
8815             return True;
8816          end;
8817
8818       --  Fourth case, slice of same array with same bounds
8819
8820       elsif K1 = N_Slice
8821         and then K2 = N_Slice
8822         and then Nkind (Discrete_Range (N1)) = N_Range
8823         and then Nkind (Discrete_Range (N2)) = N_Range
8824         and then Same_Value (Low_Bound (Discrete_Range (N1)),
8825                              Low_Bound (Discrete_Range (N2)))
8826         and then Same_Value (High_Bound (Discrete_Range (N1)),
8827                              High_Bound (Discrete_Range (N2)))
8828       then
8829          return Same_Name (Prefix (N1), Prefix (N2));
8830
8831       --  All other cases, not clearly the same object
8832
8833       else
8834          return False;
8835       end if;
8836    end Same_Object;
8837
8838    ---------------
8839    -- Same_Type --
8840    ---------------
8841
8842    function Same_Type (T1, T2 : Entity_Id) return Boolean is
8843    begin
8844       if T1 = T2 then
8845          return True;
8846
8847       elsif not Is_Constrained (T1)
8848         and then not Is_Constrained (T2)
8849         and then Base_Type (T1) = Base_Type (T2)
8850       then
8851          return True;
8852
8853       --  For now don't bother with case of identical constraints, to be
8854       --  fiddled with later on perhaps (this is only used for optimization
8855       --  purposes, so it is not critical to do a best possible job)
8856
8857       else
8858          return False;
8859       end if;
8860    end Same_Type;
8861
8862    ----------------
8863    -- Same_Value --
8864    ----------------
8865
8866    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
8867    begin
8868       if Compile_Time_Known_Value (Node1)
8869         and then Compile_Time_Known_Value (Node2)
8870         and then Expr_Value (Node1) = Expr_Value (Node2)
8871       then
8872          return True;
8873       elsif Same_Object (Node1, Node2) then
8874          return True;
8875       else
8876          return False;
8877       end if;
8878    end Same_Value;
8879
8880    ------------------------
8881    -- Scope_Is_Transient --
8882    ------------------------
8883
8884    function Scope_Is_Transient  return Boolean is
8885    begin
8886       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
8887    end Scope_Is_Transient;
8888
8889    ------------------
8890    -- Scope_Within --
8891    ------------------
8892
8893    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
8894       Scop : Entity_Id;
8895
8896    begin
8897       Scop := Scope1;
8898       while Scop /= Standard_Standard loop
8899          Scop := Scope (Scop);
8900
8901          if Scop = Scope2 then
8902             return True;
8903          end if;
8904       end loop;
8905
8906       return False;
8907    end Scope_Within;
8908
8909    --------------------------
8910    -- Scope_Within_Or_Same --
8911    --------------------------
8912
8913    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
8914       Scop : Entity_Id;
8915
8916    begin
8917       Scop := Scope1;
8918       while Scop /= Standard_Standard loop
8919          if Scop = Scope2 then
8920             return True;
8921          else
8922             Scop := Scope (Scop);
8923          end if;
8924       end loop;
8925
8926       return False;
8927    end Scope_Within_Or_Same;
8928
8929    --------------------
8930    -- Set_Convention --
8931    --------------------
8932
8933    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
8934    begin
8935       Basic_Set_Convention (E, Val);
8936
8937       if Is_Type (E)
8938         and then Is_Access_Subprogram_Type (Base_Type (E))
8939         and then Has_Foreign_Convention (E)
8940       then
8941          Set_Can_Use_Internal_Rep (E, False);
8942       end if;
8943    end Set_Convention;
8944
8945    ------------------------
8946    -- Set_Current_Entity --
8947    ------------------------
8948
8949    --  The given entity is to be set as the currently visible definition
8950    --  of its associated name (i.e. the Node_Id associated with its name).
8951    --  All we have to do is to get the name from the identifier, and
8952    --  then set the associated Node_Id to point to the given entity.
8953
8954    procedure Set_Current_Entity (E : Entity_Id) is
8955    begin
8956       Set_Name_Entity_Id (Chars (E), E);
8957    end Set_Current_Entity;
8958
8959    ---------------------------
8960    -- Set_Debug_Info_Needed --
8961    ---------------------------
8962
8963    procedure Set_Debug_Info_Needed (T : Entity_Id) is
8964
8965       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
8966       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
8967       --  Used to set debug info in a related node if not set already
8968
8969       --------------------------------------
8970       -- Set_Debug_Info_Needed_If_Not_Set --
8971       --------------------------------------
8972
8973       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
8974       begin
8975          if Present (E)
8976            and then not Needs_Debug_Info (E)
8977          then
8978             Set_Debug_Info_Needed (E);
8979          end if;
8980       end Set_Debug_Info_Needed_If_Not_Set;
8981
8982    --  Start of processing for Set_Debug_Info_Needed
8983
8984    begin
8985       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
8986       --  indicates that Debug_Info_Needed is never required for the entity.
8987
8988       if No (T)
8989         or else Debug_Info_Off (T)
8990       then
8991          return;
8992       end if;
8993
8994       --  Set flag in entity itself. Note that we will go through the following
8995       --  circuitry even if the flag is already set on T. That's intentional,
8996       --  it makes sure that the flag will be set in subsidiary entities.
8997
8998       Set_Needs_Debug_Info (T);
8999
9000       --  Set flag on subsidiary entities if not set already
9001
9002       if Is_Object (T) then
9003          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
9004
9005       elsif Is_Type (T) then
9006          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
9007
9008          if Is_Record_Type (T) then
9009             declare
9010                Ent : Entity_Id := First_Entity (T);
9011             begin
9012                while Present (Ent) loop
9013                   Set_Debug_Info_Needed_If_Not_Set (Ent);
9014                   Next_Entity (Ent);
9015                end loop;
9016             end;
9017
9018          elsif Is_Array_Type (T) then
9019             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
9020
9021             declare
9022                Indx : Node_Id := First_Index (T);
9023             begin
9024                while Present (Indx) loop
9025                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
9026                   Indx := Next_Index (Indx);
9027                end loop;
9028             end;
9029
9030             if Is_Packed (T) then
9031                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
9032             end if;
9033
9034          elsif Is_Access_Type (T) then
9035             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
9036
9037          elsif Is_Private_Type (T) then
9038             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
9039
9040          elsif Is_Protected_Type (T) then
9041             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
9042          end if;
9043       end if;
9044    end Set_Debug_Info_Needed;
9045
9046    ---------------------------------
9047    -- Set_Entity_With_Style_Check --
9048    ---------------------------------
9049
9050    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
9051       Val_Actual : Entity_Id;
9052       Nod        : Node_Id;
9053
9054    begin
9055       Set_Entity (N, Val);
9056
9057       if Style_Check
9058         and then not Suppress_Style_Checks (Val)
9059         and then not In_Instance
9060       then
9061          if Nkind (N) = N_Identifier then
9062             Nod := N;
9063          elsif Nkind (N) = N_Expanded_Name then
9064             Nod := Selector_Name (N);
9065          else
9066             return;
9067          end if;
9068
9069          --  A special situation arises for derived operations, where we want
9070          --  to do the check against the parent (since the Sloc of the derived
9071          --  operation points to the derived type declaration itself).
9072
9073          Val_Actual := Val;
9074          while not Comes_From_Source (Val_Actual)
9075            and then Nkind (Val_Actual) in N_Entity
9076            and then (Ekind (Val_Actual) = E_Enumeration_Literal
9077                       or else Is_Subprogram (Val_Actual)
9078                       or else Is_Generic_Subprogram (Val_Actual))
9079            and then Present (Alias (Val_Actual))
9080          loop
9081             Val_Actual := Alias (Val_Actual);
9082          end loop;
9083
9084          --  Renaming declarations for generic actuals do not come from source,
9085          --  and have a different name from that of the entity they rename, so
9086          --  there is no style check to perform here.
9087
9088          if Chars (Nod) = Chars (Val_Actual) then
9089             Style.Check_Identifier (Nod, Val_Actual);
9090          end if;
9091       end if;
9092
9093       Set_Entity (N, Val);
9094    end Set_Entity_With_Style_Check;
9095
9096    ------------------------
9097    -- Set_Name_Entity_Id --
9098    ------------------------
9099
9100    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
9101    begin
9102       Set_Name_Table_Info (Id, Int (Val));
9103    end Set_Name_Entity_Id;
9104
9105    ---------------------
9106    -- Set_Next_Actual --
9107    ---------------------
9108
9109    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
9110    begin
9111       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
9112          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
9113       end if;
9114    end Set_Next_Actual;
9115
9116    -----------------------
9117    -- Set_Public_Status --
9118    -----------------------
9119
9120    procedure Set_Public_Status (Id : Entity_Id) is
9121       S : constant Entity_Id := Current_Scope;
9122
9123    begin
9124       --  Everything in the scope of Standard is public
9125
9126       if S = Standard_Standard then
9127          Set_Is_Public (Id);
9128
9129       --  Entity is definitely not public if enclosing scope is not public
9130
9131       elsif not Is_Public (S) then
9132          return;
9133
9134       --  An object declaration that occurs in a handled sequence of statements
9135       --  is the declaration for a temporary object generated by the expander.
9136       --  It never needs to be made public and furthermore, making it public
9137       --  can cause back end problems if it is of variable size.
9138
9139       elsif Nkind (Parent (Id)) = N_Object_Declaration
9140         and then
9141           Nkind (Parent (Parent (Id))) = N_Handled_Sequence_Of_Statements
9142       then
9143          return;
9144
9145       --  Entities in public packages or records are public
9146
9147       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
9148          Set_Is_Public (Id);
9149
9150       --  The bounds of an entry family declaration can generate object
9151       --  declarations that are visible to the back-end, e.g. in the
9152       --  the declaration of a composite type that contains tasks.
9153
9154       elsif Is_Concurrent_Type (S)
9155         and then not Has_Completion (S)
9156         and then Nkind (Parent (Id)) = N_Object_Declaration
9157       then
9158          Set_Is_Public (Id);
9159       end if;
9160    end Set_Public_Status;
9161
9162    -----------------------------
9163    -- Set_Referenced_Modified --
9164    -----------------------------
9165
9166    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
9167       Pref : Node_Id;
9168
9169    begin
9170       --  Deal with indexed or selected component where prefix is modified
9171
9172       if Nkind (N) = N_Indexed_Component
9173            or else
9174          Nkind (N) = N_Selected_Component
9175       then
9176          Pref := Prefix (N);
9177
9178          --  If prefix is access type, then it is the designated object that is
9179          --  being modified, which means we have no entity to set the flag on.
9180
9181          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
9182             return;
9183
9184             --  Otherwise chase the prefix
9185
9186          else
9187             Set_Referenced_Modified (Pref, Out_Param);
9188          end if;
9189
9190       --  Otherwise see if we have an entity name (only other case to process)
9191
9192       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
9193          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
9194          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
9195       end if;
9196    end Set_Referenced_Modified;
9197
9198    ----------------------------
9199    -- Set_Scope_Is_Transient --
9200    ----------------------------
9201
9202    procedure Set_Scope_Is_Transient (V : Boolean := True) is
9203    begin
9204       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
9205    end Set_Scope_Is_Transient;
9206
9207    -------------------
9208    -- Set_Size_Info --
9209    -------------------
9210
9211    procedure Set_Size_Info (T1, T2 : Entity_Id) is
9212    begin
9213       --  We copy Esize, but not RM_Size, since in general RM_Size is
9214       --  subtype specific and does not get inherited by all subtypes.
9215
9216       Set_Esize                     (T1, Esize                     (T2));
9217       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
9218
9219       if Is_Discrete_Or_Fixed_Point_Type (T1)
9220            and then
9221          Is_Discrete_Or_Fixed_Point_Type (T2)
9222       then
9223          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
9224       end if;
9225
9226       Set_Alignment                 (T1, Alignment                 (T2));
9227    end Set_Size_Info;
9228
9229    --------------------
9230    -- Static_Integer --
9231    --------------------
9232
9233    function Static_Integer (N : Node_Id) return Uint is
9234    begin
9235       Analyze_And_Resolve (N, Any_Integer);
9236
9237       if N = Error
9238         or else Error_Posted (N)
9239         or else Etype (N) = Any_Type
9240       then
9241          return No_Uint;
9242       end if;
9243
9244       if Is_Static_Expression (N) then
9245          if not Raises_Constraint_Error (N) then
9246             return Expr_Value (N);
9247          else
9248             return No_Uint;
9249          end if;
9250
9251       elsif Etype (N) = Any_Type then
9252          return No_Uint;
9253
9254       else
9255          Flag_Non_Static_Expr
9256            ("static integer expression required here", N);
9257          return No_Uint;
9258       end if;
9259    end Static_Integer;
9260
9261    --------------------------
9262    -- Statically_Different --
9263    --------------------------
9264
9265    function Statically_Different (E1, E2 : Node_Id) return Boolean is
9266       R1 : constant Node_Id := Get_Referenced_Object (E1);
9267       R2 : constant Node_Id := Get_Referenced_Object (E2);
9268    begin
9269       return     Is_Entity_Name (R1)
9270         and then Is_Entity_Name (R2)
9271         and then Entity (R1) /= Entity (R2)
9272         and then not Is_Formal (Entity (R1))
9273         and then not Is_Formal (Entity (R2));
9274    end Statically_Different;
9275
9276    -----------------------------
9277    -- Subprogram_Access_Level --
9278    -----------------------------
9279
9280    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
9281    begin
9282       if Present (Alias (Subp)) then
9283          return Subprogram_Access_Level (Alias (Subp));
9284       else
9285          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
9286       end if;
9287    end Subprogram_Access_Level;
9288
9289    -----------------
9290    -- Trace_Scope --
9291    -----------------
9292
9293    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
9294    begin
9295       if Debug_Flag_W then
9296          for J in 0 .. Scope_Stack.Last loop
9297             Write_Str ("  ");
9298          end loop;
9299
9300          Write_Str (Msg);
9301          Write_Name (Chars (E));
9302          Write_Str (" from ");
9303          Write_Location (Sloc (N));
9304          Write_Eol;
9305       end if;
9306    end Trace_Scope;
9307
9308    -----------------------
9309    -- Transfer_Entities --
9310    -----------------------
9311
9312    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
9313       Ent : Entity_Id := First_Entity (From);
9314
9315    begin
9316       if No (Ent) then
9317          return;
9318       end if;
9319
9320       if (Last_Entity (To)) = Empty then
9321          Set_First_Entity (To, Ent);
9322       else
9323          Set_Next_Entity (Last_Entity (To), Ent);
9324       end if;
9325
9326       Set_Last_Entity (To, Last_Entity (From));
9327
9328       while Present (Ent) loop
9329          Set_Scope (Ent, To);
9330
9331          if not Is_Public (Ent) then
9332             Set_Public_Status (Ent);
9333
9334             if Is_Public (Ent)
9335               and then Ekind (Ent) = E_Record_Subtype
9336
9337             then
9338                --  The components of the propagated Itype must be public
9339                --  as well.
9340
9341                declare
9342                   Comp : Entity_Id;
9343                begin
9344                   Comp := First_Entity (Ent);
9345                   while Present (Comp) loop
9346                      Set_Is_Public (Comp);
9347                      Next_Entity (Comp);
9348                   end loop;
9349                end;
9350             end if;
9351          end if;
9352
9353          Next_Entity (Ent);
9354       end loop;
9355
9356       Set_First_Entity (From, Empty);
9357       Set_Last_Entity (From, Empty);
9358    end Transfer_Entities;
9359
9360    -----------------------
9361    -- Type_Access_Level --
9362    -----------------------
9363
9364    function Type_Access_Level (Typ : Entity_Id) return Uint is
9365       Btyp : Entity_Id;
9366
9367    begin
9368       Btyp := Base_Type (Typ);
9369
9370       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
9371       --  simply use the level where the type is declared. This is true for
9372       --  stand-alone object declarations, and for anonymous access types
9373       --  associated with components the level is the same as that of the
9374       --  enclosing composite type. However, special treatment is needed for
9375       --  the cases of access parameters, return objects of an anonymous access
9376       --  type, and, in Ada 95, access discriminants of limited types.
9377
9378       if Ekind (Btyp) in Access_Kind then
9379          if Ekind (Btyp) = E_Anonymous_Access_Type then
9380
9381             --  If the type is a nonlocal anonymous access type (such as for
9382             --  an access parameter) we treat it as being declared at the
9383             --  library level to ensure that names such as X.all'access don't
9384             --  fail static accessibility checks.
9385
9386             if not Is_Local_Anonymous_Access (Typ) then
9387                return Scope_Depth (Standard_Standard);
9388
9389             --  If this is a return object, the accessibility level is that of
9390             --  the result subtype of the enclosing function. The test here is
9391             --  little complicated, because we have to account for extended
9392             --  return statements that have been rewritten as blocks, in which
9393             --  case we have to find and the Is_Return_Object attribute of the
9394             --  itype's associated object. It would be nice to find a way to
9395             --  simplify this test, but it doesn't seem worthwhile to add a new
9396             --  flag just for purposes of this test. ???
9397
9398             elsif Ekind (Scope (Btyp)) = E_Return_Statement
9399               or else
9400                 (Is_Itype (Btyp)
9401                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
9402                              N_Object_Declaration
9403                   and then Is_Return_Object
9404                              (Defining_Identifier
9405                                 (Associated_Node_For_Itype (Btyp))))
9406             then
9407                declare
9408                   Scop : Entity_Id;
9409
9410                begin
9411                   Scop := Scope (Scope (Btyp));
9412                   while Present (Scop) loop
9413                      exit when Ekind (Scop) = E_Function;
9414                      Scop := Scope (Scop);
9415                   end loop;
9416
9417                   --  Treat the return object's type as having the level of the
9418                   --  function's result subtype (as per RM05-6.5(5.3/2)).
9419
9420                   return Type_Access_Level (Etype (Scop));
9421                end;
9422             end if;
9423          end if;
9424
9425          Btyp := Root_Type (Btyp);
9426
9427          --  The accessibility level of anonymous acccess types associated with
9428          --  discriminants is that of the current instance of the type, and
9429          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
9430
9431          --  AI-402: access discriminants have accessibility based on the
9432          --  object rather than the type in Ada 2005, so the above paragraph
9433          --  doesn't apply.
9434
9435          --  ??? Needs completion with rules from AI-416
9436
9437          if Ada_Version <= Ada_95
9438            and then Ekind (Typ) = E_Anonymous_Access_Type
9439            and then Present (Associated_Node_For_Itype (Typ))
9440            and then Nkind (Associated_Node_For_Itype (Typ)) =
9441                                                  N_Discriminant_Specification
9442          then
9443             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
9444          end if;
9445       end if;
9446
9447       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
9448    end Type_Access_Level;
9449
9450    --------------------------
9451    -- Unit_Declaration_Node --
9452    --------------------------
9453
9454    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
9455       N : Node_Id := Parent (Unit_Id);
9456
9457    begin
9458       --  Predefined operators do not have a full function declaration
9459
9460       if Ekind (Unit_Id) = E_Operator then
9461          return N;
9462       end if;
9463
9464       --  Isn't there some better way to express the following ???
9465
9466       while Nkind (N) /= N_Abstract_Subprogram_Declaration
9467         and then Nkind (N) /= N_Formal_Package_Declaration
9468         and then Nkind (N) /= N_Function_Instantiation
9469         and then Nkind (N) /= N_Generic_Package_Declaration
9470         and then Nkind (N) /= N_Generic_Subprogram_Declaration
9471         and then Nkind (N) /= N_Package_Declaration
9472         and then Nkind (N) /= N_Package_Body
9473         and then Nkind (N) /= N_Package_Instantiation
9474         and then Nkind (N) /= N_Package_Renaming_Declaration
9475         and then Nkind (N) /= N_Procedure_Instantiation
9476         and then Nkind (N) /= N_Protected_Body
9477         and then Nkind (N) /= N_Subprogram_Declaration
9478         and then Nkind (N) /= N_Subprogram_Body
9479         and then Nkind (N) /= N_Subprogram_Body_Stub
9480         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
9481         and then Nkind (N) /= N_Task_Body
9482         and then Nkind (N) /= N_Task_Type_Declaration
9483         and then Nkind (N) not in N_Formal_Subprogram_Declaration
9484         and then Nkind (N) not in N_Generic_Renaming_Declaration
9485       loop
9486          N := Parent (N);
9487          pragma Assert (Present (N));
9488       end loop;
9489
9490       return N;
9491    end Unit_Declaration_Node;
9492
9493    ------------------------------
9494    -- Universal_Interpretation --
9495    ------------------------------
9496
9497    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
9498       Index : Interp_Index;
9499       It    : Interp;
9500
9501    begin
9502       --  The argument may be a formal parameter of an operator or subprogram
9503       --  with multiple interpretations, or else an expression for an actual.
9504
9505       if Nkind (Opnd) = N_Defining_Identifier
9506         or else not Is_Overloaded (Opnd)
9507       then
9508          if Etype (Opnd) = Universal_Integer
9509            or else Etype (Opnd) = Universal_Real
9510          then
9511             return Etype (Opnd);
9512          else
9513             return Empty;
9514          end if;
9515
9516       else
9517          Get_First_Interp (Opnd, Index, It);
9518          while Present (It.Typ) loop
9519             if It.Typ = Universal_Integer
9520               or else It.Typ = Universal_Real
9521             then
9522                return It.Typ;
9523             end if;
9524
9525             Get_Next_Interp (Index, It);
9526          end loop;
9527
9528          return Empty;
9529       end if;
9530    end Universal_Interpretation;
9531
9532    ---------------
9533    -- Unqualify --
9534    ---------------
9535
9536    function Unqualify (Expr : Node_Id) return Node_Id is
9537    begin
9538       --  Recurse to handle unlikely case of multiple levels of qualification
9539
9540       if Nkind (Expr) = N_Qualified_Expression then
9541          return Unqualify (Expression (Expr));
9542
9543       --  Normal case, not a qualified expression
9544
9545       else
9546          return Expr;
9547       end if;
9548    end Unqualify;
9549
9550    ----------------------
9551    -- Within_Init_Proc --
9552    ----------------------
9553
9554    function Within_Init_Proc return Boolean is
9555       S : Entity_Id;
9556
9557    begin
9558       S := Current_Scope;
9559       while not Is_Overloadable (S) loop
9560          if S = Standard_Standard then
9561             return False;
9562          else
9563             S := Scope (S);
9564          end if;
9565       end loop;
9566
9567       return Is_Init_Proc (S);
9568    end Within_Init_Proc;
9569
9570    ----------------
9571    -- Wrong_Type --
9572    ----------------
9573
9574    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
9575       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
9576       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
9577
9578       function Has_One_Matching_Field return Boolean;
9579       --  Determines if Expec_Type is a record type with a single component or
9580       --  discriminant whose type matches the found type or is one dimensional
9581       --  array whose component type matches the found type.
9582
9583       ----------------------------
9584       -- Has_One_Matching_Field --
9585       ----------------------------
9586
9587       function Has_One_Matching_Field return Boolean is
9588          E : Entity_Id;
9589
9590       begin
9591          if Is_Array_Type (Expec_Type)
9592            and then Number_Dimensions (Expec_Type) = 1
9593            and then
9594              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
9595          then
9596             return True;
9597
9598          elsif not Is_Record_Type (Expec_Type) then
9599             return False;
9600
9601          else
9602             E := First_Entity (Expec_Type);
9603             loop
9604                if No (E) then
9605                   return False;
9606
9607                elsif (Ekind (E) /= E_Discriminant
9608                        and then Ekind (E) /= E_Component)
9609                  or else (Chars (E) = Name_uTag
9610                            or else Chars (E) = Name_uParent)
9611                then
9612                   Next_Entity (E);
9613
9614                else
9615                   exit;
9616                end if;
9617             end loop;
9618
9619             if not Covers (Etype (E), Found_Type) then
9620                return False;
9621
9622             elsif Present (Next_Entity (E)) then
9623                return False;
9624
9625             else
9626                return True;
9627             end if;
9628          end if;
9629       end Has_One_Matching_Field;
9630
9631    --  Start of processing for Wrong_Type
9632
9633    begin
9634       --  Don't output message if either type is Any_Type, or if a message
9635       --  has already been posted for this node. We need to do the latter
9636       --  check explicitly (it is ordinarily done in Errout), because we
9637       --  are using ! to force the output of the error messages.
9638
9639       if Expec_Type = Any_Type
9640         or else Found_Type = Any_Type
9641         or else Error_Posted (Expr)
9642       then
9643          return;
9644
9645       --  In  an instance, there is an ongoing problem with completion of
9646       --  type derived from private types. Their structure is what Gigi
9647       --  expects, but the  Etype is the parent type rather than the
9648       --  derived private type itself. Do not flag error in this case. The
9649       --  private completion is an entity without a parent, like an Itype.
9650       --  Similarly, full and partial views may be incorrect in the instance.
9651       --  There is no simple way to insure that it is consistent ???
9652
9653       elsif In_Instance then
9654          if Etype (Etype (Expr)) = Etype (Expected_Type)
9655            and then
9656              (Has_Private_Declaration (Expected_Type)
9657                or else Has_Private_Declaration (Etype (Expr)))
9658            and then No (Parent (Expected_Type))
9659          then
9660             return;
9661          end if;
9662       end if;
9663
9664       --  An interesting special check. If the expression is parenthesized
9665       --  and its type corresponds to the type of the sole component of the
9666       --  expected record type, or to the component type of the expected one
9667       --  dimensional array type, then assume we have a bad aggregate attempt.
9668
9669       if Nkind (Expr) in N_Subexpr
9670         and then Paren_Count (Expr) /= 0
9671         and then Has_One_Matching_Field
9672       then
9673          Error_Msg_N ("positional aggregate cannot have one component", Expr);
9674
9675       --  Another special check, if we are looking for a pool-specific access
9676       --  type and we found an E_Access_Attribute_Type, then we have the case
9677       --  of an Access attribute being used in a context which needs a pool-
9678       --  specific type, which is never allowed. The one extra check we make
9679       --  is that the expected designated type covers the Found_Type.
9680
9681       elsif Is_Access_Type (Expec_Type)
9682         and then Ekind (Found_Type) = E_Access_Attribute_Type
9683         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
9684         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
9685         and then Covers
9686           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
9687       then
9688          Error_Msg_N ("result must be general access type!", Expr);
9689          Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
9690
9691       --  Another special check, if the expected type is an integer type,
9692       --  but the expression is of type System.Address, and the parent is
9693       --  an addition or subtraction operation whose left operand is the
9694       --  expression in question and whose right operand is of an integral
9695       --  type, then this is an attempt at address arithmetic, so give
9696       --  appropriate message.
9697
9698       elsif Is_Integer_Type (Expec_Type)
9699         and then Is_RTE (Found_Type, RE_Address)
9700         and then (Nkind (Parent (Expr)) = N_Op_Add
9701                     or else
9702                   Nkind (Parent (Expr)) = N_Op_Subtract)
9703         and then Expr = Left_Opnd (Parent (Expr))
9704         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
9705       then
9706          Error_Msg_N
9707            ("address arithmetic not predefined in package System",
9708             Parent (Expr));
9709          Error_Msg_N
9710            ("\possible missing with/use of System.Storage_Elements",
9711             Parent (Expr));
9712          return;
9713
9714       --  If the expected type is an anonymous access type, as for access
9715       --  parameters and discriminants, the error is on the designated types.
9716
9717       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
9718          if Comes_From_Source (Expec_Type) then
9719             Error_Msg_NE ("expected}!", Expr, Expec_Type);
9720          else
9721             Error_Msg_NE
9722               ("expected an access type with designated}",
9723                  Expr, Designated_Type (Expec_Type));
9724          end if;
9725
9726          if Is_Access_Type (Found_Type)
9727            and then not Comes_From_Source (Found_Type)
9728          then
9729             Error_Msg_NE
9730               ("\\found an access type with designated}!",
9731                 Expr, Designated_Type (Found_Type));
9732          else
9733             if From_With_Type (Found_Type) then
9734                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
9735                Error_Msg_Qual_Level := 99;
9736                Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type));
9737                Error_Msg_Qual_Level := 0;
9738             else
9739                Error_Msg_NE ("found}!", Expr, Found_Type);
9740             end if;
9741          end if;
9742
9743       --  Normal case of one type found, some other type expected
9744
9745       else
9746          --  If the names of the two types are the same, see if some number
9747          --  of levels of qualification will help. Don't try more than three
9748          --  levels, and if we get to standard, it's no use (and probably
9749          --  represents an error in the compiler) Also do not bother with
9750          --  internal scope names.
9751
9752          declare
9753             Expec_Scope : Entity_Id;
9754             Found_Scope : Entity_Id;
9755
9756          begin
9757             Expec_Scope := Expec_Type;
9758             Found_Scope := Found_Type;
9759
9760             for Levels in Int range 0 .. 3 loop
9761                if Chars (Expec_Scope) /= Chars (Found_Scope) then
9762                   Error_Msg_Qual_Level := Levels;
9763                   exit;
9764                end if;
9765
9766                Expec_Scope := Scope (Expec_Scope);
9767                Found_Scope := Scope (Found_Scope);
9768
9769                exit when Expec_Scope = Standard_Standard
9770                  or else Found_Scope = Standard_Standard
9771                  or else not Comes_From_Source (Expec_Scope)
9772                  or else not Comes_From_Source (Found_Scope);
9773             end loop;
9774          end;
9775
9776          if Is_Record_Type (Expec_Type)
9777            and then Present (Corresponding_Remote_Type (Expec_Type))
9778          then
9779             Error_Msg_NE ("expected}!", Expr,
9780                           Corresponding_Remote_Type (Expec_Type));
9781          else
9782             Error_Msg_NE ("expected}!", Expr, Expec_Type);
9783          end if;
9784
9785          if Is_Entity_Name (Expr)
9786            and then Is_Package_Or_Generic_Package (Entity (Expr))
9787          then
9788             Error_Msg_N ("\\found package name!", Expr);
9789
9790          elsif Is_Entity_Name (Expr)
9791            and then
9792              (Ekind (Entity (Expr)) = E_Procedure
9793                 or else
9794               Ekind (Entity (Expr)) = E_Generic_Procedure)
9795          then
9796             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
9797                Error_Msg_N
9798                  ("found procedure name, possibly missing Access attribute!",
9799                    Expr);
9800             else
9801                Error_Msg_N
9802                  ("\\found procedure name instead of function!", Expr);
9803             end if;
9804
9805          elsif Nkind (Expr) = N_Function_Call
9806            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
9807            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
9808            and then No (Parameter_Associations (Expr))
9809          then
9810             Error_Msg_N
9811               ("found function name, possibly missing Access attribute!",
9812                Expr);
9813
9814          --  Catch common error: a prefix or infix operator which is not
9815          --  directly visible because the type isn't.
9816
9817          elsif Nkind (Expr) in N_Op
9818             and then Is_Overloaded (Expr)
9819             and then not Is_Immediately_Visible (Expec_Type)
9820             and then not Is_Potentially_Use_Visible (Expec_Type)
9821             and then not In_Use (Expec_Type)
9822             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
9823          then
9824             Error_Msg_N
9825               ("operator of the type is not directly visible!", Expr);
9826
9827          elsif Ekind (Found_Type) = E_Void
9828            and then Present (Parent (Found_Type))
9829            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
9830          then
9831             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
9832
9833          else
9834             Error_Msg_NE ("\\found}!", Expr, Found_Type);
9835          end if;
9836
9837          Error_Msg_Qual_Level := 0;
9838       end if;
9839    end Wrong_Type;
9840
9841 end Sem_Util;