gcc/ada/sem_util.adb

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