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