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