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-2011, 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_Ch11; use Exp_Ch11;
  33 with Exp_Disp; use Exp_Disp;
  34 with Exp_Util; use Exp_Util;
  35 with Fname;    use Fname;
  36 with Freeze;   use Freeze;
  37 with Lib;      use Lib;
  38 with Lib.Xref; use Lib.Xref;
  39 with Nlists;   use Nlists;
  40 with Output;   use Output;
  41 with Opt;      use Opt;
  42 with Restrict; use Restrict;
  43 with Rident;   use Rident;
  44 with Rtsfind;  use Rtsfind;
  45 with Sem;      use Sem;
  46 with Sem_Aux;  use Sem_Aux;
  47 with Sem_Attr; use Sem_Attr;
  48 with Sem_Ch8;  use Sem_Ch8;
  49 with Sem_Disp; use Sem_Disp;
  50 with Sem_Eval; use Sem_Eval;
  51 with Sem_Res;  use Sem_Res;
  52 with Sem_Type; use Sem_Type;
  53 with Sinfo;    use Sinfo;
  54 with Sinput;   use Sinput;
  55 with Stand;    use Stand;
  56 with Style;
  57 with Stringt;  use Stringt;
  58 with Table;
  59 with Targparm; use Targparm;
  60 with Tbuild;   use Tbuild;
  61 with Ttypes;   use Ttypes;
  62 with Uname;    use Uname;
  63
  64 with GNAT.HTable; use GNAT.HTable;
  65
  66 package body Sem_Util is
  67
  68    ----------------------------------------
  69    -- Global_Variables for New_Copy_Tree --
  70    ----------------------------------------
  71
  72    --  These global variables are used by New_Copy_Tree. See description
  73    --  of the body of this subprogram for details. Global variables can be
  74    --  safely used by New_Copy_Tree, since there is no case of a recursive
  75    --  call from the processing inside New_Copy_Tree.
  76
  77    NCT_Hash_Threshold : constant := 20;
  78    --  If there are more than this number of pairs of entries in the
  79    --  map, then Hash_Tables_Used will be set, and the hash tables will
  80    --  be initialized and used for the searches.
  81
  82    NCT_Hash_Tables_Used : Boolean := False;
  83    --  Set to True if hash tables are in use
  84
  85    NCT_Table_Entries : Nat;
  86    --  Count entries in table to see if threshold is reached
  87
  88    NCT_Hash_Table_Setup : Boolean := False;
  89    --  Set to True if hash table contains data. We set this True if we
  90    --  setup the hash table with data, and leave it set permanently
  91    --  from then on, this is a signal that second and subsequent users
  92    --  of the hash table must clear the old entries before reuse.
  93
  94    subtype NCT_Header_Num is Int range 0 .. 511;
  95    --  Defines range of headers in hash tables (512 headers)
  96
  97    ----------------------------------
  98    -- Order Dependence (AI05-0144) --
  99    ----------------------------------
 100
 101    --  Each actual in a call is entered into the table below. A flag indicates
 102    --  whether the corresponding formal is OUT or IN OUT. Each top-level call
 103    --  (procedure call, condition, assignment) examines all the actuals for a
 104    --  possible order dependence. The table is reset after each such check.
 105    --  The actuals to be checked in a call to Check_Order_Dependence are at
 106    --  positions 1 .. Last.
 107
 108    type Actual_Name is record
 109       Act         : Node_Id;
 110       Is_Writable : Boolean;
 111    end record;
 112
 113    package Actuals_In_Call is new Table.Table (
 114       Table_Component_Type => Actual_Name,
 115       Table_Index_Type     => Int,
 116       Table_Low_Bound      => 0,
 117       Table_Initial        => 10,
 118       Table_Increment      => 100,
 119       Table_Name           => "Actuals");
 120
 121    -----------------------
 122    -- Local Subprograms --
 123    -----------------------
 124
 125    function Build_Component_Subtype
 126      (C   : List_Id;
 127       Loc : Source_Ptr;
 128       T   : Entity_Id) return Node_Id;
 129    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
 130    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
 131    --  Loc is the source location, T is the original subtype.
 132
 133    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
 134    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
 135    --  with discriminants whose default values are static, examine only the
 136    --  components in the selected variant to determine whether all of them
 137    --  have a default.
 138
 139    function Has_Null_Extension (T : Entity_Id) return Boolean;
 140    --  T is a derived tagged type. Check whether the type extension is null.
 141    --  If the parent type is fully initialized, T can be treated as such.
 142
 143    ------------------------------
 144    --  Abstract_Interface_List --
 145    ------------------------------
 146
 147    function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
 148       Nod : Node_Id;
 149
 150    begin
 151       if Is_Concurrent_Type (Typ) then
 152
 153          --  If we are dealing with a synchronized subtype, go to the base
 154          --  type, whose declaration has the interface list.
 155
 156          --  Shouldn't this be Declaration_Node???
 157
 158          Nod := Parent (Base_Type (Typ));
 159
 160          if Nkind (Nod) = N_Full_Type_Declaration then
 161             return Empty_List;
 162          end if;
 163
 164       elsif Ekind (Typ) = E_Record_Type_With_Private then
 165          if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
 166             Nod := Type_Definition (Parent (Typ));
 167
 168          elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
 169             if Present (Full_View (Typ))
 170               and then Nkind (Parent (Full_View (Typ)))
 171                          = N_Full_Type_Declaration
 172             then
 173                Nod := Type_Definition (Parent (Full_View (Typ)));
 174
 175             --  If the full-view is not available we cannot do anything else
 176             --  here (the source has errors).
 177
 178             else
 179                return Empty_List;
 180             end if;
 181
 182          --  Support for generic formals with interfaces is still missing ???
 183
 184          elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 185             return Empty_List;
 186
 187          else
 188             pragma Assert
 189               (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
 190             Nod := Parent (Typ);
 191          end if;
 192
 193       elsif Ekind (Typ) = E_Record_Subtype then
 194          Nod := Type_Definition (Parent (Etype (Typ)));
 195
 196       elsif Ekind (Typ) = E_Record_Subtype_With_Private then
 197
 198          --  Recurse, because parent may still be a private extension. Also
 199          --  note that the full view of the subtype or the full view of its
 200          --  base type may (both) be unavailable.
 201
 202          return Abstract_Interface_List (Etype (Typ));
 203
 204       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
 205          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 206             Nod := Formal_Type_Definition (Parent (Typ));
 207          else
 208             Nod := Type_Definition (Parent (Typ));
 209          end if;
 210       end if;
 211
 212       return Interface_List (Nod);
 213    end Abstract_Interface_List;
 214
 215    --------------------------------
 216    -- Add_Access_Type_To_Process --
 217    --------------------------------
 218
 219    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
 220       L : Elist_Id;
 221
 222    begin
 223       Ensure_Freeze_Node (E);
 224       L := Access_Types_To_Process (Freeze_Node (E));
 225
 226       if No (L) then
 227          L := New_Elmt_List;
 228          Set_Access_Types_To_Process (Freeze_Node (E), L);
 229       end if;
 230
 231       Append_Elmt (A, L);
 232    end Add_Access_Type_To_Process;
 233
 234    ----------------------------
 235    -- Add_Global_Declaration --
 236    ----------------------------
 237
 238    procedure Add_Global_Declaration (N : Node_Id) is
 239       Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
 240
 241    begin
 242       if No (Declarations (Aux_Node)) then
 243          Set_Declarations (Aux_Node, New_List);
 244       end if;
 245
 246       Append_To (Declarations (Aux_Node), N);
 247       Analyze (N);
 248    end Add_Global_Declaration;
 249
 250    -----------------
 251    -- Addressable --
 252    -----------------
 253
 254    --  For now, just 8/16/32/64. but analyze later if AAMP is special???
 255
 256    function Addressable (V : Uint) return Boolean is
 257    begin
 258       return V = Uint_8  or else
 259              V = Uint_16 or else
 260              V = Uint_32 or else
 261              V = Uint_64;
 262    end Addressable;
 263
 264    function Addressable (V : Int) return Boolean is
 265    begin
 266       return V = 8  or else
 267              V = 16 or else
 268              V = 32 or else
 269              V = 64;
 270    end Addressable;
 271
 272    -----------------------
 273    -- Alignment_In_Bits --
 274    -----------------------
 275
 276    function Alignment_In_Bits (E : Entity_Id) return Uint is
 277    begin
 278       return Alignment (E) * System_Storage_Unit;
 279    end Alignment_In_Bits;
 280
 281    -----------------------------------------
 282    -- Apply_Compile_Time_Constraint_Error --
 283    -----------------------------------------
 284
 285    procedure Apply_Compile_Time_Constraint_Error
 286      (N      : Node_Id;
 287       Msg    : String;
 288       Reason : RT_Exception_Code;
 289       Ent    : Entity_Id  := Empty;
 290       Typ    : Entity_Id  := Empty;
 291       Loc    : Source_Ptr := No_Location;
 292       Rep    : Boolean    := True;
 293       Warn   : Boolean    := False)
 294    is
 295       Stat   : constant Boolean := Is_Static_Expression (N);
 296       R_Stat : constant Node_Id :=
 297                  Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
 298       Rtyp   : Entity_Id;
 299
 300    begin
 301       if No (Typ) then
 302          Rtyp := Etype (N);
 303       else
 304          Rtyp := Typ;
 305       end if;
 306
 307       Discard_Node
 308         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 309
 310       if not Rep then
 311          return;
 312       end if;
 313
 314       --  Now we replace the node by an N_Raise_Constraint_Error node
 315       --  This does not need reanalyzing, so set it as analyzed now.
 316
 317       Rewrite (N, R_Stat);
 318       Set_Analyzed (N, True);
 319
 320       Set_Etype (N, Rtyp);
 321       Set_Raises_Constraint_Error (N);
 322
 323       --  Now deal with possible local raise handling
 324
 325       Possible_Local_Raise (N, Standard_Constraint_Error);
 326
 327       --  If the original expression was marked as static, the result is
 328       --  still marked as static, but the Raises_Constraint_Error flag is
 329       --  always set so that further static evaluation is not attempted.
 330
 331       if Stat then
 332          Set_Is_Static_Expression (N);
 333       end if;
 334    end Apply_Compile_Time_Constraint_Error;
 335
 336    --------------------------------
 337    -- Bad_Predicated_Subtype_Use --
 338    --------------------------------
 339
 340    procedure Bad_Predicated_Subtype_Use
 341      (Msg : String;
 342       N   : Node_Id;
 343       Typ : Entity_Id)
 344    is
 345    begin
 346       if Has_Predicates (Typ) then
 347          if Is_Generic_Actual_Type (Typ) then
 348             Error_Msg_FE (Msg & '?', N, Typ);
 349             Error_Msg_F ("\Program_Error will be raised at run time?", N);
 350             Insert_Action (N,
 351               Make_Raise_Program_Error (Sloc (N),
 352                 Reason => PE_Bad_Predicated_Generic_Type));
 353
 354          else
 355             Error_Msg_FE (Msg, N, Typ);
 356          end if;
 357       end if;
 358    end Bad_Predicated_Subtype_Use;
 359
 360    --------------------------
 361    -- Build_Actual_Subtype --
 362    --------------------------
 363
 364    function Build_Actual_Subtype
 365      (T : Entity_Id;
 366       N : Node_Or_Entity_Id) return Node_Id
 367    is
 368       Loc : Source_Ptr;
 369       --  Normally Sloc (N), but may point to corresponding body in some cases
 370
 371       Constraints : List_Id;
 372       Decl        : Node_Id;
 373       Discr       : Entity_Id;
 374       Hi          : Node_Id;
 375       Lo          : Node_Id;
 376       Subt        : Entity_Id;
 377       Disc_Type   : Entity_Id;
 378       Obj         : Node_Id;
 379
 380    begin
 381       Loc := Sloc (N);
 382
 383       if Nkind (N) = N_Defining_Identifier then
 384          Obj := New_Reference_To (N, Loc);
 385
 386          --  If this is a formal parameter of a subprogram declaration, and
 387          --  we are compiling the body, we want the declaration for the
 388          --  actual subtype to carry the source position of the body, to
 389          --  prevent anomalies in gdb when stepping through the code.
 390
 391          if Is_Formal (N) then
 392             declare
 393                Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
 394             begin
 395                if Nkind (Decl) = N_Subprogram_Declaration
 396                  and then Present (Corresponding_Body (Decl))
 397                then
 398                   Loc := Sloc (Corresponding_Body (Decl));
 399                end if;
 400             end;
 401          end if;
 402
 403       else
 404          Obj := N;
 405       end if;
 406
 407       if Is_Array_Type (T) then
 408          Constraints := New_List;
 409          for J in 1 .. Number_Dimensions (T) loop
 410
 411             --  Build an array subtype declaration with the nominal subtype and
 412             --  the bounds of the actual. Add the declaration in front of the
 413             --  local declarations for the subprogram, for analysis before any
 414             --  reference to the formal in the body.
 415
 416             Lo :=
 417               Make_Attribute_Reference (Loc,
 418                 Prefix         =>
 419                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 420                 Attribute_Name => Name_First,
 421                 Expressions    => New_List (
 422                   Make_Integer_Literal (Loc, J)));
 423
 424             Hi :=
 425               Make_Attribute_Reference (Loc,
 426                 Prefix         =>
 427                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 428                 Attribute_Name => Name_Last,
 429                 Expressions    => New_List (
 430                   Make_Integer_Literal (Loc, J)));
 431
 432             Append (Make_Range (Loc, Lo, Hi), Constraints);
 433          end loop;
 434
 435       --  If the type has unknown discriminants there is no constrained
 436       --  subtype to build. This is never called for a formal or for a
 437       --  lhs, so returning the type is ok ???
 438
 439       elsif Has_Unknown_Discriminants (T) then
 440          return T;
 441
 442       else
 443          Constraints := New_List;
 444
 445          --  Type T is a generic derived type, inherit the discriminants from
 446          --  the parent type.
 447
 448          if Is_Private_Type (T)
 449            and then No (Full_View (T))
 450
 451             --  T was flagged as an error if it was declared as a formal
 452             --  derived type with known discriminants. In this case there
 453             --  is no need to look at the parent type since T already carries
 454             --  its own discriminants.
 455
 456            and then not Error_Posted (T)
 457          then
 458             Disc_Type := Etype (Base_Type (T));
 459          else
 460             Disc_Type := T;
 461          end if;
 462
 463          Discr := First_Discriminant (Disc_Type);
 464          while Present (Discr) loop
 465             Append_To (Constraints,
 466               Make_Selected_Component (Loc,
 467                 Prefix =>
 468                   Duplicate_Subexpr_No_Checks (Obj),
 469                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 470             Next_Discriminant (Discr);
 471          end loop;
 472       end if;
 473
 474       Subt := Make_Temporary (Loc, 'S', Related_Node => N);
 475       Set_Is_Internal (Subt);
 476
 477       Decl :=
 478         Make_Subtype_Declaration (Loc,
 479           Defining_Identifier => Subt,
 480           Subtype_Indication =>
 481             Make_Subtype_Indication (Loc,
 482               Subtype_Mark => New_Reference_To (T,  Loc),
 483               Constraint  =>
 484                 Make_Index_Or_Discriminant_Constraint (Loc,
 485                   Constraints => Constraints)));
 486
 487       Mark_Rewrite_Insertion (Decl);
 488       return Decl;
 489    end Build_Actual_Subtype;
 490
 491    ---------------------------------------
 492    -- Build_Actual_Subtype_Of_Component --
 493    ---------------------------------------
 494
 495    function Build_Actual_Subtype_Of_Component
 496      (T : Entity_Id;
 497       N : Node_Id) return Node_Id
 498    is
 499       Loc       : constant Source_Ptr := Sloc (N);
 500       P         : constant Node_Id    := Prefix (N);
 501       D         : Elmt_Id;
 502       Id        : Node_Id;
 503       Index_Typ : Entity_Id;
 504
 505       Desig_Typ : Entity_Id;
 506       --  This is either a copy of T, or if T is an access type, then it is
 507       --  the directly designated type of this access type.
 508
 509       function Build_Actual_Array_Constraint return List_Id;
 510       --  If one or more of the bounds of the component depends on
 511       --  discriminants, build  actual constraint using the discriminants
 512       --  of the prefix.
 513
 514       function Build_Actual_Record_Constraint return List_Id;
 515       --  Similar to previous one, for discriminated components constrained
 516       --  by the discriminant of the enclosing object.
 517
 518       -----------------------------------
 519       -- Build_Actual_Array_Constraint --
 520       -----------------------------------
 521
 522       function Build_Actual_Array_Constraint return List_Id is
 523          Constraints : constant List_Id := New_List;
 524          Indx        : Node_Id;
 525          Hi          : Node_Id;
 526          Lo          : Node_Id;
 527          Old_Hi      : Node_Id;
 528          Old_Lo      : Node_Id;
 529
 530       begin
 531          Indx := First_Index (Desig_Typ);
 532          while Present (Indx) loop
 533             Old_Lo := Type_Low_Bound  (Etype (Indx));
 534             Old_Hi := Type_High_Bound (Etype (Indx));
 535
 536             if Denotes_Discriminant (Old_Lo) then
 537                Lo :=
 538                  Make_Selected_Component (Loc,
 539                    Prefix => New_Copy_Tree (P),
 540                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 541
 542             else
 543                Lo := New_Copy_Tree (Old_Lo);
 544
 545                --  The new bound will be reanalyzed in the enclosing
 546                --  declaration. For literal bounds that come from a type
 547                --  declaration, the type of the context must be imposed, so
 548                --  insure that analysis will take place. For non-universal
 549                --  types this is not strictly necessary.
 550
 551                Set_Analyzed (Lo, False);
 552             end if;
 553
 554             if Denotes_Discriminant (Old_Hi) then
 555                Hi :=
 556                  Make_Selected_Component (Loc,
 557                    Prefix => New_Copy_Tree (P),
 558                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 559
 560             else
 561                Hi := New_Copy_Tree (Old_Hi);
 562                Set_Analyzed (Hi, False);
 563             end if;
 564
 565             Append (Make_Range (Loc, Lo, Hi), Constraints);
 566             Next_Index (Indx);
 567          end loop;
 568
 569          return Constraints;
 570       end Build_Actual_Array_Constraint;
 571
 572       ------------------------------------
 573       -- Build_Actual_Record_Constraint --
 574       ------------------------------------
 575
 576       function Build_Actual_Record_Constraint return List_Id is
 577          Constraints : constant List_Id := New_List;
 578          D           : Elmt_Id;
 579          D_Val       : Node_Id;
 580
 581       begin
 582          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 583          while Present (D) loop
 584             if Denotes_Discriminant (Node (D)) then
 585                D_Val :=  Make_Selected_Component (Loc,
 586                  Prefix => New_Copy_Tree (P),
 587                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 588
 589             else
 590                D_Val := New_Copy_Tree (Node (D));
 591             end if;
 592
 593             Append (D_Val, Constraints);
 594             Next_Elmt (D);
 595          end loop;
 596
 597          return Constraints;
 598       end Build_Actual_Record_Constraint;
 599
 600    --  Start of processing for Build_Actual_Subtype_Of_Component
 601
 602    begin
 603       --  Why the test for Spec_Expression mode here???
 604
 605       if In_Spec_Expression then
 606          return Empty;
 607
 608       --  More comments for the rest of this body would be good ???
 609
 610       elsif Nkind (N) = N_Explicit_Dereference then
 611          if Is_Composite_Type (T)
 612            and then not Is_Constrained (T)
 613            and then not (Is_Class_Wide_Type (T)
 614                           and then Is_Constrained (Root_Type (T)))
 615            and then not Has_Unknown_Discriminants (T)
 616          then
 617             --  If the type of the dereference is already constrained, it is an
 618             --  actual subtype.
 619
 620             if Is_Array_Type (Etype (N))
 621               and then Is_Constrained (Etype (N))
 622             then
 623                return Empty;
 624             else
 625                Remove_Side_Effects (P);
 626                return Build_Actual_Subtype (T, N);
 627             end if;
 628          else
 629             return Empty;
 630          end if;
 631       end if;
 632
 633       if Ekind (T) = E_Access_Subtype then
 634          Desig_Typ := Designated_Type (T);
 635       else
 636          Desig_Typ := T;
 637       end if;
 638
 639       if Ekind (Desig_Typ) = E_Array_Subtype then
 640          Id := First_Index (Desig_Typ);
 641          while Present (Id) loop
 642             Index_Typ := Underlying_Type (Etype (Id));
 643
 644             if Denotes_Discriminant (Type_Low_Bound  (Index_Typ))
 645                  or else
 646                Denotes_Discriminant (Type_High_Bound (Index_Typ))
 647             then
 648                Remove_Side_Effects (P);
 649                return
 650                  Build_Component_Subtype
 651                    (Build_Actual_Array_Constraint, Loc, Base_Type (T));
 652             end if;
 653
 654             Next_Index (Id);
 655          end loop;
 656
 657       elsif Is_Composite_Type (Desig_Typ)
 658         and then Has_Discriminants (Desig_Typ)
 659         and then not Has_Unknown_Discriminants (Desig_Typ)
 660       then
 661          if Is_Private_Type (Desig_Typ)
 662            and then No (Discriminant_Constraint (Desig_Typ))
 663          then
 664             Desig_Typ := Full_View (Desig_Typ);
 665          end if;
 666
 667          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 668          while Present (D) loop
 669             if Denotes_Discriminant (Node (D)) then
 670                Remove_Side_Effects (P);
 671                return
 672                  Build_Component_Subtype (
 673                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
 674             end if;
 675
 676             Next_Elmt (D);
 677          end loop;
 678       end if;
 679
 680       --  If none of the above, the actual and nominal subtypes are the same
 681
 682       return Empty;
 683    end Build_Actual_Subtype_Of_Component;
 684
 685    -----------------------------
 686    -- Build_Component_Subtype --
 687    -----------------------------
 688
 689    function Build_Component_Subtype
 690      (C   : List_Id;
 691       Loc : Source_Ptr;
 692       T   : Entity_Id) return Node_Id
 693    is
 694       Subt : Entity_Id;
 695       Decl : Node_Id;
 696
 697    begin
 698       --  Unchecked_Union components do not require component subtypes
 699
 700       if Is_Unchecked_Union (T) then
 701          return Empty;
 702       end if;
 703
 704       Subt := Make_Temporary (Loc, 'S');
 705       Set_Is_Internal (Subt);
 706
 707       Decl :=
 708         Make_Subtype_Declaration (Loc,
 709           Defining_Identifier => Subt,
 710           Subtype_Indication =>
 711             Make_Subtype_Indication (Loc,
 712               Subtype_Mark => New_Reference_To (Base_Type (T),  Loc),
 713               Constraint  =>
 714                 Make_Index_Or_Discriminant_Constraint (Loc,
 715                   Constraints => C)));
 716
 717       Mark_Rewrite_Insertion (Decl);
 718       return Decl;
 719    end Build_Component_Subtype;
 720
 721    ---------------------------
 722    -- Build_Default_Subtype --
 723    ---------------------------
 724
 725    function Build_Default_Subtype
 726      (T : Entity_Id;
 727       N : Node_Id) return Entity_Id
 728    is
 729       Loc  : constant Source_Ptr := Sloc (N);
 730       Disc : Entity_Id;
 731
 732    begin
 733       if not Has_Discriminants (T) or else Is_Constrained (T) then
 734          return T;
 735       end if;
 736
 737       Disc := First_Discriminant (T);
 738
 739       if No (Discriminant_Default_Value (Disc)) then
 740          return T;
 741       end if;
 742
 743       declare
 744          Act         : constant Entity_Id := Make_Temporary (Loc, 'S');
 745          Constraints : constant List_Id := New_List;
 746          Decl        : Node_Id;
 747
 748       begin
 749          while Present (Disc) loop
 750             Append_To (Constraints,
 751               New_Copy_Tree (Discriminant_Default_Value (Disc)));
 752             Next_Discriminant (Disc);
 753          end loop;
 754
 755          Decl :=
 756            Make_Subtype_Declaration (Loc,
 757              Defining_Identifier => Act,
 758              Subtype_Indication =>
 759                Make_Subtype_Indication (Loc,
 760                  Subtype_Mark => New_Occurrence_Of (T, Loc),
 761                  Constraint =>
 762                    Make_Index_Or_Discriminant_Constraint (Loc,
 763                      Constraints => Constraints)));
 764
 765          Insert_Action (N, Decl);
 766          Analyze (Decl);
 767          return Act;
 768       end;
 769    end Build_Default_Subtype;
 770
 771    --------------------------------------------
 772    -- Build_Discriminal_Subtype_Of_Component --
 773    --------------------------------------------
 774
 775    function Build_Discriminal_Subtype_Of_Component
 776      (T : Entity_Id) return Node_Id
 777    is
 778       Loc : constant Source_Ptr := Sloc (T);
 779       D   : Elmt_Id;
 780       Id  : Node_Id;
 781
 782       function Build_Discriminal_Array_Constraint return List_Id;
 783       --  If one or more of the bounds of the component depends on
 784       --  discriminants, build  actual constraint using the discriminants
 785       --  of the prefix.
 786
 787       function Build_Discriminal_Record_Constraint return List_Id;
 788       --  Similar to previous one, for discriminated components constrained
 789       --  by the discriminant of the enclosing object.
 790
 791       ----------------------------------------
 792       -- Build_Discriminal_Array_Constraint --
 793       ----------------------------------------
 794
 795       function Build_Discriminal_Array_Constraint return List_Id is
 796          Constraints : constant List_Id := New_List;
 797          Indx        : Node_Id;
 798          Hi          : Node_Id;
 799          Lo          : Node_Id;
 800          Old_Hi      : Node_Id;
 801          Old_Lo      : Node_Id;
 802
 803       begin
 804          Indx := First_Index (T);
 805          while Present (Indx) loop
 806             Old_Lo := Type_Low_Bound  (Etype (Indx));
 807             Old_Hi := Type_High_Bound (Etype (Indx));
 808
 809             if Denotes_Discriminant (Old_Lo) then
 810                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
 811
 812             else
 813                Lo := New_Copy_Tree (Old_Lo);
 814             end if;
 815
 816             if Denotes_Discriminant (Old_Hi) then
 817                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
 818
 819             else
 820                Hi := New_Copy_Tree (Old_Hi);
 821             end if;
 822
 823             Append (Make_Range (Loc, Lo, Hi), Constraints);
 824             Next_Index (Indx);
 825          end loop;
 826
 827          return Constraints;
 828       end Build_Discriminal_Array_Constraint;
 829
 830       -----------------------------------------
 831       -- Build_Discriminal_Record_Constraint --
 832       -----------------------------------------
 833
 834       function Build_Discriminal_Record_Constraint return List_Id is
 835          Constraints : constant List_Id := New_List;
 836          D           : Elmt_Id;
 837          D_Val       : Node_Id;
 838
 839       begin
 840          D := First_Elmt (Discriminant_Constraint (T));
 841          while Present (D) loop
 842             if Denotes_Discriminant (Node (D)) then
 843                D_Val :=
 844                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
 845
 846             else
 847                D_Val := New_Copy_Tree (Node (D));
 848             end if;
 849
 850             Append (D_Val, Constraints);
 851             Next_Elmt (D);
 852          end loop;
 853
 854          return Constraints;
 855       end Build_Discriminal_Record_Constraint;
 856
 857    --  Start of processing for Build_Discriminal_Subtype_Of_Component
 858
 859    begin
 860       if Ekind (T) = E_Array_Subtype then
 861          Id := First_Index (T);
 862          while Present (Id) loop
 863             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id))) or else
 864                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
 865             then
 866                return Build_Component_Subtype
 867                  (Build_Discriminal_Array_Constraint, Loc, T);
 868             end if;
 869
 870             Next_Index (Id);
 871          end loop;
 872
 873       elsif Ekind (T) = E_Record_Subtype
 874         and then Has_Discriminants (T)
 875         and then not Has_Unknown_Discriminants (T)
 876       then
 877          D := First_Elmt (Discriminant_Constraint (T));
 878          while Present (D) loop
 879             if Denotes_Discriminant (Node (D)) then
 880                return Build_Component_Subtype
 881                  (Build_Discriminal_Record_Constraint, Loc, T);
 882             end if;
 883
 884             Next_Elmt (D);
 885          end loop;
 886       end if;
 887
 888       --  If none of the above, the actual and nominal subtypes are the same
 889
 890       return Empty;
 891    end Build_Discriminal_Subtype_Of_Component;
 892
 893    ------------------------------
 894    -- Build_Elaboration_Entity --
 895    ------------------------------
 896
 897    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
 898       Loc      : constant Source_Ptr := Sloc (N);
 899       Decl     : Node_Id;
 900       Elab_Ent : Entity_Id;
 901
 902       procedure Set_Package_Name (Ent : Entity_Id);
 903       --  Given an entity, sets the fully qualified name of the entity in
 904       --  Name_Buffer, with components separated by double underscores. This
 905       --  is a recursive routine that climbs the scope chain to Standard.
 906
 907       ----------------------
 908       -- Set_Package_Name --
 909       ----------------------
 910
 911       procedure Set_Package_Name (Ent : Entity_Id) is
 912       begin
 913          if Scope (Ent) /= Standard_Standard then
 914             Set_Package_Name (Scope (Ent));
 915
 916             declare
 917                Nam : constant String := Get_Name_String (Chars (Ent));
 918             begin
 919                Name_Buffer (Name_Len + 1) := '_';
 920                Name_Buffer (Name_Len + 2) := '_';
 921                Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
 922                Name_Len := Name_Len + Nam'Length + 2;
 923             end;
 924
 925          else
 926             Get_Name_String (Chars (Ent));
 927          end if;
 928       end Set_Package_Name;
 929
 930    --  Start of processing for Build_Elaboration_Entity
 931
 932    begin
 933       --  Ignore if already constructed
 934
 935       if Present (Elaboration_Entity (Spec_Id)) then
 936          return;
 937       end if;
 938
 939       --  Construct name of elaboration entity as xxx_E, where xxx is the unit
 940       --  name with dots replaced by double underscore. We have to manually
 941       --  construct this name, since it will be elaborated in the outer scope,
 942       --  and thus will not have the unit name automatically prepended.
 943
 944       Set_Package_Name (Spec_Id);
 945
 946       --  Append _E
 947
 948       Name_Buffer (Name_Len + 1) := '_';
 949       Name_Buffer (Name_Len + 2) := 'E';
 950       Name_Len := Name_Len + 2;
 951
 952       --  Create elaboration counter
 953
 954       Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
 955       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
 956
 957       Decl :=
 958         Make_Object_Declaration (Loc,
 959           Defining_Identifier => Elab_Ent,
 960           Object_Definition   =>
 961             New_Occurrence_Of (Standard_Short_Integer, Loc),
 962           Expression          => Make_Integer_Literal (Loc, Uint_0));
 963
 964       Push_Scope (Standard_Standard);
 965       Add_Global_Declaration (Decl);
 966       Pop_Scope;
 967
 968       --  Reset True_Constant indication, since we will indeed assign a value
 969       --  to the variable in the binder main. We also kill the Current_Value
 970       --  and Last_Assignment fields for the same reason.
 971
 972       Set_Is_True_Constant (Elab_Ent, False);
 973       Set_Current_Value    (Elab_Ent, Empty);
 974       Set_Last_Assignment  (Elab_Ent, Empty);
 975
 976       --  We do not want any further qualification of the name (if we did
 977       --  not do this, we would pick up the name of the generic package
 978       --  in the case of a library level generic instantiation).
 979
 980       Set_Has_Qualified_Name       (Elab_Ent);
 981       Set_Has_Fully_Qualified_Name (Elab_Ent);
 982    end Build_Elaboration_Entity;
 983
 984    --------------------------------
 985    -- Build_Explicit_Dereference --
 986    --------------------------------
 987
 988    procedure Build_Explicit_Dereference
 989      (Expr : Node_Id;
 990       Disc : Entity_Id)
 991    is
 992       Loc : constant Source_Ptr := Sloc (Expr);
 993    begin
 994       Set_Is_Overloaded (Expr, False);
 995       Rewrite (Expr,
 996         Make_Explicit_Dereference (Loc,
 997           Prefix =>
 998             Make_Selected_Component (Loc,
 999               Prefix        => Relocate_Node (Expr),
1000               Selector_Name => New_Occurrence_Of (Disc, Loc))));
1001       Set_Etype (Prefix (Expr), Etype (Disc));
1002       Set_Etype (Expr, Designated_Type (Etype (Disc)));
1003    end Build_Explicit_Dereference;
1004
1005    -----------------------------------
1006    -- Cannot_Raise_Constraint_Error --
1007    -----------------------------------
1008
1009    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1010    begin
1011       if Compile_Time_Known_Value (Expr) then
1012          return True;
1013
1014       elsif Do_Range_Check (Expr) then
1015          return False;
1016
1017       elsif Raises_Constraint_Error (Expr) then
1018          return False;
1019
1020       else
1021          case Nkind (Expr) is
1022             when N_Identifier =>
1023                return True;
1024
1025             when N_Expanded_Name =>
1026                return True;
1027
1028             when N_Selected_Component =>
1029                return not Do_Discriminant_Check (Expr);
1030
1031             when N_Attribute_Reference =>
1032                if Do_Overflow_Check (Expr) then
1033                   return False;
1034
1035                elsif No (Expressions (Expr)) then
1036                   return True;
1037
1038                else
1039                   declare
1040                      N : Node_Id;
1041
1042                   begin
1043                      N := First (Expressions (Expr));
1044                      while Present (N) loop
1045                         if Cannot_Raise_Constraint_Error (N) then
1046                            Next (N);
1047                         else
1048                            return False;
1049                         end if;
1050                      end loop;
1051
1052                      return True;
1053                   end;
1054                end if;
1055
1056             when N_Type_Conversion =>
1057                if Do_Overflow_Check (Expr)
1058                  or else Do_Length_Check (Expr)
1059                  or else Do_Tag_Check (Expr)
1060                then
1061                   return False;
1062                else
1063                   return
1064                     Cannot_Raise_Constraint_Error (Expression (Expr));
1065                end if;
1066
1067             when N_Unchecked_Type_Conversion =>
1068                return Cannot_Raise_Constraint_Error (Expression (Expr));
1069
1070             when N_Unary_Op =>
1071                if Do_Overflow_Check (Expr) then
1072                   return False;
1073                else
1074                   return
1075                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1076                end if;
1077
1078             when N_Op_Divide |
1079                  N_Op_Mod    |
1080                  N_Op_Rem
1081             =>
1082                if Do_Division_Check (Expr)
1083                  or else Do_Overflow_Check (Expr)
1084                then
1085                   return False;
1086                else
1087                   return
1088                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1089                       and then
1090                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1091                end if;
1092
1093             when N_Op_Add                    |
1094                  N_Op_And                    |
1095                  N_Op_Concat                 |
1096                  N_Op_Eq                     |
1097                  N_Op_Expon                  |
1098                  N_Op_Ge                     |
1099                  N_Op_Gt                     |
1100                  N_Op_Le                     |
1101                  N_Op_Lt                     |
1102                  N_Op_Multiply               |
1103                  N_Op_Ne                     |
1104                  N_Op_Or                     |
1105                  N_Op_Rotate_Left            |
1106                  N_Op_Rotate_Right           |
1107                  N_Op_Shift_Left             |
1108                  N_Op_Shift_Right            |
1109                  N_Op_Shift_Right_Arithmetic |
1110                  N_Op_Subtract               |
1111                  N_Op_Xor
1112             =>
1113                if Do_Overflow_Check (Expr) then
1114                   return False;
1115                else
1116                   return
1117                     Cannot_Raise_Constraint_Error (Left_Opnd (Expr))
1118                       and then
1119                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1120                end if;
1121
1122             when others =>
1123                return False;
1124          end case;
1125       end if;
1126    end Cannot_Raise_Constraint_Error;
1127
1128    --------------------------------
1129    -- Check_Implicit_Dereference --
1130    --------------------------------
1131
1132    procedure Check_Implicit_Dereference (Nam : Node_Id;  Typ : Entity_Id)
1133    is
1134       Disc  : Entity_Id;
1135       Desig : Entity_Id;
1136
1137    begin
1138       if Ada_Version < Ada_2012
1139         or else not Has_Implicit_Dereference (Base_Type (Typ))
1140       then
1141          return;
1142
1143       elsif not Comes_From_Source (Nam) then
1144          return;
1145
1146       elsif Is_Entity_Name (Nam)
1147         and then Is_Type (Entity (Nam))
1148       then
1149          null;
1150
1151       else
1152          Disc := First_Discriminant (Typ);
1153          while Present (Disc) loop
1154             if Has_Implicit_Dereference (Disc) then
1155                Desig := Designated_Type (Etype (Disc));
1156                Add_One_Interp (Nam, Disc, Desig);
1157                exit;
1158             end if;
1159
1160             Next_Discriminant (Disc);
1161          end loop;
1162       end if;
1163    end Check_Implicit_Dereference;
1164
1165    ---------------------------------------
1166    -- Check_Later_Vs_Basic_Declarations --
1167    ---------------------------------------
1168
1169    procedure Check_Later_Vs_Basic_Declarations
1170      (Decls          : List_Id;
1171       During_Parsing : Boolean)
1172    is
1173       Body_Sloc : Source_Ptr;
1174       Decl      : Node_Id;
1175
1176       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
1177       --  Return whether Decl is considered as a declarative item.
1178       --  When During_Parsing is True, the semantics of Ada 83 is followed.
1179       --  When During_Parsing is False, the semantics of SPARK is followed.
1180
1181       -------------------------------
1182       -- Is_Later_Declarative_Item --
1183       -------------------------------
1184
1185       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
1186       begin
1187          if Nkind (Decl) in N_Later_Decl_Item then
1188             return True;
1189
1190          elsif Nkind (Decl) = N_Pragma then
1191             return True;
1192
1193          elsif During_Parsing then
1194             return False;
1195
1196          --  In SPARK, a package declaration is not considered as a later
1197          --  declarative item.
1198
1199          elsif Nkind (Decl) = N_Package_Declaration then
1200             return False;
1201
1202          --  In SPARK, a renaming is considered as a later declarative item
1203
1204          elsif Nkind (Decl) in N_Renaming_Declaration then
1205             return True;
1206
1207          else
1208             return False;
1209          end if;
1210       end Is_Later_Declarative_Item;
1211
1212    --  Start of Check_Later_Vs_Basic_Declarations
1213
1214    begin
1215       Decl := First (Decls);
1216
1217       --  Loop through sequence of basic declarative items
1218
1219       Outer : while Present (Decl) loop
1220          if Nkind (Decl) /= N_Subprogram_Body
1221            and then Nkind (Decl) /= N_Package_Body
1222            and then Nkind (Decl) /= N_Task_Body
1223            and then Nkind (Decl) not in N_Body_Stub
1224          then
1225             Next (Decl);
1226
1227             --  Once a body is encountered, we only allow later declarative
1228             --  items. The inner loop checks the rest of the list.
1229
1230          else
1231             Body_Sloc := Sloc (Decl);
1232
1233             Inner : while Present (Decl) loop
1234                if not Is_Later_Declarative_Item (Decl) then
1235                   if During_Parsing then
1236                      if Ada_Version = Ada_83 then
1237                         Error_Msg_Sloc := Body_Sloc;
1238                         Error_Msg_N
1239                           ("(Ada 83) decl cannot appear after body#", Decl);
1240                      end if;
1241                   else
1242                      Error_Msg_Sloc := Body_Sloc;
1243                      Check_SPARK_Restriction
1244                        ("decl cannot appear after body#", Decl);
1245                   end if;
1246                end if;
1247
1248                Next (Decl);
1249             end loop Inner;
1250          end if;
1251       end loop Outer;
1252    end Check_Later_Vs_Basic_Declarations;
1253
1254    -----------------------------------------
1255    -- Check_Dynamically_Tagged_Expression --
1256    -----------------------------------------
1257
1258    procedure Check_Dynamically_Tagged_Expression
1259      (Expr        : Node_Id;
1260       Typ         : Entity_Id;
1261       Related_Nod : Node_Id)
1262    is
1263    begin
1264       pragma Assert (Is_Tagged_Type (Typ));
1265
1266       --  In order to avoid spurious errors when analyzing the expanded code,
1267       --  this check is done only for nodes that come from source and for
1268       --  actuals of generic instantiations.
1269
1270       if (Comes_From_Source (Related_Nod)
1271            or else In_Generic_Actual (Expr))
1272         and then (Is_Class_Wide_Type (Etype (Expr))
1273                    or else Is_Dynamically_Tagged (Expr))
1274         and then Is_Tagged_Type (Typ)
1275         and then not Is_Class_Wide_Type (Typ)
1276       then
1277          Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1278       end if;
1279    end Check_Dynamically_Tagged_Expression;
1280
1281    --------------------------
1282    -- Check_Fully_Declared --
1283    --------------------------
1284
1285    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1286    begin
1287       if Ekind (T) = E_Incomplete_Type then
1288
1289          --  Ada 2005 (AI-50217): If the type is available through a limited
1290          --  with_clause, verify that its full view has been analyzed.
1291
1292          if From_With_Type (T)
1293            and then Present (Non_Limited_View (T))
1294            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1295          then
1296             --  The non-limited view is fully declared
1297             null;
1298
1299          else
1300             Error_Msg_NE
1301               ("premature usage of incomplete}", N, First_Subtype (T));
1302          end if;
1303
1304       --  Need comments for these tests ???
1305
1306       elsif Has_Private_Component (T)
1307         and then not Is_Generic_Type (Root_Type (T))
1308         and then not In_Spec_Expression
1309       then
1310          --  Special case: if T is the anonymous type created for a single
1311          --  task or protected object, use the name of the source object.
1312
1313          if Is_Concurrent_Type (T)
1314            and then not Comes_From_Source (T)
1315            and then Nkind (N) = N_Object_Declaration
1316          then
1317             Error_Msg_NE ("type of& has incomplete component", N,
1318               Defining_Identifier (N));
1319
1320          else
1321             Error_Msg_NE
1322               ("premature usage of incomplete}", N, First_Subtype (T));
1323          end if;
1324       end if;
1325    end Check_Fully_Declared;
1326
1327    -------------------------
1328    -- Check_Nested_Access --
1329    -------------------------
1330
1331    procedure Check_Nested_Access (Ent : Entity_Id) is
1332       Scop         : constant Entity_Id := Current_Scope;
1333       Current_Subp : Entity_Id;
1334       Enclosing    : Entity_Id;
1335
1336    begin
1337       --  Currently only enabled for VM back-ends for efficiency, should we
1338       --  enable it more systematically ???
1339
1340       --  Check for Is_Imported needs commenting below ???
1341
1342       if VM_Target /= No_VM
1343         and then (Ekind (Ent) = E_Variable
1344                     or else
1345                   Ekind (Ent) = E_Constant
1346                     or else
1347                   Ekind (Ent) = E_Loop_Parameter)
1348         and then Scope (Ent) /= Empty
1349         and then not Is_Library_Level_Entity (Ent)
1350         and then not Is_Imported (Ent)
1351       then
1352          if Is_Subprogram (Scop)
1353            or else Is_Generic_Subprogram (Scop)
1354            or else Is_Entry (Scop)
1355          then
1356             Current_Subp := Scop;
1357          else
1358             Current_Subp := Current_Subprogram;
1359          end if;
1360
1361          Enclosing := Enclosing_Subprogram (Ent);
1362
1363          if Enclosing /= Empty
1364            and then Enclosing /= Current_Subp
1365          then
1366             Set_Has_Up_Level_Access (Ent, True);
1367          end if;
1368       end if;
1369    end Check_Nested_Access;
1370
1371    ----------------------------
1372    -- Check_Order_Dependence --
1373    ----------------------------
1374
1375    procedure Check_Order_Dependence is
1376       Act1 : Node_Id;
1377       Act2 : Node_Id;
1378
1379    begin
1380       if Ada_Version < Ada_2012 then
1381          return;
1382       end if;
1383
1384       --  Ada 2012 AI05-0144-2: Dangerous order dependence. Actuals in nested
1385       --  calls within a construct have been collected. If one of them is
1386       --  writable and overlaps with another one, evaluation of the enclosing
1387       --  construct is nondeterministic. This is illegal in Ada 2012, but is
1388       --  treated as a warning for now.
1389
1390       for J in 1 .. Actuals_In_Call.Last loop
1391          if Actuals_In_Call.Table (J).Is_Writable then
1392             Act1 := Actuals_In_Call.Table (J).Act;
1393
1394             if Nkind (Act1) = N_Attribute_Reference then
1395                Act1 := Prefix (Act1);
1396             end if;
1397
1398             for K in 1 .. Actuals_In_Call.Last loop
1399                if K /= J then
1400                   Act2 := Actuals_In_Call.Table (K).Act;
1401
1402                   if Nkind (Act2) = N_Attribute_Reference then
1403                      Act2 := Prefix (Act2);
1404                   end if;
1405
1406                   if Actuals_In_Call.Table (K).Is_Writable
1407                     and then K < J
1408                   then
1409                      --  Already checked
1410
1411                      null;
1412
1413                   elsif Denotes_Same_Object (Act1, Act2)
1414                     and then Parent (Act1) /= Parent (Act2)
1415                   then
1416                      Error_Msg_N
1417                        ("result may differ if evaluated "
1418                         & "after other actual in expression?", Act1);
1419                   end if;
1420                end if;
1421             end loop;
1422          end if;
1423       end loop;
1424
1425       --  Remove checked actuals from table
1426
1427       Actuals_In_Call.Set_Last (0);
1428    end Check_Order_Dependence;
1429
1430    ------------------------------------------
1431    -- Check_Potentially_Blocking_Operation --
1432    ------------------------------------------
1433
1434    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
1435       S : Entity_Id;
1436
1437    begin
1438       --  N is one of the potentially blocking operations listed in 9.5.1(8).
1439       --  When pragma Detect_Blocking is active, the run time will raise
1440       --  Program_Error. Here we only issue a warning, since we generally
1441       --  support the use of potentially blocking operations in the absence
1442       --  of the pragma.
1443
1444       --  Indirect blocking through a subprogram call cannot be diagnosed
1445       --  statically without interprocedural analysis, so we do not attempt
1446       --  to do it here.
1447
1448       S := Scope (Current_Scope);
1449       while Present (S) and then S /= Standard_Standard loop
1450          if Is_Protected_Type (S) then
1451             Error_Msg_N
1452               ("potentially blocking operation in protected operation?", N);
1453             return;
1454          end if;
1455
1456          S := Scope (S);
1457       end loop;
1458    end Check_Potentially_Blocking_Operation;
1459
1460    ------------------------------
1461    -- Check_Unprotected_Access --
1462    ------------------------------
1463
1464    procedure Check_Unprotected_Access
1465      (Context : Node_Id;
1466       Expr    : Node_Id)
1467    is
1468       Cont_Encl_Typ : Entity_Id;
1469       Pref_Encl_Typ : Entity_Id;
1470
1471       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
1472       --  Check whether Obj is a private component of a protected object.
1473       --  Return the protected type where the component resides, Empty
1474       --  otherwise.
1475
1476       function Is_Public_Operation return Boolean;
1477       --  Verify that the enclosing operation is callable from outside the
1478       --  protected object, to minimize false positives.
1479
1480       ------------------------------
1481       -- Enclosing_Protected_Type --
1482       ------------------------------
1483
1484       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
1485       begin
1486          if Is_Entity_Name (Obj) then
1487             declare
1488                Ent : Entity_Id := Entity (Obj);
1489
1490             begin
1491                --  The object can be a renaming of a private component, use
1492                --  the original record component.
1493
1494                if Is_Prival (Ent) then
1495                   Ent := Prival_Link (Ent);
1496                end if;
1497
1498                if Is_Protected_Type (Scope (Ent)) then
1499                   return Scope (Ent);
1500                end if;
1501             end;
1502          end if;
1503
1504          --  For indexed and selected components, recursively check the prefix
1505
1506          if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
1507             return Enclosing_Protected_Type (Prefix (Obj));
1508
1509          --  The object does not denote a protected component
1510
1511          else
1512             return Empty;
1513          end if;
1514       end Enclosing_Protected_Type;
1515
1516       -------------------------
1517       -- Is_Public_Operation --
1518       -------------------------
1519
1520       function Is_Public_Operation return Boolean is
1521          S : Entity_Id;
1522          E : Entity_Id;
1523
1524       begin
1525          S := Current_Scope;
1526          while Present (S)
1527            and then S /= Pref_Encl_Typ
1528          loop
1529             if Scope (S) = Pref_Encl_Typ then
1530                E := First_Entity (Pref_Encl_Typ);
1531                while Present (E)
1532                  and then E /= First_Private_Entity (Pref_Encl_Typ)
1533                loop
1534                   if E = S then
1535                      return True;
1536                   end if;
1537                   Next_Entity (E);
1538                end loop;
1539             end if;
1540
1541             S := Scope (S);
1542          end loop;
1543
1544          return False;
1545       end Is_Public_Operation;
1546
1547    --  Start of processing for Check_Unprotected_Access
1548
1549    begin
1550       if Nkind (Expr) = N_Attribute_Reference
1551         and then Attribute_Name (Expr) = Name_Unchecked_Access
1552       then
1553          Cont_Encl_Typ := Enclosing_Protected_Type (Context);
1554          Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
1555
1556          --  Check whether we are trying to export a protected component to a
1557          --  context with an equal or lower access level.
1558
1559          if Present (Pref_Encl_Typ)
1560            and then No (Cont_Encl_Typ)
1561            and then Is_Public_Operation
1562            and then Scope_Depth (Pref_Encl_Typ) >=
1563                       Object_Access_Level (Context)
1564          then
1565             Error_Msg_N
1566               ("?possible unprotected access to protected data", Expr);
1567          end if;
1568       end if;
1569    end Check_Unprotected_Access;
1570
1571    ---------------
1572    -- Check_VMS --
1573    ---------------
1574
1575    procedure Check_VMS (Construct : Node_Id) is
1576    begin
1577       if not OpenVMS_On_Target then
1578          Error_Msg_N
1579            ("this construct is allowed only in Open'V'M'S", Construct);
1580       end if;
1581    end Check_VMS;
1582
1583    ------------------------
1584    -- Collect_Interfaces --
1585    ------------------------
1586
1587    procedure Collect_Interfaces
1588      (T               : Entity_Id;
1589       Ifaces_List     : out Elist_Id;
1590       Exclude_Parents : Boolean := False;
1591       Use_Full_View   : Boolean := True)
1592    is
1593       procedure Collect (Typ : Entity_Id);
1594       --  Subsidiary subprogram used to traverse the whole list
1595       --  of directly and indirectly implemented interfaces
1596
1597       -------------
1598       -- Collect --
1599       -------------
1600
1601       procedure Collect (Typ : Entity_Id) is
1602          Ancestor   : Entity_Id;
1603          Full_T     : Entity_Id;
1604          Id         : Node_Id;
1605          Iface      : Entity_Id;
1606
1607       begin
1608          Full_T := Typ;
1609
1610          --  Handle private types
1611
1612          if Use_Full_View
1613            and then Is_Private_Type (Typ)
1614            and then Present (Full_View (Typ))
1615          then
1616             Full_T := Full_View (Typ);
1617          end if;
1618
1619          --  Include the ancestor if we are generating the whole list of
1620          --  abstract interfaces.
1621
1622          if Etype (Full_T) /= Typ
1623
1624             --  Protect the frontend against wrong sources. For example:
1625
1626             --    package P is
1627             --      type A is tagged null record;
1628             --      type B is new A with private;
1629             --      type C is new A with private;
1630             --    private
1631             --      type B is new C with null record;
1632             --      type C is new B with null record;
1633             --    end P;
1634
1635            and then Etype (Full_T) /= T
1636          then
1637             Ancestor := Etype (Full_T);
1638             Collect (Ancestor);
1639
1640             if Is_Interface (Ancestor)
1641               and then not Exclude_Parents
1642             then
1643                Append_Unique_Elmt (Ancestor, Ifaces_List);
1644             end if;
1645          end if;
1646
1647          --  Traverse the graph of ancestor interfaces
1648
1649          if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
1650             Id := First (Abstract_Interface_List (Full_T));
1651             while Present (Id) loop
1652                Iface := Etype (Id);
1653
1654                --  Protect against wrong uses. For example:
1655                --    type I is interface;
1656                --    type O is tagged null record;
1657                --    type Wrong is new I and O with null record; -- ERROR
1658
1659                if Is_Interface (Iface) then
1660                   if Exclude_Parents
1661                     and then Etype (T) /= T
1662                     and then Interface_Present_In_Ancestor (Etype (T), Iface)
1663                   then
1664                      null;
1665                   else
1666                      Collect (Iface);
1667                      Append_Unique_Elmt (Iface, Ifaces_List);
1668                   end if;
1669                end if;
1670
1671                Next (Id);
1672             end loop;
1673          end if;
1674       end Collect;
1675
1676    --  Start of processing for Collect_Interfaces
1677
1678    begin
1679       pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
1680       Ifaces_List := New_Elmt_List;
1681       Collect (T);
1682    end Collect_Interfaces;
1683
1684    ----------------------------------
1685    -- Collect_Interface_Components --
1686    ----------------------------------
1687
1688    procedure Collect_Interface_Components
1689      (Tagged_Type     : Entity_Id;
1690       Components_List : out Elist_Id)
1691    is
1692       procedure Collect (Typ : Entity_Id);
1693       --  Subsidiary subprogram used to climb to the parents
1694
1695       -------------
1696       -- Collect --
1697       -------------
1698
1699       procedure Collect (Typ : Entity_Id) is
1700          Tag_Comp   : Entity_Id;
1701          Parent_Typ : Entity_Id;
1702
1703       begin
1704          --  Handle private types
1705
1706          if Present (Full_View (Etype (Typ))) then
1707             Parent_Typ := Full_View (Etype (Typ));
1708          else
1709             Parent_Typ := Etype (Typ);
1710          end if;
1711
1712          if Parent_Typ /= Typ
1713
1714             --  Protect the frontend against wrong sources. For example:
1715
1716             --    package P is
1717             --      type A is tagged null record;
1718             --      type B is new A with private;
1719             --      type C is new A with private;
1720             --    private
1721             --      type B is new C with null record;
1722             --      type C is new B with null record;
1723             --    end P;
1724
1725            and then Parent_Typ /= Tagged_Type
1726          then
1727             Collect (Parent_Typ);
1728          end if;
1729
1730          --  Collect the components containing tags of secondary dispatch
1731          --  tables.
1732
1733          Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
1734          while Present (Tag_Comp) loop
1735             pragma Assert (Present (Related_Type (Tag_Comp)));
1736             Append_Elmt (Tag_Comp, Components_List);
1737
1738             Tag_Comp := Next_Tag_Component (Tag_Comp);
1739          end loop;
1740       end Collect;
1741
1742    --  Start of processing for Collect_Interface_Components
1743
1744    begin
1745       pragma Assert (Ekind (Tagged_Type) = E_Record_Type
1746         and then Is_Tagged_Type (Tagged_Type));
1747
1748       Components_List := New_Elmt_List;
1749       Collect (Tagged_Type);
1750    end Collect_Interface_Components;
1751
1752    -----------------------------
1753    -- Collect_Interfaces_Info --
1754    -----------------------------
1755
1756    procedure Collect_Interfaces_Info
1757      (T               : Entity_Id;
1758       Ifaces_List     : out Elist_Id;
1759       Components_List : out Elist_Id;
1760       Tags_List       : out Elist_Id)
1761    is
1762       Comps_List : Elist_Id;
1763       Comp_Elmt  : Elmt_Id;
1764       Comp_Iface : Entity_Id;
1765       Iface_Elmt : Elmt_Id;
1766       Iface      : Entity_Id;
1767
1768       function Search_Tag (Iface : Entity_Id) return Entity_Id;
1769       --  Search for the secondary tag associated with the interface type
1770       --  Iface that is implemented by T.
1771
1772       ----------------
1773       -- Search_Tag --
1774       ----------------
1775
1776       function Search_Tag (Iface : Entity_Id) return Entity_Id is
1777          ADT : Elmt_Id;
1778       begin
1779          if not Is_CPP_Class (T) then
1780             ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
1781          else
1782             ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
1783          end if;
1784
1785          while Present (ADT)
1786             and then Is_Tag (Node (ADT))
1787             and then Related_Type (Node (ADT)) /= Iface
1788          loop
1789             --  Skip secondary dispatch table referencing thunks to user
1790             --  defined primitives covered by this interface.
1791
1792             pragma Assert (Has_Suffix (Node (ADT), 'P'));
1793             Next_Elmt (ADT);
1794
1795             --  Skip secondary dispatch tables of Ada types
1796
1797             if not Is_CPP_Class (T) then
1798
1799                --  Skip secondary dispatch table referencing thunks to
1800                --  predefined primitives.
1801
1802                pragma Assert (Has_Suffix (Node (ADT), 'Y'));
1803                Next_Elmt (ADT);
1804
1805                --  Skip secondary dispatch table referencing user-defined
1806                --  primitives covered by this interface.
1807
1808                pragma Assert (Has_Suffix (Node (ADT), 'D'));
1809                Next_Elmt (ADT);
1810
1811                --  Skip secondary dispatch table referencing predefined
1812                --  primitives.
1813
1814                pragma Assert (Has_Suffix (Node (ADT), 'Z'));
1815                Next_Elmt (ADT);
1816             end if;
1817          end loop;
1818
1819          pragma Assert (Is_Tag (Node (ADT)));
1820          return Node (ADT);
1821       end Search_Tag;
1822
1823    --  Start of processing for Collect_Interfaces_Info
1824
1825    begin
1826       Collect_Interfaces (T, Ifaces_List);
1827       Collect_Interface_Components (T, Comps_List);
1828
1829       --  Search for the record component and tag associated with each
1830       --  interface type of T.
1831
1832       Components_List := New_Elmt_List;
1833       Tags_List       := New_Elmt_List;
1834
1835       Iface_Elmt := First_Elmt (Ifaces_List);
1836       while Present (Iface_Elmt) loop
1837          Iface := Node (Iface_Elmt);
1838
1839          --  Associate the primary tag component and the primary dispatch table
1840          --  with all the interfaces that are parents of T
1841
1842          if Is_Ancestor (Iface, T, Use_Full_View => True) then
1843             Append_Elmt (First_Tag_Component (T), Components_List);
1844             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
1845
1846          --  Otherwise search for the tag component and secondary dispatch
1847          --  table of Iface
1848
1849          else
1850             Comp_Elmt := First_Elmt (Comps_List);
1851             while Present (Comp_Elmt) loop
1852                Comp_Iface := Related_Type (Node (Comp_Elmt));
1853
1854                if Comp_Iface = Iface
1855                  or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
1856                then
1857                   Append_Elmt (Node (Comp_Elmt), Components_List);
1858                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
1859                   exit;
1860                end if;
1861
1862                Next_Elmt (Comp_Elmt);
1863             end loop;
1864             pragma Assert (Present (Comp_Elmt));
1865          end if;
1866
1867          Next_Elmt (Iface_Elmt);
1868       end loop;
1869    end Collect_Interfaces_Info;
1870
1871    ---------------------
1872    -- Collect_Parents --
1873    ---------------------
1874
1875    procedure Collect_Parents
1876      (T             : Entity_Id;
1877       List          : out Elist_Id;
1878       Use_Full_View : Boolean := True)
1879    is
1880       Current_Typ : Entity_Id := T;
1881       Parent_Typ  : Entity_Id;
1882
1883    begin
1884       List := New_Elmt_List;
1885
1886       --  No action if the if the type has no parents
1887
1888       if T = Etype (T) then
1889          return;
1890       end if;
1891
1892       loop
1893          Parent_Typ := Etype (Current_Typ);
1894
1895          if Is_Private_Type (Parent_Typ)
1896            and then Present (Full_View (Parent_Typ))
1897            and then Use_Full_View
1898          then
1899             Parent_Typ := Full_View (Base_Type (Parent_Typ));
1900          end if;
1901
1902          Append_Elmt (Parent_Typ, List);
1903
1904          exit when Parent_Typ = Current_Typ;
1905          Current_Typ := Parent_Typ;
1906       end loop;
1907    end Collect_Parents;
1908
1909    ----------------------------------
1910    -- Collect_Primitive_Operations --
1911    ----------------------------------
1912
1913    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
1914       B_Type         : constant Entity_Id := Base_Type (T);
1915       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
1916       B_Scope        : Entity_Id          := Scope (B_Type);
1917       Op_List        : Elist_Id;
1918       Formal         : Entity_Id;
1919       Is_Prim        : Boolean;
1920       Formal_Derived : Boolean := False;
1921       Id             : Entity_Id;
1922
1923       function Match (E : Entity_Id) return Boolean;
1924       --  True if E's base type is B_Type, or E is of an anonymous access type
1925       --  and the base type of its designated type is B_Type.
1926
1927       -----------
1928       -- Match --
1929       -----------
1930
1931       function Match (E : Entity_Id) return Boolean is
1932          Etyp : Entity_Id := Etype (E);
1933
1934       begin
1935          if Ekind (Etyp) = E_Anonymous_Access_Type then
1936             Etyp := Designated_Type (Etyp);
1937          end if;
1938
1939          return Base_Type (Etyp) = B_Type;
1940       end Match;
1941
1942    --  Start of processing for Collect_Primitive_Operations
1943
1944    begin
1945       --  For tagged types, the primitive operations are collected as they
1946       --  are declared, and held in an explicit list which is simply returned.
1947
1948       if Is_Tagged_Type (B_Type) then
1949          return Primitive_Operations (B_Type);
1950
1951       --  An untagged generic type that is a derived type inherits the
1952       --  primitive operations of its parent type. Other formal types only
1953       --  have predefined operators, which are not explicitly represented.
1954
1955       elsif Is_Generic_Type (B_Type) then
1956          if Nkind (B_Decl) = N_Formal_Type_Declaration
1957            and then Nkind (Formal_Type_Definition (B_Decl))
1958              = N_Formal_Derived_Type_Definition
1959          then
1960             Formal_Derived := True;
1961          else
1962             return New_Elmt_List;
1963          end if;
1964       end if;
1965
1966       Op_List := New_Elmt_List;
1967
1968       if B_Scope = Standard_Standard then
1969          if B_Type = Standard_String then
1970             Append_Elmt (Standard_Op_Concat, Op_List);
1971
1972          elsif B_Type = Standard_Wide_String then
1973             Append_Elmt (Standard_Op_Concatw, Op_List);
1974
1975          else
1976             null;
1977          end if;
1978
1979       elsif (Is_Package_Or_Generic_Package (B_Scope)
1980               and then
1981                 Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
1982                                                             N_Package_Body)
1983         or else Is_Derived_Type (B_Type)
1984       then
1985          --  The primitive operations appear after the base type, except
1986          --  if the derivation happens within the private part of B_Scope
1987          --  and the type is a private type, in which case both the type
1988          --  and some primitive operations may appear before the base
1989          --  type, and the list of candidates starts after the type.
1990
1991          if In_Open_Scopes (B_Scope)
1992            and then Scope (T) = B_Scope
1993            and then In_Private_Part (B_Scope)
1994          then
1995             Id := Next_Entity (T);
1996          else
1997             Id := Next_Entity (B_Type);
1998          end if;
1999
2000          while Present (Id) loop
2001
2002             --  Note that generic formal subprograms are not
2003             --  considered to be primitive operations and thus
2004             --  are never inherited.
2005
2006             if Is_Overloadable (Id)
2007               and then Nkind (Parent (Parent (Id)))
2008                          not in N_Formal_Subprogram_Declaration
2009             then
2010                Is_Prim := False;
2011
2012                if Match (Id) then
2013                   Is_Prim := True;
2014
2015                else
2016                   Formal := First_Formal (Id);
2017                   while Present (Formal) loop
2018                      if Match (Formal) then
2019                         Is_Prim := True;
2020                         exit;
2021                      end if;
2022
2023                      Next_Formal (Formal);
2024                   end loop;
2025                end if;
2026
2027                --  For a formal derived type, the only primitives are the
2028                --  ones inherited from the parent type. Operations appearing
2029                --  in the package declaration are not primitive for it.
2030
2031                if Is_Prim
2032                  and then (not Formal_Derived
2033                             or else Present (Alias (Id)))
2034                then
2035                   --  In the special case of an equality operator aliased to
2036                   --  an overriding dispatching equality belonging to the same
2037                   --  type, we don't include it in the list of primitives.
2038                   --  This avoids inheriting multiple equality operators when
2039                   --  deriving from untagged private types whose full type is
2040                   --  tagged, which can otherwise cause ambiguities. Note that
2041                   --  this should only happen for this kind of untagged parent
2042                   --  type, since normally dispatching operations are inherited
2043                   --  using the type's Primitive_Operations list.
2044
2045                   if Chars (Id) = Name_Op_Eq
2046                     and then Is_Dispatching_Operation (Id)
2047                     and then Present (Alias (Id))
2048                     and then Present (Overridden_Operation (Alias (Id)))
2049                     and then Base_Type (Etype (First_Entity (Id))) =
2050                                Base_Type (Etype (First_Entity (Alias (Id))))
2051                   then
2052                      null;
2053
2054                   --  Include the subprogram in the list of primitives
2055
2056                   else
2057                      Append_Elmt (Id, Op_List);
2058                   end if;
2059                end if;
2060             end if;
2061
2062             Next_Entity (Id);
2063
2064             --  For a type declared in System, some of its operations may
2065             --  appear in the target-specific extension to System.
2066
2067             if No (Id)
2068               and then B_Scope = RTU_Entity (System)
2069               and then Present_System_Aux
2070             then
2071                B_Scope := System_Aux_Id;
2072                Id := First_Entity (System_Aux_Id);
2073             end if;
2074          end loop;
2075       end if;
2076
2077       return Op_List;
2078    end Collect_Primitive_Operations;
2079
2080    -----------------------------------
2081    -- Compile_Time_Constraint_Error --
2082    -----------------------------------
2083
2084    function Compile_Time_Constraint_Error
2085      (N    : Node_Id;
2086       Msg  : String;
2087       Ent  : Entity_Id  := Empty;
2088       Loc  : Source_Ptr := No_Location;
2089       Warn : Boolean    := False) return Node_Id
2090    is
2091       Msgc : String (1 .. Msg'Length + 2);
2092       --  Copy of message, with room for possible ? and ! at end
2093
2094       Msgl : Natural;
2095       Wmsg : Boolean;
2096       P    : Node_Id;
2097       OldP : Node_Id;
2098       Msgs : Boolean;
2099       Eloc : Source_Ptr;
2100
2101    begin
2102       --  A static constraint error in an instance body is not a fatal error.
2103       --  we choose to inhibit the message altogether, because there is no
2104       --  obvious node (for now) on which to post it. On the other hand the
2105       --  offending node must be replaced with a constraint_error in any case.
2106
2107       --  No messages are generated if we already posted an error on this node
2108
2109       if not Error_Posted (N) then
2110          if Loc /= No_Location then
2111             Eloc := Loc;
2112          else
2113             Eloc := Sloc (N);
2114          end if;
2115
2116          Msgc (1 .. Msg'Length) := Msg;
2117          Msgl := Msg'Length;
2118
2119          --  Message is a warning, even in Ada 95 case
2120
2121          if Msg (Msg'Last) = '?' then
2122             Wmsg := True;
2123
2124          --  In Ada 83, all messages are warnings. In the private part and
2125          --  the body of an instance, constraint_checks are only warnings.
2126          --  We also make this a warning if the Warn parameter is set.
2127
2128          elsif Warn
2129            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
2130          then
2131             Msgl := Msgl + 1;
2132             Msgc (Msgl) := '?';
2133             Wmsg := True;
2134
2135          elsif In_Instance_Not_Visible then
2136             Msgl := Msgl + 1;
2137             Msgc (Msgl) := '?';
2138             Wmsg := True;
2139
2140          --  Otherwise we have a real error message (Ada 95 static case)
2141          --  and we make this an unconditional message. Note that in the
2142          --  warning case we do not make the message unconditional, it seems
2143          --  quite reasonable to delete messages like this (about exceptions
2144          --  that will be raised) in dead code.
2145
2146          else
2147             Wmsg := False;
2148             Msgl := Msgl + 1;
2149             Msgc (Msgl) := '!';
2150          end if;
2151
2152          --  Should we generate a warning? The answer is not quite yes. The
2153          --  very annoying exception occurs in the case of a short circuit
2154          --  operator where the left operand is static and decisive. Climb
2155          --  parents to see if that is the case we have here. Conditional
2156          --  expressions with decisive conditions are a similar situation.
2157
2158          Msgs := True;
2159          P := N;
2160          loop
2161             OldP := P;
2162             P := Parent (P);
2163
2164             --  And then with False as left operand
2165
2166             if Nkind (P) = N_And_Then
2167               and then Compile_Time_Known_Value (Left_Opnd (P))
2168               and then Is_False (Expr_Value (Left_Opnd (P)))
2169             then
2170                Msgs := False;
2171                exit;
2172
2173             --  OR ELSE with True as left operand
2174
2175             elsif Nkind (P) = N_Or_Else
2176               and then Compile_Time_Known_Value (Left_Opnd (P))
2177               and then Is_True (Expr_Value (Left_Opnd (P)))
2178             then
2179                Msgs := False;
2180                exit;
2181
2182             --  Conditional expression
2183
2184             elsif Nkind (P) = N_Conditional_Expression then
2185                declare
2186                   Cond : constant Node_Id := First (Expressions (P));
2187                   Texp : constant Node_Id := Next (Cond);
2188                   Fexp : constant Node_Id := Next (Texp);
2189
2190                begin
2191                   if Compile_Time_Known_Value (Cond) then
2192
2193                      --  Condition is True and we are in the right operand
2194
2195                      if Is_True (Expr_Value (Cond))
2196                        and then OldP = Fexp
2197                      then
2198                         Msgs := False;
2199                         exit;
2200
2201                      --  Condition is False and we are in the left operand
2202
2203                      elsif Is_False (Expr_Value (Cond))
2204                        and then OldP = Texp
2205                      then
2206                         Msgs := False;
2207                         exit;
2208                      end if;
2209                   end if;
2210                end;
2211
2212             --  Special case for component association in aggregates, where
2213             --  we want to keep climbing up to the parent aggregate.
2214
2215             elsif Nkind (P) = N_Component_Association
2216               and then Nkind (Parent (P)) = N_Aggregate
2217             then
2218                null;
2219
2220             --  Keep going if within subexpression
2221
2222             else
2223                exit when Nkind (P) not in N_Subexpr;
2224             end if;
2225          end loop;
2226
2227          if Msgs then
2228             if Present (Ent) then
2229                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
2230             else
2231                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
2232             end if;
2233
2234             if Wmsg then
2235                if Inside_Init_Proc then
2236                   Error_Msg_NEL
2237                     ("\?& will be raised for objects of this type",
2238                      N, Standard_Constraint_Error, Eloc);
2239                else
2240                   Error_Msg_NEL
2241                     ("\?& will be raised at run time",
2242                      N, Standard_Constraint_Error, Eloc);
2243                end if;
2244
2245             else
2246                Error_Msg
2247                  ("\static expression fails Constraint_Check", Eloc);
2248                Set_Error_Posted (N);
2249             end if;
2250          end if;
2251       end if;
2252
2253       return N;
2254    end Compile_Time_Constraint_Error;
2255
2256    -----------------------
2257    -- Conditional_Delay --
2258    -----------------------
2259
2260    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
2261    begin
2262       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
2263          Set_Has_Delayed_Freeze (New_Ent);
2264       end if;
2265    end Conditional_Delay;
2266
2267    -------------------------
2268    -- Copy_Parameter_List --
2269    -------------------------
2270
2271    function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
2272       Loc    : constant Source_Ptr := Sloc (Subp_Id);
2273       Plist  : List_Id;
2274       Formal : Entity_Id;
2275
2276    begin
2277       if No (First_Formal (Subp_Id)) then
2278          return No_List;
2279       else
2280          Plist := New_List;
2281          Formal := First_Formal (Subp_Id);
2282          while Present (Formal) loop
2283             Append
2284               (Make_Parameter_Specification (Loc,
2285                 Defining_Identifier =>
2286                   Make_Defining_Identifier (Sloc (Formal),
2287                     Chars => Chars (Formal)),
2288                 In_Present  => In_Present (Parent (Formal)),
2289                 Out_Present => Out_Present (Parent (Formal)),
2290              Parameter_Type =>
2291                   New_Reference_To (Etype (Formal), Loc),
2292                 Expression =>
2293                   New_Copy_Tree (Expression (Parent (Formal)))),
2294               Plist);
2295
2296             Next_Formal (Formal);
2297          end loop;
2298       end if;
2299
2300       return Plist;
2301    end Copy_Parameter_List;
2302
2303    --------------------
2304    -- Current_Entity --
2305    --------------------
2306
2307    --  The currently visible definition for a given identifier is the
2308    --  one most chained at the start of the visibility chain, i.e. the
2309    --  one that is referenced by the Node_Id value of the name of the
2310    --  given identifier.
2311
2312    function Current_Entity (N : Node_Id) return Entity_Id is
2313    begin
2314       return Get_Name_Entity_Id (Chars (N));
2315    end Current_Entity;
2316
2317    -----------------------------
2318    -- Current_Entity_In_Scope --
2319    -----------------------------
2320
2321    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
2322       E  : Entity_Id;
2323       CS : constant Entity_Id := Current_Scope;
2324
2325       Transient_Case : constant Boolean := Scope_Is_Transient;
2326
2327    begin
2328       E := Get_Name_Entity_Id (Chars (N));
2329       while Present (E)
2330         and then Scope (E) /= CS
2331         and then (not Transient_Case or else Scope (E) /= Scope (CS))
2332       loop
2333          E := Homonym (E);
2334       end loop;
2335
2336       return E;
2337    end Current_Entity_In_Scope;
2338
2339    -------------------
2340    -- Current_Scope --
2341    -------------------
2342
2343    function Current_Scope return Entity_Id is
2344    begin
2345       if Scope_Stack.Last = -1 then
2346          return Standard_Standard;
2347       else
2348          declare
2349             C : constant Entity_Id :=
2350                   Scope_Stack.Table (Scope_Stack.Last).Entity;
2351          begin
2352             if Present (C) then
2353                return C;
2354             else
2355                return Standard_Standard;
2356             end if;
2357          end;
2358       end if;
2359    end Current_Scope;
2360
2361    ------------------------
2362    -- Current_Subprogram --
2363    ------------------------
2364
2365    function Current_Subprogram return Entity_Id is
2366       Scop : constant Entity_Id := Current_Scope;
2367    begin
2368       if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
2369          return Scop;
2370       else
2371          return Enclosing_Subprogram (Scop);
2372       end if;
2373    end Current_Subprogram;
2374
2375    ----------------------------------
2376    -- Deepest_Type_Access_Level --
2377    ----------------------------------
2378
2379    function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
2380    begin
2381       if Ekind (Typ) = E_Anonymous_Access_Type
2382         and then not Is_Local_Anonymous_Access (Typ)
2383         and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
2384       then
2385          --  Typ is the type of an Ada 2012 stand-alone object of an anonymous
2386          --  access type.
2387
2388          return
2389            Scope_Depth (Enclosing_Dynamic_Scope
2390                          (Defining_Identifier
2391                            (Associated_Node_For_Itype (Typ))));
2392
2393       else
2394          return Type_Access_Level (Typ);
2395       end if;
2396    end Deepest_Type_Access_Level;
2397
2398    ---------------------
2399    -- Defining_Entity --
2400    ---------------------
2401
2402    function Defining_Entity (N : Node_Id) return Entity_Id is
2403       K   : constant Node_Kind := Nkind (N);
2404       Err : Entity_Id := Empty;
2405
2406    begin
2407       case K is
2408          when
2409            N_Subprogram_Declaration                 |
2410            N_Abstract_Subprogram_Declaration        |
2411            N_Subprogram_Body                        |
2412            N_Package_Declaration                    |
2413            N_Subprogram_Renaming_Declaration        |
2414            N_Subprogram_Body_Stub                   |
2415            N_Generic_Subprogram_Declaration         |
2416            N_Generic_Package_Declaration            |
2417            N_Formal_Subprogram_Declaration
2418          =>
2419             return Defining_Entity (Specification (N));
2420
2421          when
2422            N_Component_Declaration                  |
2423            N_Defining_Program_Unit_Name             |
2424            N_Discriminant_Specification             |
2425            N_Entry_Body                             |
2426            N_Entry_Declaration                      |
2427            N_Entry_Index_Specification              |
2428            N_Exception_Declaration                  |
2429            N_Exception_Renaming_Declaration         |
2430            N_Formal_Object_Declaration              |
2431            N_Formal_Package_Declaration             |
2432            N_Formal_Type_Declaration                |
2433            N_Full_Type_Declaration                  |
2434            N_Implicit_Label_Declaration             |
2435            N_Incomplete_Type_Declaration            |
2436            N_Loop_Parameter_Specification           |
2437            N_Number_Declaration                     |
2438            N_Object_Declaration                     |
2439            N_Object_Renaming_Declaration            |
2440            N_Package_Body_Stub                      |
2441            N_Parameter_Specification                |
2442            N_Private_Extension_Declaration          |
2443            N_Private_Type_Declaration               |
2444            N_Protected_Body                         |
2445            N_Protected_Body_Stub                    |
2446            N_Protected_Type_Declaration             |
2447            N_Single_Protected_Declaration           |
2448            N_Single_Task_Declaration                |
2449            N_Subtype_Declaration                    |
2450            N_Task_Body                              |
2451            N_Task_Body_Stub                         |
2452            N_Task_Type_Declaration
2453          =>
2454             return Defining_Identifier (N);
2455
2456          when N_Subunit =>
2457             return Defining_Entity (Proper_Body (N));
2458
2459          when
2460            N_Function_Instantiation                 |
2461            N_Function_Specification                 |
2462            N_Generic_Function_Renaming_Declaration  |
2463            N_Generic_Package_Renaming_Declaration   |
2464            N_Generic_Procedure_Renaming_Declaration |
2465            N_Package_Body                           |
2466            N_Package_Instantiation                  |
2467            N_Package_Renaming_Declaration           |
2468            N_Package_Specification                  |
2469            N_Procedure_Instantiation                |
2470            N_Procedure_Specification
2471          =>
2472             declare
2473                Nam : constant Node_Id := Defining_Unit_Name (N);
2474
2475             begin
2476                if Nkind (Nam) in N_Entity then
2477                   return Nam;
2478
2479                --  For Error, make up a name and attach to declaration
2480                --  so we can continue semantic analysis
2481
2482                elsif Nam = Error then
2483                   Err := Make_Temporary (Sloc (N), 'T');
2484                   Set_Defining_Unit_Name (N, Err);
2485
2486                   return Err;
2487                --  If not an entity, get defining identifier
2488
2489                else
2490                   return Defining_Identifier (Nam);
2491                end if;
2492             end;
2493
2494          when N_Block_Statement =>
2495             return Entity (Identifier (N));
2496
2497          when others =>
2498             raise Program_Error;
2499
2500       end case;
2501    end Defining_Entity;
2502
2503    --------------------------
2504    -- Denotes_Discriminant --
2505    --------------------------
2506
2507    function Denotes_Discriminant
2508      (N                : Node_Id;
2509       Check_Concurrent : Boolean := False) return Boolean
2510    is
2511       E : Entity_Id;
2512    begin
2513       if not Is_Entity_Name (N)
2514         or else No (Entity (N))
2515       then
2516          return False;
2517       else
2518          E := Entity (N);
2519       end if;
2520
2521       --  If we are checking for a protected type, the discriminant may have
2522       --  been rewritten as the corresponding discriminal of the original type
2523       --  or of the corresponding concurrent record, depending on whether we
2524       --  are in the spec or body of the protected type.
2525
2526       return Ekind (E) = E_Discriminant
2527         or else
2528           (Check_Concurrent
2529             and then Ekind (E) = E_In_Parameter
2530             and then Present (Discriminal_Link (E))
2531             and then
2532               (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
2533                 or else
2534                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
2535
2536    end Denotes_Discriminant;
2537
2538    -------------------------
2539    -- Denotes_Same_Object --
2540    -------------------------
2541
2542    function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
2543       Obj1 : Node_Id := A1;
2544       Obj2 : Node_Id := A2;
2545
2546       procedure Check_Renaming (Obj : in out Node_Id);
2547       --  If an object is a renaming, examine renamed object. If it is a
2548       --  dereference of a variable, or an indexed expression with non-constant
2549       --  indexes, no overlap check can be reported.
2550
2551       --------------------
2552       -- Check_Renaming --
2553       --------------------
2554
2555       procedure Check_Renaming (Obj : in out Node_Id) is
2556       begin
2557          if Is_Entity_Name (Obj)
2558            and then Present (Renamed_Entity (Entity (Obj)))
2559          then
2560             Obj := Renamed_Entity (Entity (Obj));
2561             if Nkind (Obj) = N_Explicit_Dereference
2562               and then Is_Variable (Prefix (Obj))
2563             then
2564                Obj := Empty;
2565
2566             elsif Nkind (Obj) = N_Indexed_Component then
2567                declare
2568                   Indx : Node_Id;
2569
2570                begin
2571                   Indx := First (Expressions (Obj));
2572                   while Present (Indx) loop
2573                      if not Is_OK_Static_Expression (Indx) then
2574                         Obj := Empty;
2575                         exit;
2576                      end if;
2577
2578                      Next_Index (Indx);
2579                   end loop;
2580                end;
2581             end if;
2582          end if;
2583       end Check_Renaming;
2584
2585    --  Start of processing for Denotes_Same_Object
2586
2587    begin
2588       Check_Renaming (Obj1);
2589       Check_Renaming (Obj2);
2590
2591       if No (Obj1)
2592         or else No (Obj2)
2593       then
2594          return False;
2595       end if;
2596
2597       --  If we have entity names, then must be same entity
2598
2599       if Is_Entity_Name (Obj1) then
2600          if Is_Entity_Name (Obj2) then
2601             return Entity (Obj1) = Entity (Obj2);
2602          else
2603             return False;
2604          end if;
2605
2606       --  No match if not same node kind
2607
2608       elsif Nkind (Obj1) /= Nkind (Obj2) then
2609          return False;
2610
2611       --  For selected components, must have same prefix and selector
2612
2613       elsif Nkind (Obj1) = N_Selected_Component then
2614          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
2615            and then
2616          Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
2617
2618       --  For explicit dereferences, prefixes must be same
2619
2620       elsif Nkind (Obj1) = N_Explicit_Dereference then
2621          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
2622
2623       --  For indexed components, prefixes and all subscripts must be the same
2624
2625       elsif Nkind (Obj1) = N_Indexed_Component then
2626          if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
2627             declare
2628                Indx1 : Node_Id;
2629                Indx2 : Node_Id;
2630
2631             begin
2632                Indx1 := First (Expressions (Obj1));
2633                Indx2 := First (Expressions (Obj2));
2634                while Present (Indx1) loop
2635
2636                   --  Indexes must denote the same static value or same object
2637
2638                   if Is_OK_Static_Expression (Indx1) then
2639                      if not Is_OK_Static_Expression (Indx2) then
2640                         return False;
2641
2642                      elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
2643                         return False;
2644                      end if;
2645
2646                   elsif not Denotes_Same_Object (Indx1, Indx2) then
2647                      return False;
2648                   end if;
2649
2650                   Next (Indx1);
2651                   Next (Indx2);
2652                end loop;
2653
2654                return True;
2655             end;
2656          else
2657             return False;
2658          end if;
2659
2660       --  For slices, prefixes must match and bounds must match
2661
2662       elsif Nkind (Obj1) = N_Slice
2663         and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
2664       then
2665          declare
2666             Lo1, Lo2, Hi1, Hi2 : Node_Id;
2667
2668          begin
2669             Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
2670             Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
2671
2672             --  Check whether bounds are statically identical. There is no
2673             --  attempt to detect partial overlap of slices.
2674
2675             return Denotes_Same_Object (Lo1, Lo2)
2676               and then Denotes_Same_Object (Hi1, Hi2);
2677          end;
2678
2679          --  Literals will appear as indexes. Isn't this where we should check
2680          --  Known_At_Compile_Time at least if we are generating warnings ???
2681
2682       elsif Nkind (Obj1) = N_Integer_Literal then
2683          return Intval (Obj1) = Intval (Obj2);
2684
2685       else
2686          return False;
2687       end if;
2688    end Denotes_Same_Object;
2689
2690    -------------------------
2691    -- Denotes_Same_Prefix --
2692    -------------------------
2693
2694    function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
2695
2696    begin
2697       if Is_Entity_Name (A1) then
2698          if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
2699            and then not Is_Access_Type (Etype (A1))
2700          then
2701             return Denotes_Same_Object (A1, Prefix (A2))
2702               or else Denotes_Same_Prefix (A1, Prefix (A2));
2703          else
2704             return False;
2705          end if;
2706
2707       elsif Is_Entity_Name (A2) then
2708          return Denotes_Same_Prefix (A2, A1);
2709
2710       elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
2711               and then
2712             Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
2713       then
2714          declare
2715             Root1, Root2 : Node_Id;
2716             Depth1, Depth2 : Int := 0;
2717
2718          begin
2719             Root1 := Prefix (A1);
2720             while not Is_Entity_Name (Root1) loop
2721                if not Nkind_In
2722                  (Root1, N_Selected_Component, N_Indexed_Component)
2723                then
2724                   return False;
2725                else
2726                   Root1 := Prefix (Root1);
2727                end if;
2728
2729                Depth1 := Depth1 + 1;
2730             end loop;
2731
2732             Root2 := Prefix (A2);
2733             while not Is_Entity_Name (Root2) loop
2734                if not Nkind_In
2735                  (Root2, N_Selected_Component, N_Indexed_Component)
2736                then
2737                   return False;
2738                else
2739                   Root2 := Prefix (Root2);
2740                end if;
2741
2742                Depth2 := Depth2 + 1;
2743             end loop;
2744
2745             --  If both have the same depth and they do not denote the same
2746             --  object, they are disjoint and not warning is needed.
2747
2748             if Depth1 = Depth2 then
2749                return False;
2750
2751             elsif Depth1 > Depth2 then
2752                Root1 := Prefix (A1);
2753                for I in 1 .. Depth1 - Depth2 - 1 loop
2754                   Root1 := Prefix (Root1);
2755                end loop;
2756
2757                return Denotes_Same_Object (Root1, A2);
2758
2759             else
2760                Root2 := Prefix (A2);
2761                for I in 1 .. Depth2 - Depth1 - 1 loop
2762                   Root2 := Prefix (Root2);
2763                end loop;
2764
2765                return Denotes_Same_Object (A1, Root2);
2766             end if;
2767          end;
2768
2769       else
2770          return False;
2771       end if;
2772    end Denotes_Same_Prefix;
2773
2774    ----------------------
2775    -- Denotes_Variable --
2776    ----------------------
2777
2778    function Denotes_Variable (N : Node_Id) return Boolean is
2779    begin
2780       return Is_Variable (N) and then Paren_Count (N) = 0;
2781    end Denotes_Variable;
2782
2783    -----------------------------
2784    -- Depends_On_Discriminant --
2785    -----------------------------
2786
2787    function Depends_On_Discriminant (N : Node_Id) return Boolean is
2788       L : Node_Id;
2789       H : Node_Id;
2790
2791    begin
2792       Get_Index_Bounds (N, L, H);
2793       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
2794    end Depends_On_Discriminant;
2795
2796    -------------------------
2797    -- Designate_Same_Unit --
2798    -------------------------
2799
2800    function Designate_Same_Unit
2801      (Name1 : Node_Id;
2802       Name2 : Node_Id) return Boolean
2803    is
2804       K1 : constant Node_Kind := Nkind (Name1);
2805       K2 : constant Node_Kind := Nkind (Name2);
2806
2807       function Prefix_Node (N : Node_Id) return Node_Id;
2808       --  Returns the parent unit name node of a defining program unit name
2809       --  or the prefix if N is a selected component or an expanded name.
2810
2811       function Select_Node (N : Node_Id) return Node_Id;
2812       --  Returns the defining identifier node of a defining program unit
2813       --  name or  the selector node if N is a selected component or an
2814       --  expanded name.
2815
2816       -----------------
2817       -- Prefix_Node --
2818       -----------------
2819
2820       function Prefix_Node (N : Node_Id) return Node_Id is
2821       begin
2822          if Nkind (N) = N_Defining_Program_Unit_Name then
2823             return Name (N);
2824
2825          else
2826             return Prefix (N);
2827          end if;
2828       end Prefix_Node;
2829
2830       -----------------
2831       -- Select_Node --
2832       -----------------
2833
2834       function Select_Node (N : Node_Id) return Node_Id is
2835       begin
2836          if Nkind (N) = N_Defining_Program_Unit_Name then
2837             return Defining_Identifier (N);
2838
2839          else
2840             return Selector_Name (N);
2841          end if;
2842       end Select_Node;
2843
2844    --  Start of processing for Designate_Next_Unit
2845
2846    begin
2847       if (K1 = N_Identifier or else
2848           K1 = N_Defining_Identifier)
2849         and then
2850          (K2 = N_Identifier or else
2851           K2 = N_Defining_Identifier)
2852       then
2853          return Chars (Name1) = Chars (Name2);
2854
2855       elsif
2856          (K1 = N_Expanded_Name      or else
2857           K1 = N_Selected_Component or else
2858           K1 = N_Defining_Program_Unit_Name)
2859         and then
2860          (K2 = N_Expanded_Name      or else
2861           K2 = N_Selected_Component or else
2862           K2 = N_Defining_Program_Unit_Name)
2863       then
2864          return
2865            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
2866              and then
2867                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
2868
2869       else
2870          return False;
2871       end if;
2872    end Designate_Same_Unit;
2873
2874    ------------------------------------------
2875    -- function Dynamic_Accessibility_Level --
2876    ------------------------------------------
2877
2878    function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
2879       E : Entity_Id;
2880       Loc : constant Source_Ptr := Sloc (Expr);
2881
2882       function Make_Level_Literal (Level : Uint) return Node_Id;
2883       --  Construct an integer literal representing an accessibility level
2884       --  with its type set to Natural.
2885
2886       ------------------------
2887       -- Make_Level_Literal --
2888       ------------------------
2889
2890       function Make_Level_Literal (Level : Uint) return Node_Id is
2891          Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
2892       begin
2893          Set_Etype (Result, Standard_Natural);
2894          return Result;
2895       end Make_Level_Literal;
2896
2897    --  Start of processing for Dynamic_Accessibility_Level
2898
2899    begin
2900       if Is_Entity_Name (Expr) then
2901          E := Entity (Expr);
2902
2903          if Present (Renamed_Object (E)) then
2904             return Dynamic_Accessibility_Level (Renamed_Object (E));
2905          end if;
2906
2907          if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
2908             if Present (Extra_Accessibility (E)) then
2909                return New_Occurrence_Of (Extra_Accessibility (E), Loc);
2910             end if;
2911          end if;
2912       end if;
2913
2914       --  Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
2915
2916       case Nkind (Expr) is
2917
2918          --  For access discriminant, the level of the enclosing object
2919
2920          when N_Selected_Component =>
2921             if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
2922               and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
2923                                             E_Anonymous_Access_Type
2924             then
2925                return Make_Level_Literal (Object_Access_Level (Expr));
2926             end if;
2927
2928          when N_Attribute_Reference =>
2929             case Get_Attribute_Id (Attribute_Name (Expr)) is
2930
2931                --  For X'Access, the level of the prefix X
2932
2933                when Attribute_Access =>
2934                   return Make_Level_Literal
2935                            (Object_Access_Level (Prefix (Expr)));
2936
2937                --  Treat the unchecked attributes as library-level
2938
2939                when Attribute_Unchecked_Access    |
2940                     Attribute_Unrestricted_Access =>
2941                   return Make_Level_Literal (Scope_Depth (Standard_Standard));
2942
2943                --  No other access-valued attributes
2944
2945                when others =>
2946                   raise Program_Error;
2947             end case;
2948
2949          when N_Allocator =>
2950
2951             --  Unimplemented: depends on context. As an actual parameter where
2952             --  formal type is anonymous, use
2953             --    Scope_Depth (Current_Scope) + 1.
2954             --  For other cases, see 3.10.2(14/3) and following. ???
2955
2956             null;
2957
2958          when N_Type_Conversion =>
2959             if not Is_Local_Anonymous_Access (Etype (Expr)) then
2960
2961                --  Handle type conversions introduced for a rename of an
2962                --  Ada2012 stand-alone object of an anonymous access type.
2963
2964                return Dynamic_Accessibility_Level (Expression (Expr));
2965             end if;
2966
2967          when others =>
2968             null;
2969       end case;
2970
2971       return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
2972    end Dynamic_Accessibility_Level;
2973
2974    -----------------------------------
2975    -- Effective_Extra_Accessibility --
2976    -----------------------------------
2977
2978    function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
2979    begin
2980       if Present (Renamed_Object (Id))
2981         and then Is_Entity_Name (Renamed_Object (Id)) then
2982          return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
2983       end if;
2984
2985       return Extra_Accessibility (Id);
2986    end Effective_Extra_Accessibility;
2987
2988    --------------------------
2989    -- Enclosing_CPP_Parent --
2990    --------------------------
2991
2992    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
2993       Parent_Typ : Entity_Id := Typ;
2994
2995    begin
2996       while not Is_CPP_Class (Parent_Typ)
2997          and then Etype (Parent_Typ) /= Parent_Typ
2998       loop
2999          Parent_Typ := Etype (Parent_Typ);
3000
3001          if Is_Private_Type (Parent_Typ) then
3002             Parent_Typ := Full_View (Base_Type (Parent_Typ));
3003          end if;
3004       end loop;
3005
3006       pragma Assert (Is_CPP_Class (Parent_Typ));
3007       return Parent_Typ;
3008    end Enclosing_CPP_Parent;
3009
3010    ----------------------------
3011    -- Enclosing_Generic_Body --
3012    ----------------------------
3013
3014    function Enclosing_Generic_Body
3015      (N : Node_Id) return Node_Id
3016    is
3017       P    : Node_Id;
3018       Decl : Node_Id;
3019       Spec : Node_Id;
3020
3021    begin
3022       P := Parent (N);
3023       while Present (P) loop
3024          if Nkind (P) = N_Package_Body
3025            or else Nkind (P) = N_Subprogram_Body
3026          then
3027             Spec := Corresponding_Spec (P);
3028
3029             if Present (Spec) then
3030                Decl := Unit_Declaration_Node (Spec);
3031
3032                if Nkind (Decl) = N_Generic_Package_Declaration
3033                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
3034                then
3035                   return P;
3036                end if;
3037             end if;
3038          end if;
3039
3040          P := Parent (P);
3041       end loop;
3042
3043       return Empty;
3044    end Enclosing_Generic_Body;
3045
3046    ----------------------------
3047    -- Enclosing_Generic_Unit --
3048    ----------------------------
3049
3050    function Enclosing_Generic_Unit
3051      (N : Node_Id) return Node_Id
3052    is
3053       P    : Node_Id;
3054       Decl : Node_Id;
3055       Spec : Node_Id;
3056
3057    begin
3058       P := Parent (N);
3059       while Present (P) loop
3060          if Nkind (P) = N_Generic_Package_Declaration
3061            or else Nkind (P) = N_Generic_Subprogram_Declaration
3062          then
3063             return P;
3064
3065          elsif Nkind (P) = N_Package_Body
3066            or else Nkind (P) = N_Subprogram_Body
3067          then
3068             Spec := Corresponding_Spec (P);
3069
3070             if Present (Spec) then
3071                Decl := Unit_Declaration_Node (Spec);
3072
3073                if Nkind (Decl) = N_Generic_Package_Declaration
3074                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
3075                then
3076                   return Decl;
3077                end if;
3078             end if;
3079          end if;
3080
3081          P := Parent (P);
3082       end loop;
3083
3084       return Empty;
3085    end Enclosing_Generic_Unit;
3086
3087    -------------------------------
3088    -- Enclosing_Lib_Unit_Entity --
3089    -------------------------------
3090
3091    function Enclosing_Lib_Unit_Entity return Entity_Id is
3092       Unit_Entity : Entity_Id;
3093
3094    begin
3095       --  Look for enclosing library unit entity by following scope links.
3096       --  Equivalent to, but faster than indexing through the scope stack.
3097
3098       Unit_Entity := Current_Scope;
3099       while (Present (Scope (Unit_Entity))
3100         and then Scope (Unit_Entity) /= Standard_Standard)
3101         and not Is_Child_Unit (Unit_Entity)
3102       loop
3103          Unit_Entity := Scope (Unit_Entity);
3104       end loop;
3105
3106       return Unit_Entity;
3107    end Enclosing_Lib_Unit_Entity;
3108
3109    -----------------------------
3110    -- Enclosing_Lib_Unit_Node --
3111    -----------------------------
3112
3113    function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
3114       Current_Node : Node_Id;
3115
3116    begin
3117       Current_Node := N;
3118       while Present (Current_Node)
3119         and then Nkind (Current_Node) /= N_Compilation_Unit
3120       loop
3121          Current_Node := Parent (Current_Node);
3122       end loop;
3123
3124       if Nkind (Current_Node) /= N_Compilation_Unit then
3125          return Empty;
3126       end if;
3127
3128       return Current_Node;
3129    end Enclosing_Lib_Unit_Node;
3130
3131    -----------------------
3132    -- Enclosing_Package --
3133    -----------------------
3134
3135    function Enclosing_Package (E : Entity_Id) return Entity_Id is
3136       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
3137
3138    begin
3139       if Dynamic_Scope = Standard_Standard then
3140          return Standard_Standard;
3141
3142       elsif Dynamic_Scope = Empty then
3143          return Empty;
3144
3145       elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
3146                       E_Generic_Package)
3147       then
3148          return Dynamic_Scope;
3149
3150       else
3151          return Enclosing_Package (Dynamic_Scope);
3152       end if;
3153    end Enclosing_Package;
3154
3155    --------------------------
3156    -- Enclosing_Subprogram --
3157    --------------------------
3158
3159    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
3160       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
3161
3162    begin
3163       if Dynamic_Scope = Standard_Standard then
3164          return Empty;
3165
3166       elsif Dynamic_Scope = Empty then
3167          return Empty;
3168
3169       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
3170          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
3171
3172       elsif Ekind (Dynamic_Scope) = E_Block
3173         or else Ekind (Dynamic_Scope) = E_Return_Statement
3174       then
3175          return Enclosing_Subprogram (Dynamic_Scope);
3176
3177       elsif Ekind (Dynamic_Scope) = E_Task_Type then
3178          return Get_Task_Body_Procedure (Dynamic_Scope);
3179
3180       elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
3181         and then Present (Full_View (Dynamic_Scope))
3182         and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
3183       then
3184          return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
3185
3186       --  No body is generated if the protected operation is eliminated
3187
3188       elsif Convention (Dynamic_Scope) = Convention_Protected
3189         and then not Is_Eliminated (Dynamic_Scope)
3190         and then Present (Protected_Body_Subprogram (Dynamic_Scope))
3191       then
3192          return Protected_Body_Subprogram (Dynamic_Scope);
3193
3194       else
3195          return Dynamic_Scope;
3196       end if;
3197    end Enclosing_Subprogram;
3198
3199    ------------------------
3200    -- Ensure_Freeze_Node --
3201    ------------------------
3202
3203    procedure Ensure_Freeze_Node (E : Entity_Id) is
3204       FN : Node_Id;
3205
3206    begin
3207       if No (Freeze_Node (E)) then
3208          FN := Make_Freeze_Entity (Sloc (E));
3209          Set_Has_Delayed_Freeze (E);
3210          Set_Freeze_Node (E, FN);
3211          Set_Access_Types_To_Process (FN, No_Elist);
3212          Set_TSS_Elist (FN, No_Elist);
3213          Set_Entity (FN, E);
3214       end if;
3215    end Ensure_Freeze_Node;
3216
3217    ----------------
3218    -- Enter_Name --
3219    ----------------
3220
3221    procedure Enter_Name (Def_Id : Entity_Id) is
3222       C : constant Entity_Id := Current_Entity (Def_Id);
3223       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
3224       S : constant Entity_Id := Current_Scope;
3225
3226    begin
3227       Generate_Definition (Def_Id);
3228
3229       --  Add new name to current scope declarations. Check for duplicate
3230       --  declaration, which may or may not be a genuine error.
3231
3232       if Present (E) then
3233
3234          --  Case of previous entity entered because of a missing declaration
3235          --  or else a bad subtype indication. Best is to use the new entity,
3236          --  and make the previous one invisible.
3237
3238          if Etype (E) = Any_Type then
3239             Set_Is_Immediately_Visible (E, False);
3240
3241          --  Case of renaming declaration constructed for package instances.
3242          --  if there is an explicit declaration with the same identifier,
3243          --  the renaming is not immediately visible any longer, but remains
3244          --  visible through selected component notation.
3245
3246          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
3247            and then not Comes_From_Source (E)
3248          then
3249             Set_Is_Immediately_Visible (E, False);
3250
3251          --  The new entity may be the package renaming, which has the same
3252          --  same name as a generic formal which has been seen already.
3253
3254          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
3255             and then not Comes_From_Source (Def_Id)
3256          then
3257             Set_Is_Immediately_Visible (E, False);
3258
3259          --  For a fat pointer corresponding to a remote access to subprogram,
3260          --  we use the same identifier as the RAS type, so that the proper
3261          --  name appears in the stub. This type is only retrieved through
3262          --  the RAS type and never by visibility, and is not added to the
3263          --  visibility list (see below).
3264
3265          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
3266            and then Present (Corresponding_Remote_Type (Def_Id))
3267          then
3268             null;
3269
3270          --  Case of an implicit operation or derived literal. The new entity
3271          --  hides the implicit one,  which is removed from all visibility,
3272          --  i.e. the entity list of its scope, and homonym chain of its name.
3273
3274          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
3275            or else Is_Internal (E)
3276          then
3277             declare
3278                Prev     : Entity_Id;
3279                Prev_Vis : Entity_Id;
3280                Decl     : constant Node_Id := Parent (E);
3281
3282             begin
3283                --  If E is an implicit declaration, it cannot be the first
3284                --  entity in the scope.
3285
3286                Prev := First_Entity (Current_Scope);
3287                while Present (Prev)
3288                  and then Next_Entity (Prev) /= E
3289                loop
3290                   Next_Entity (Prev);
3291                end loop;
3292
3293                if No (Prev) then
3294
3295                   --  If E is not on the entity chain of the current scope,
3296                   --  it is an implicit declaration in the generic formal
3297                   --  part of a generic subprogram. When analyzing the body,
3298                   --  the generic formals are visible but not on the entity
3299                   --  chain of the subprogram. The new entity will become
3300                   --  the visible one in the body.
3301
3302                   pragma Assert
3303                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
3304                   null;
3305
3306                else
3307                   Set_Next_Entity (Prev, Next_Entity (E));
3308
3309                   if No (Next_Entity (Prev)) then
3310                      Set_Last_Entity (Current_Scope, Prev);
3311                   end if;
3312
3313                   if E = Current_Entity (E) then
3314                      Prev_Vis := Empty;
3315
3316                   else
3317                      Prev_Vis := Current_Entity (E);
3318                      while Homonym (Prev_Vis) /= E loop
3319                         Prev_Vis := Homonym (Prev_Vis);
3320                      end loop;
3321                   end if;
3322
3323                   if Present (Prev_Vis)  then
3324
3325                      --  Skip E in the visibility chain
3326
3327                      Set_Homonym (Prev_Vis, Homonym (E));
3328
3329                   else
3330                      Set_Name_Entity_Id (Chars (E), Homonym (E));
3331                   end if;
3332                end if;
3333             end;
3334
3335          --  This section of code could use a comment ???
3336
3337          elsif Present (Etype (E))
3338            and then Is_Concurrent_Type (Etype (E))
3339            and then E = Def_Id
3340          then
3341             return;
3342
3343          --  If the homograph is a protected component renaming, it should not
3344          --  be hiding the current entity. Such renamings are treated as weak
3345          --  declarations.
3346
3347          elsif Is_Prival (E) then
3348             Set_Is_Immediately_Visible (E, False);
3349
3350          --  In this case the current entity is a protected component renaming.
3351          --  Perform minimal decoration by setting the scope and return since
3352          --  the prival should not be hiding other visible entities.
3353
3354          elsif Is_Prival (Def_Id) then
3355             Set_Scope (Def_Id, Current_Scope);
3356             return;
3357
3358          --  Analogous to privals, the discriminal generated for an entry index
3359          --  parameter acts as a weak declaration. Perform minimal decoration
3360          --  to avoid bogus errors.
3361
3362          elsif Is_Discriminal (Def_Id)
3363            and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
3364          then
3365             Set_Scope (Def_Id, Current_Scope);
3366             return;
3367
3368          --  In the body or private part of an instance, a type extension may
3369          --  introduce a component with the same name as that of an actual. The
3370          --  legality rule is not enforced, but the semantics of the full type
3371          --  with two components of same name are not clear at this point???
3372
3373          elsif In_Instance_Not_Visible then
3374             null;
3375
3376          --  When compiling a package body, some child units may have become
3377          --  visible. They cannot conflict with local entities that hide them.
3378
3379          elsif Is_Child_Unit (E)
3380            and then In_Open_Scopes (Scope (E))
3381            and then not Is_Immediately_Visible (E)
3382          then
3383             null;
3384
3385          --  Conversely, with front-end inlining we may compile the parent body
3386          --  first, and a child unit subsequently. The context is now the
3387          --  parent spec, and body entities are not visible.
3388
3389          elsif Is_Child_Unit (Def_Id)
3390            and then Is_Package_Body_Entity (E)
3391            and then not In_Package_Body (Current_Scope)
3392          then
3393             null;
3394
3395          --  Case of genuine duplicate declaration
3396
3397          else
3398             Error_Msg_Sloc := Sloc (E);
3399
3400             --  If the previous declaration is an incomplete type declaration
3401             --  this may be an attempt to complete it with a private type. The
3402             --  following avoids confusing cascaded errors.
3403
3404             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
3405               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
3406             then
3407                Error_Msg_N
3408                  ("incomplete type cannot be completed with a private " &
3409                   "declaration", Parent (Def_Id));
3410                Set_Is_Immediately_Visible (E, False);
3411                Set_Full_View (E, Def_Id);
3412
3413             --  An inherited component of a record conflicts with a new
3414             --  discriminant. The discriminant is inserted first in the scope,
3415             --  but the error should be posted on it, not on the component.
3416
3417             elsif Ekind (E) = E_Discriminant
3418               and then Present (Scope (Def_Id))
3419               and then Scope (Def_Id) /= Current_Scope
3420             then
3421                Error_Msg_Sloc := Sloc (Def_Id);
3422                Error_Msg_N ("& conflicts with declaration#", E);
3423                return;
3424
3425             --  If the name of the unit appears in its own context clause, a
3426             --  dummy package with the name has already been created, and the
3427             --  error emitted. Try to continue quietly.
3428
3429             elsif Error_Posted (E)
3430               and then Sloc (E) = No_Location
3431               and then Nkind (Parent (E)) = N_Package_Specification
3432               and then Current_Scope = Standard_Standard
3433             then
3434                Set_Scope (Def_Id, Current_Scope);
3435                return;
3436
3437             else
3438                Error_Msg_N ("& conflicts with declaration#", Def_Id);
3439
3440                --  Avoid cascaded messages with duplicate components in
3441                --  derived types.
3442
3443                if Ekind_In (E, E_Component, E_Discriminant) then
3444                   return;
3445                end if;
3446             end if;
3447
3448             if Nkind (Parent (Parent (Def_Id))) =
3449                 N_Generic_Subprogram_Declaration
3450               and then Def_Id =
3451                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
3452             then
3453                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
3454             end if;
3455
3456             --  If entity is in standard, then we are in trouble, because it
3457             --  means that we have a library package with a duplicated name.
3458             --  That's hard to recover from, so abort!
3459
3460             if S = Standard_Standard then
3461                raise Unrecoverable_Error;
3462
3463             --  Otherwise we continue with the declaration. Having two
3464             --  identical declarations should not cause us too much trouble!
3465
3466             else
3467                null;
3468             end if;
3469          end if;
3470       end if;
3471
3472       --  If we fall through, declaration is OK, at least OK enough to continue
3473
3474       --  If Def_Id is a discriminant or a record component we are in the midst
3475       --  of inheriting components in a derived record definition. Preserve
3476       --  their Ekind and Etype.
3477
3478       if Ekind_In (Def_Id, E_Discriminant, E_Component) then
3479          null;
3480
3481       --  If a type is already set, leave it alone (happens when a type
3482       --  declaration is reanalyzed following a call to the optimizer).
3483
3484       elsif Present (Etype (Def_Id)) then
3485          null;
3486
3487       --  Otherwise, the kind E_Void insures that premature uses of the entity
3488       --  will be detected. Any_Type insures that no cascaded errors will occur
3489
3490       else
3491          Set_Ekind (Def_Id, E_Void);
3492          Set_Etype (Def_Id, Any_Type);
3493       end if;
3494
3495       --  Inherited discriminants and components in derived record types are
3496       --  immediately visible. Itypes are not.
3497
3498       if Ekind_In (Def_Id, E_Discriminant, E_Component)
3499         or else (No (Corresponding_Remote_Type (Def_Id))
3500                  and then not Is_Itype (Def_Id))
3501       then
3502          Set_Is_Immediately_Visible (Def_Id);
3503          Set_Current_Entity         (Def_Id);
3504       end if;
3505
3506       Set_Homonym       (Def_Id, C);
3507       Append_Entity     (Def_Id, S);
3508       Set_Public_Status (Def_Id);
3509
3510       --  Declaring a homonym is not allowed in SPARK ...
3511
3512       if Present (C)
3513         and then Restriction_Check_Required (SPARK)
3514       then
3515
3516          declare
3517             Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
3518             Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
3519             Other_Scope    : constant Node_Id := Enclosing_Dynamic_Scope (C);
3520          begin
3521
3522             --  ... unless the new declaration is in a subprogram, and the
3523             --  visible declaration is a variable declaration or a parameter
3524             --  specification outside that subprogram.
3525
3526             if Present (Enclosing_Subp)
3527               and then Nkind_In (Parent (C), N_Object_Declaration,
3528                                  N_Parameter_Specification)
3529               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
3530             then
3531                null;
3532
3533             --  ... or the new declaration is in a package, and the visible
3534             --  declaration occurs outside that package.
3535
3536             elsif Present (Enclosing_Pack)
3537               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
3538             then
3539                null;
3540
3541             --  ... or the new declaration is a component declaration in a
3542             --  record type definition.
3543
3544             elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
3545                null;
3546
3547             --  Don't issue error for non-source entities
3548
3549             elsif Comes_From_Source (Def_Id)
3550               and then Comes_From_Source (C)
3551             then
3552                Error_Msg_Sloc := Sloc (C);
3553                Check_SPARK_Restriction
3554                  ("redeclaration of identifier &#", Def_Id);
3555             end if;
3556          end;
3557       end if;
3558
3559       --  Warn if new entity hides an old one
3560
3561       if Warn_On_Hiding and then Present (C)
3562
3563          --  Don't warn for record components since they always have a well
3564          --  defined scope which does not confuse other uses. Note that in
3565          --  some cases, Ekind has not been set yet.
3566
3567          and then Ekind (C) /= E_Component
3568          and then Ekind (C) /= E_Discriminant
3569          and then Nkind (Parent (C)) /= N_Component_Declaration
3570          and then Ekind (Def_Id) /= E_Component
3571          and then Ekind (Def_Id) /= E_Discriminant
3572          and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
3573
3574          --  Don't warn for one character variables. It is too common to use
3575          --  such variables as locals and will just cause too many false hits.
3576
3577          and then Length_Of_Name (Chars (C)) /= 1
3578
3579          --  Don't warn for non-source entities
3580
3581          and then Comes_From_Source (C)
3582          and then Comes_From_Source (Def_Id)
3583
3584          --  Don't warn unless entity in question is in extended main source
3585
3586          and then In_Extended_Main_Source_Unit (Def_Id)
3587
3588          --  Finally, the hidden entity must be either immediately visible or
3589          --  use visible (i.e. from a used package).
3590
3591          and then
3592            (Is_Immediately_Visible (C)
3593               or else
3594             Is_Potentially_Use_Visible (C))
3595       then
3596          Error_Msg_Sloc := Sloc (C);
3597          Error_Msg_N ("declaration hides &#?", Def_Id);
3598       end if;
3599    end Enter_Name;
3600
3601    --------------------------
3602    -- Explain_Limited_Type --
3603    --------------------------
3604
3605    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
3606       C : Entity_Id;
3607
3608    begin
3609       --  For array, component type must be limited
3610
3611       if Is_Array_Type (T) then
3612          Error_Msg_Node_2 := T;
3613          Error_Msg_NE
3614            ("\component type& of type& is limited", N, Component_Type (T));
3615          Explain_Limited_Type (Component_Type (T), N);
3616
3617       elsif Is_Record_Type (T) then
3618
3619          --  No need for extra messages if explicit limited record
3620
3621          if Is_Limited_Record (Base_Type (T)) then
3622             return;
3623          end if;
3624
3625          --  Otherwise find a limited component. Check only components that
3626          --  come from source, or inherited components that appear in the
3627          --  source of the ancestor.
3628
3629          C := First_Component (T);
3630          while Present (C) loop
3631             if Is_Limited_Type (Etype (C))
3632               and then
3633                 (Comes_From_Source (C)
3634                    or else
3635                      (Present (Original_Record_Component (C))
3636                        and then
3637                          Comes_From_Source (Original_Record_Component (C))))
3638             then
3639                Error_Msg_Node_2 := T;
3640                Error_Msg_NE ("\component& of type& has limited type", N, C);
3641                Explain_Limited_Type (Etype (C), N);
3642                return;
3643             end if;
3644
3645             Next_Component (C);
3646          end loop;
3647
3648          --  The type may be declared explicitly limited, even if no component
3649          --  of it is limited, in which case we fall out of the loop.
3650          return;
3651       end if;
3652    end Explain_Limited_Type;
3653
3654    -----------------
3655    -- Find_Actual --
3656    -----------------
3657
3658    procedure Find_Actual
3659      (N        : Node_Id;
3660       Formal   : out Entity_Id;
3661       Call     : out Node_Id)
3662    is
3663       Parnt  : constant Node_Id := Parent (N);
3664       Actual : Node_Id;
3665
3666    begin
3667       if (Nkind (Parnt) = N_Indexed_Component
3668             or else
3669           Nkind (Parnt) = N_Selected_Component)
3670         and then N = Prefix (Parnt)
3671       then
3672          Find_Actual (Parnt, Formal, Call);
3673          return;
3674
3675       elsif Nkind (Parnt) = N_Parameter_Association
3676         and then N = Explicit_Actual_Parameter (Parnt)
3677       then
3678          Call := Parent (Parnt);
3679
3680       elsif Nkind_In (Parnt, N_Procedure_Call_Statement, N_Function_Call) then
3681          Call := Parnt;
3682
3683       else
3684          Formal := Empty;
3685          Call   := Empty;
3686          return;
3687       end if;
3688
3689       --  If we have a call to a subprogram look for the parameter. Note that
3690       --  we exclude overloaded calls, since we don't know enough to be sure
3691       --  of giving the right answer in this case.
3692
3693       if Is_Entity_Name (Name (Call))
3694         and then Present (Entity (Name (Call)))
3695         and then Is_Overloadable (Entity (Name (Call)))
3696         and then not Is_Overloaded (Name (Call))
3697       then
3698          --  Fall here if we are definitely a parameter
3699
3700          Actual := First_Actual (Call);
3701          Formal := First_Formal (Entity (Name (Call)));
3702          while Present (Formal) and then Present (Actual) loop
3703             if Actual = N then
3704                return;
3705             else
3706                Actual := Next_Actual (Actual);
3707                Formal := Next_Formal (Formal);
3708             end if;
3709          end loop;
3710       end if;
3711
3712       --  Fall through here if we did not find matching actual
3713
3714       Formal := Empty;
3715       Call   := Empty;
3716    end Find_Actual;
3717
3718    ---------------------------
3719    -- Find_Body_Discriminal --
3720    ---------------------------
3721
3722    function Find_Body_Discriminal
3723      (Spec_Discriminant : Entity_Id) return Entity_Id
3724    is
3725       Tsk  : Entity_Id;
3726       Disc : Entity_Id;
3727
3728    begin
3729       --  If expansion is suppressed, then the scope can be the concurrent type
3730       --  itself rather than a corresponding concurrent record type.
3731
3732       if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
3733          Tsk := Scope (Spec_Discriminant);
3734
3735       else
3736          pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
3737
3738          Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
3739       end if;
3740
3741       --  Find discriminant of original concurrent type, and use its current
3742       --  discriminal, which is the renaming within the task/protected body.
3743
3744       Disc := First_Discriminant (Tsk);
3745       while Present (Disc) loop
3746          if Chars (Disc) = Chars (Spec_Discriminant) then
3747             return Discriminal (Disc);
3748          end if;
3749
3750          Next_Discriminant (Disc);
3751       end loop;
3752
3753       --  That loop should always succeed in finding a matching entry and
3754       --  returning. Fatal error if not.
3755
3756       raise Program_Error;
3757    end Find_Body_Discriminal;
3758
3759    -------------------------------------
3760    -- Find_Corresponding_Discriminant --
3761    -------------------------------------
3762
3763    function Find_Corresponding_Discriminant
3764      (Id  : Node_Id;
3765       Typ : Entity_Id) return Entity_Id
3766    is
3767       Par_Disc : Entity_Id;
3768       Old_Disc : Entity_Id;
3769       New_Disc : Entity_Id;
3770
3771    begin
3772       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
3773
3774       --  The original type may currently be private, and the discriminant
3775       --  only appear on its full view.
3776
3777       if Is_Private_Type (Scope (Par_Disc))
3778         and then not Has_Discriminants (Scope (Par_Disc))
3779         and then Present (Full_View (Scope (Par_Disc)))
3780       then
3781          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
3782       else
3783          Old_Disc := First_Discriminant (Scope (Par_Disc));
3784       end if;
3785
3786       if Is_Class_Wide_Type (Typ) then
3787          New_Disc := First_Discriminant (Root_Type (Typ));
3788       else
3789          New_Disc := First_Discriminant (Typ);
3790       end if;
3791
3792       while Present (Old_Disc) and then Present (New_Disc) loop
3793          if Old_Disc = Par_Disc  then
3794             return New_Disc;
3795          else
3796             Next_Discriminant (Old_Disc);
3797             Next_Discriminant (New_Disc);
3798          end if;
3799       end loop;
3800
3801       --  Should always find it
3802
3803       raise Program_Error;
3804    end Find_Corresponding_Discriminant;
3805
3806    --------------------------
3807    -- Find_Overlaid_Entity --
3808    --------------------------
3809
3810    procedure Find_Overlaid_Entity
3811      (N   : Node_Id;
3812       Ent : out Entity_Id;
3813       Off : out Boolean)
3814    is
3815       Expr : Node_Id;
3816
3817    begin
3818       --  We are looking for one of the two following forms:
3819
3820       --    for X'Address use Y'Address
3821
3822       --  or
3823
3824       --    Const : constant Address := expr;
3825       --    ...
3826       --    for X'Address use Const;
3827
3828       --  In the second case, the expr is either Y'Address, or recursively a
3829       --  constant that eventually references Y'Address.
3830
3831       Ent := Empty;
3832       Off := False;
3833
3834       if Nkind (N) = N_Attribute_Definition_Clause
3835         and then Chars (N) = Name_Address
3836       then
3837          Expr := Expression (N);
3838
3839          --  This loop checks the form of the expression for Y'Address,
3840          --  using recursion to deal with intermediate constants.
3841
3842          loop
3843             --  Check for Y'Address
3844
3845             if Nkind (Expr) = N_Attribute_Reference
3846               and then Attribute_Name (Expr) = Name_Address
3847             then
3848                Expr := Prefix (Expr);
3849                exit;
3850
3851                --  Check for Const where Const is a constant entity
3852
3853             elsif Is_Entity_Name (Expr)
3854               and then Ekind (Entity (Expr)) = E_Constant
3855             then
3856                Expr := Constant_Value (Entity (Expr));
3857
3858             --  Anything else does not need checking
3859
3860             else
3861                return;
3862             end if;
3863          end loop;
3864
3865          --  This loop checks the form of the prefix for an entity,
3866          --  using recursion to deal with intermediate components.
3867
3868          loop
3869             --  Check for Y where Y is an entity
3870
3871             if Is_Entity_Name (Expr) then
3872                Ent := Entity (Expr);
3873                return;
3874
3875             --  Check for components
3876
3877             elsif
3878                Nkind_In (Expr, N_Selected_Component, N_Indexed_Component) then
3879
3880                Expr := Prefix (Expr);
3881                Off := True;
3882
3883             --  Anything else does not need checking
3884
3885             else
3886                return;
3887             end if;
3888          end loop;
3889       end if;
3890    end Find_Overlaid_Entity;
3891
3892    -------------------------
3893    -- Find_Parameter_Type --
3894    -------------------------
3895
3896    function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
3897    begin
3898       if Nkind (Param) /= N_Parameter_Specification then
3899          return Empty;
3900
3901       --  For an access parameter, obtain the type from the formal entity
3902       --  itself, because access to subprogram nodes do not carry a type.
3903       --  Shouldn't we always use the formal entity ???
3904
3905       elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
3906          return Etype (Defining_Identifier (Param));
3907
3908       else
3909          return Etype (Parameter_Type (Param));
3910       end if;
3911    end Find_Parameter_Type;
3912
3913    -----------------------------
3914    -- Find_Static_Alternative --
3915    -----------------------------
3916
3917    function Find_Static_Alternative (N : Node_Id) return Node_Id is
3918       Expr   : constant Node_Id := Expression (N);
3919       Val    : constant Uint    := Expr_Value (Expr);
3920       Alt    : Node_Id;
3921       Choice : Node_Id;
3922
3923    begin
3924       Alt := First (Alternatives (N));
3925
3926       Search : loop
3927          if Nkind (Alt) /= N_Pragma then
3928             Choice := First (Discrete_Choices (Alt));
3929             while Present (Choice) loop
3930
3931                --  Others choice, always matches
3932
3933                if Nkind (Choice) = N_Others_Choice then
3934                   exit Search;
3935
3936                --  Range, check if value is in the range
3937
3938                elsif Nkind (Choice) = N_Range then
3939                   exit Search when
3940                     Val >= Expr_Value (Low_Bound (Choice))
3941                       and then
3942                     Val <= Expr_Value (High_Bound (Choice));
3943
3944                --  Choice is a subtype name. Note that we know it must
3945                --  be a static subtype, since otherwise it would have
3946                --  been diagnosed as illegal.
3947
3948                elsif Is_Entity_Name (Choice)
3949                  and then Is_Type (Entity (Choice))
3950                then
3951                   exit Search when Is_In_Range (Expr, Etype (Choice),
3952                                                 Assume_Valid => False);
3953
3954                --  Choice is a subtype indication
3955
3956                elsif Nkind (Choice) = N_Subtype_Indication then
3957                   declare
3958                      C : constant Node_Id := Constraint (Choice);
3959                      R : constant Node_Id := Range_Expression (C);
3960
3961                   begin
3962                      exit Search when
3963                        Val >= Expr_Value (Low_Bound (R))
3964                          and then
3965                        Val <= Expr_Value (High_Bound (R));
3966                   end;
3967
3968                --  Choice is a simple expression
3969
3970                else
3971                   exit Search when Val = Expr_Value (Choice);
3972                end if;
3973
3974                Next (Choice);
3975             end loop;
3976          end if;
3977
3978          Next (Alt);
3979          pragma Assert (Present (Alt));
3980       end loop Search;
3981
3982       --  The above loop *must* terminate by finding a match, since
3983       --  we know the case statement is valid, and the value of the
3984       --  expression is known at compile time. When we fall out of
3985       --  the loop, Alt points to the alternative that we know will
3986       --  be selected at run time.
3987
3988       return Alt;
3989    end Find_Static_Alternative;
3990
3991    ------------------
3992    -- First_Actual --
3993    ------------------
3994
3995    function First_Actual (Node : Node_Id) return Node_Id is
3996       N : Node_Id;
3997
3998    begin
3999       if No (Parameter_Associations (Node)) then
4000          return Empty;
4001       end if;
4002
4003       N := First (Parameter_Associations (Node));
4004
4005       if Nkind (N) = N_Parameter_Association then
4006          return First_Named_Actual (Node);
4007       else
4008          return N;
4009       end if;
4010    end First_Actual;
4011
4012    -----------------------
4013    -- Gather_Components --
4014    -----------------------
4015
4016    procedure Gather_Components
4017      (Typ           : Entity_Id;
4018       Comp_List     : Node_Id;
4019       Governed_By   : List_Id;
4020       Into          : Elist_Id;
4021       Report_Errors : out Boolean)
4022    is
4023       Assoc           : Node_Id;
4024       Variant         : Node_Id;
4025       Discrete_Choice : Node_Id;
4026       Comp_Item       : Node_Id;
4027
4028       Discrim       : Entity_Id;
4029       Discrim_Name  : Node_Id;
4030       Discrim_Value : Node_Id;
4031
4032    begin
4033       Report_Errors := False;
4034
4035       if No (Comp_List) or else Null_Present (Comp_List) then
4036          return;
4037
4038       elsif Present (Component_Items (Comp_List)) then
4039          Comp_Item := First (Component_Items (Comp_List));
4040
4041       else
4042          Comp_Item := Empty;
4043       end if;
4044
4045       while Present (Comp_Item) loop
4046
4047          --  Skip the tag of a tagged record, the interface tags, as well
4048          --  as all items that are not user components (anonymous types,
4049          --  rep clauses, Parent field, controller field).
4050
4051          if Nkind (Comp_Item) = N_Component_Declaration then
4052             declare
4053                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
4054             begin
4055                if not Is_Tag (Comp)
4056                  and then Chars (Comp) /= Name_uParent
4057                then
4058                   Append_Elmt (Comp, Into);
4059                end if;
4060             end;
4061          end if;
4062
4063          Next (Comp_Item);
4064       end loop;
4065
4066       if No (Variant_Part (Comp_List)) then
4067          return;
4068       else
4069          Discrim_Name := Name (Variant_Part (Comp_List));
4070          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
4071       end if;
4072
4073       --  Look for the discriminant that governs this variant part.
4074       --  The discriminant *must* be in the Governed_By List
4075
4076       Assoc := First (Governed_By);
4077       Find_Constraint : loop
4078          Discrim := First (Choices (Assoc));
4079          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
4080            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
4081                       and then
4082                     Chars (Corresponding_Discriminant (Entity (Discrim)))
4083                          = Chars  (Discrim_Name))
4084            or else Chars (Original_Record_Component (Entity (Discrim)))
4085                          = Chars (Discrim_Name);
4086
4087          if No (Next (Assoc)) then
4088             if not Is_Constrained (Typ)
4089               and then Is_Derived_Type (Typ)
4090               and then Present (Stored_Constraint (Typ))
4091             then
4092                --  If the type is a tagged type with inherited discriminants,
4093                --  use the stored constraint on the parent in order to find
4094                --  the values of discriminants that are otherwise hidden by an
4095                --  explicit constraint. Renamed discriminants are handled in
4096                --  the code above.
4097
4098                --  If several parent discriminants are renamed by a single
4099                --  discriminant of the derived type, the call to obtain the
4100                --  Corresponding_Discriminant field only retrieves the last
4101                --  of them. We recover the constraint on the others from the
4102                --  Stored_Constraint as well.
4103
4104                declare
4105                   D : Entity_Id;
4106                   C : Elmt_Id;
4107
4108                begin
4109                   D := First_Discriminant (Etype (Typ));
4110                   C := First_Elmt (Stored_Constraint (Typ));
4111                   while Present (D) and then Present (C) loop
4112                      if Chars (Discrim_Name) = Chars (D) then
4113                         if Is_Entity_Name (Node (C))
4114                           and then Entity (Node (C)) = Entity (Discrim)
4115                         then
4116                            --  D is renamed by Discrim, whose value is given in
4117                            --  Assoc.
4118
4119                            null;
4120
4121                         else
4122                            Assoc :=
4123                              Make_Component_Association (Sloc (Typ),
4124                                New_List
4125                                  (New_Occurrence_Of (D, Sloc (Typ))),
4126                                   Duplicate_Subexpr_No_Checks (Node (C)));
4127                         end if;
4128                         exit Find_Constraint;
4129                      end if;
4130
4131                      Next_Discriminant (D);
4132                      Next_Elmt (C);
4133                   end loop;
4134                end;
4135             end if;
4136          end if;
4137
4138          if No (Next (Assoc)) then
4139             Error_Msg_NE (" missing value for discriminant&",
4140               First (Governed_By), Discrim_Name);
4141             Report_Errors := True;
4142             return;
4143          end if;
4144
4145          Next (Assoc);
4146       end loop Find_Constraint;
4147
4148       Discrim_Value := Expression (Assoc);
4149
4150       if not Is_OK_Static_Expression (Discrim_Value) then
4151          Error_Msg_FE
4152            ("value for discriminant & must be static!",
4153             Discrim_Value, Discrim);
4154          Why_Not_Static (Discrim_Value);
4155          Report_Errors := True;
4156          return;
4157       end if;
4158
4159       Search_For_Discriminant_Value : declare
4160          Low  : Node_Id;
4161          High : Node_Id;
4162
4163          UI_High          : Uint;
4164          UI_Low           : Uint;
4165          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
4166
4167       begin
4168          Find_Discrete_Value : while Present (Variant) loop
4169             Discrete_Choice := First (Discrete_Choices (Variant));
4170             while Present (Discrete_Choice) loop
4171
4172                exit Find_Discrete_Value when
4173                  Nkind (Discrete_Choice) = N_Others_Choice;
4174
4175                Get_Index_Bounds (Discrete_Choice, Low, High);
4176
4177                UI_Low  := Expr_Value (Low);
4178                UI_High := Expr_Value (High);
4179
4180                exit Find_Discrete_Value when
4181                  UI_Low <= UI_Discrim_Value
4182                    and then
4183                  UI_High >= UI_Discrim_Value;
4184
4185                Next (Discrete_Choice);
4186             end loop;
4187
4188             Next_Non_Pragma (Variant);
4189          end loop Find_Discrete_Value;
4190       end Search_For_Discriminant_Value;
4191
4192       if No (Variant) then
4193          Error_Msg_NE
4194            ("value of discriminant & is out of range", Discrim_Value, Discrim);
4195          Report_Errors := True;
4196          return;
4197       end  if;
4198
4199       --  If we have found the corresponding choice, recursively add its
4200       --  components to the Into list.
4201
4202       Gather_Components (Empty,
4203         Component_List (Variant), Governed_By, Into, Report_Errors);
4204    end Gather_Components;
4205
4206    ------------------------
4207    -- Get_Actual_Subtype --
4208    ------------------------
4209
4210    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
4211       Typ  : constant Entity_Id := Etype (N);
4212       Utyp : Entity_Id := Underlying_Type (Typ);
4213       Decl : Node_Id;
4214       Atyp : Entity_Id;
4215
4216    begin
4217       if No (Utyp) then
4218          Utyp := Typ;
4219       end if;
4220
4221       --  If what we have is an identifier that references a subprogram
4222       --  formal, or a variable or constant object, then we get the actual
4223       --  subtype from the referenced entity if one has been built.
4224
4225       if Nkind (N) = N_Identifier
4226         and then
4227           (Is_Formal (Entity (N))
4228             or else Ekind (Entity (N)) = E_Constant
4229             or else Ekind (Entity (N)) = E_Variable)
4230         and then Present (Actual_Subtype (Entity (N)))
4231       then
4232          return Actual_Subtype (Entity (N));
4233
4234       --  Actual subtype of unchecked union is always itself. We never need
4235       --  the "real" actual subtype. If we did, we couldn't get it anyway
4236       --  because the discriminant is not available. The restrictions on
4237       --  Unchecked_Union are designed to make sure that this is OK.
4238
4239       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
4240          return Typ;
4241
4242       --  Here for the unconstrained case, we must find actual subtype
4243       --  No actual subtype is available, so we must build it on the fly.
4244
4245       --  Checking the type, not the underlying type, for constrainedness
4246       --  seems to be necessary. Maybe all the tests should be on the type???
4247
4248       elsif (not Is_Constrained (Typ))
4249            and then (Is_Array_Type (Utyp)
4250                       or else (Is_Record_Type (Utyp)
4251                                 and then Has_Discriminants (Utyp)))
4252            and then not Has_Unknown_Discriminants (Utyp)
4253            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
4254       then
4255          --  Nothing to do if in spec expression (why not???)
4256
4257          if In_Spec_Expression then
4258             return Typ;
4259
4260          elsif Is_Private_Type (Typ)
4261            and then not Has_Discriminants (Typ)
4262          then
4263             --  If the type has no discriminants, there is no subtype to
4264             --  build, even if the underlying type is discriminated.
4265
4266             return Typ;
4267
4268          --  Else build the actual subtype
4269
4270          else
4271             Decl := Build_Actual_Subtype (Typ, N);
4272             Atyp := Defining_Identifier (Decl);
4273
4274             --  If Build_Actual_Subtype generated a new declaration then use it
4275
4276             if Atyp /= Typ then
4277
4278                --  The actual subtype is an Itype, so analyze the declaration,
4279                --  but do not attach it to the tree, to get the type defined.
4280
4281                Set_Parent (Decl, N);
4282                Set_Is_Itype (Atyp);
4283                Analyze (Decl, Suppress => All_Checks);
4284                Set_Associated_Node_For_Itype (Atyp, N);
4285                Set_Has_Delayed_Freeze (Atyp, False);
4286
4287                --  We need to freeze the actual subtype immediately. This is
4288                --  needed, because otherwise this Itype will not get frozen
4289                --  at all, and it is always safe to freeze on creation because
4290                --  any associated types must be frozen at this point.
4291
4292                Freeze_Itype (Atyp, N);
4293                return Atyp;
4294
4295             --  Otherwise we did not build a declaration, so return original
4296
4297             else
4298                return Typ;
4299             end if;
4300          end if;
4301
4302       --  For all remaining cases, the actual subtype is the same as
4303       --  the nominal type.
4304
4305       else
4306          return Typ;
4307       end if;
4308    end Get_Actual_Subtype;
4309
4310    -------------------------------------
4311    -- Get_Actual_Subtype_If_Available --
4312    -------------------------------------
4313
4314    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
4315       Typ  : constant Entity_Id := Etype (N);
4316
4317    begin
4318       --  If what we have is an identifier that references a subprogram
4319       --  formal, or a variable or constant object, then we get the actual
4320       --  subtype from the referenced entity if one has been built.
4321
4322       if Nkind (N) = N_Identifier
4323         and then
4324           (Is_Formal (Entity (N))
4325             or else Ekind (Entity (N)) = E_Constant
4326             or else Ekind (Entity (N)) = E_Variable)
4327         and then Present (Actual_Subtype (Entity (N)))
4328       then
4329          return Actual_Subtype (Entity (N));
4330
4331       --  Otherwise the Etype of N is returned unchanged
4332
4333       else
4334          return Typ;
4335       end if;
4336    end Get_Actual_Subtype_If_Available;
4337
4338    ------------------------
4339    -- Get_Body_From_Stub --
4340    ------------------------
4341
4342    function Get_Body_From_Stub (N : Node_Id) return Node_Id is
4343    begin
4344       return Proper_Body (Unit (Library_Unit (N)));
4345    end Get_Body_From_Stub;
4346
4347    -------------------------------
4348    -- Get_Default_External_Name --
4349    -------------------------------
4350
4351    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
4352    begin
4353       Get_Decoded_Name_String (Chars (E));
4354
4355       if Opt.External_Name_Imp_Casing = Uppercase then
4356          Set_Casing (All_Upper_Case);
4357       else
4358          Set_Casing (All_Lower_Case);
4359       end if;
4360
4361       return
4362         Make_String_Literal (Sloc (E),
4363           Strval => String_From_Name_Buffer);
4364    end Get_Default_External_Name;
4365
4366    --------------------------
4367    -- Get_Enclosing_Object --
4368    --------------------------
4369
4370    function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
4371    begin
4372       if Is_Entity_Name (N) then
4373          return Entity (N);
4374       else
4375          case Nkind (N) is
4376             when N_Indexed_Component  |
4377                  N_Slice              |
4378                  N_Selected_Component =>
4379
4380                --  If not generating code, a dereference may be left implicit.
4381                --  In thoses cases, return Empty.
4382
4383                if Is_Access_Type (Etype (Prefix (N))) then
4384                   return Empty;
4385                else
4386                   return Get_Enclosing_Object (Prefix (N));
4387                end if;
4388
4389             when N_Type_Conversion =>
4390                return Get_Enclosing_Object (Expression (N));
4391
4392             when others =>
4393                return Empty;
4394          end case;
4395       end if;
4396    end Get_Enclosing_Object;
4397
4398    ---------------------------
4399    -- Get_Enum_Lit_From_Pos --
4400    ---------------------------
4401
4402    function Get_Enum_Lit_From_Pos
4403      (T   : Entity_Id;
4404       Pos : Uint;
4405       Loc : Source_Ptr) return Node_Id
4406    is
4407       Lit : Node_Id;
4408
4409    begin
4410       --  In the case where the literal is of type Character, Wide_Character
4411       --  or Wide_Wide_Character or of a type derived from them, there needs
4412       --  to be some special handling since there is no explicit chain of
4413       --  literals to search. Instead, an N_Character_Literal node is created
4414       --  with the appropriate Char_Code and Chars fields.
4415
4416       if Is_Standard_Character_Type (T) then
4417          Set_Character_Literal_Name (UI_To_CC (Pos));
4418          return
4419            Make_Character_Literal (Loc,
4420              Chars              => Name_Find,
4421              Char_Literal_Value => Pos);
4422
4423       --  For all other cases, we have a complete table of literals, and
4424       --  we simply iterate through the chain of literal until the one
4425       --  with the desired position value is found.
4426       --
4427
4428       else
4429          Lit := First_Literal (Base_Type (T));
4430          for J in 1 .. UI_To_Int (Pos) loop
4431             Next_Literal (Lit);
4432          end loop;
4433
4434          return New_Occurrence_Of (Lit, Loc);
4435       end if;
4436    end Get_Enum_Lit_From_Pos;
4437
4438    ---------------------------------------
4439    -- Get_Ensures_From_Test_Case_Pragma --
4440    ---------------------------------------
4441
4442    function Get_Ensures_From_Test_Case_Pragma (N : Node_Id) return Node_Id is
4443       Args : constant List_Id := Pragma_Argument_Associations (N);
4444       Res  : Node_Id;
4445
4446    begin
4447       if List_Length (Args) = 4 then
4448          Res := Pick (Args, 4);
4449
4450       elsif List_Length (Args) = 3 then
4451          Res := Pick (Args, 3);
4452
4453          if Chars (Res) /= Name_Ensures then
4454             Res := Empty;
4455          end if;
4456
4457       else
4458          Res := Empty;
4459       end if;
4460
4461       return Res;
4462    end Get_Ensures_From_Test_Case_Pragma;
4463
4464    ------------------------
4465    -- Get_Generic_Entity --
4466    ------------------------
4467
4468    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
4469       Ent : constant Entity_Id := Entity (Name (N));
4470    begin
4471       if Present (Renamed_Object (Ent)) then
4472          return Renamed_Object (Ent);
4473       else
4474          return Ent;
4475       end if;
4476    end Get_Generic_Entity;
4477
4478    ----------------------
4479    -- Get_Index_Bounds --
4480    ----------------------
4481
4482    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
4483       Kind : constant Node_Kind := Nkind (N);
4484       R    : Node_Id;
4485
4486    begin
4487       if Kind = N_Range then
4488          L := Low_Bound (N);
4489          H := High_Bound (N);
4490
4491       elsif Kind = N_Subtype_Indication then
4492          R := Range_Expression (Constraint (N));
4493
4494          if R = Error then
4495             L := Error;
4496             H := Error;
4497             return;
4498
4499          else
4500             L := Low_Bound  (Range_Expression (Constraint (N)));
4501             H := High_Bound (Range_Expression (Constraint (N)));
4502          end if;
4503
4504       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
4505          if Error_Posted (Scalar_Range (Entity (N))) then
4506             L := Error;
4507             H := Error;
4508
4509          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
4510             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
4511
4512          else
4513             L := Low_Bound  (Scalar_Range (Entity (N)));
4514             H := High_Bound (Scalar_Range (Entity (N)));
4515          end if;
4516
4517       else
4518          --  N is an expression, indicating a range with one value
4519
4520          L := N;
4521          H := N;
4522       end if;
4523    end Get_Index_Bounds;
4524
4525    ----------------------------------
4526    -- Get_Library_Unit_Name_string --
4527    ----------------------------------
4528
4529    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
4530       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
4531
4532    begin
4533       Get_Unit_Name_String (Unit_Name_Id);
4534
4535       --  Remove seven last character (" (spec)" or " (body)")
4536
4537       Name_Len := Name_Len - 7;
4538       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
4539    end Get_Library_Unit_Name_String;
4540
4541    ------------------------
4542    -- Get_Name_Entity_Id --
4543    ------------------------
4544
4545    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
4546    begin
4547       return Entity_Id (Get_Name_Table_Info (Id));
4548    end Get_Name_Entity_Id;
4549
4550    ------------------------------------
4551    -- Get_Name_From_Test_Case_Pragma --
4552    ------------------------------------
4553
4554    function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is
4555       Arg : constant Node_Id :=
4556               Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
4557    begin
4558       return Strval (Expr_Value_S (Arg));
4559    end Get_Name_From_Test_Case_Pragma;
4560
4561    -------------------
4562    -- Get_Pragma_Id --
4563    -------------------
4564
4565    function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
4566    begin
4567       return Get_Pragma_Id (Pragma_Name (N));
4568    end Get_Pragma_Id;
4569
4570    ---------------------------
4571    -- Get_Referenced_Object --
4572    ---------------------------
4573
4574    function Get_Referenced_Object (N : Node_Id) return Node_Id is
4575       R : Node_Id;
4576
4577    begin
4578       R := N;
4579       while Is_Entity_Name (R)
4580         and then Present (Renamed_Object (Entity (R)))
4581       loop
4582          R := Renamed_Object (Entity (R));
4583       end loop;
4584
4585       return R;
4586    end Get_Referenced_Object;
4587
4588    ------------------------
4589    -- Get_Renamed_Entity --
4590    ------------------------
4591
4592    function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
4593       R : Entity_Id;
4594
4595    begin
4596       R := E;
4597       while Present (Renamed_Entity (R)) loop
4598          R := Renamed_Entity (R);
4599       end loop;
4600
4601       return R;
4602    end Get_Renamed_Entity;
4603
4604    ----------------------------------------
4605    -- Get_Requires_From_Test_Case_Pragma --
4606    ----------------------------------------
4607
4608    function Get_Requires_From_Test_Case_Pragma (N : Node_Id) return Node_Id is
4609       Args : constant List_Id := Pragma_Argument_Associations (N);
4610       Res  : Node_Id;
4611
4612    begin
4613       if List_Length (Args) >= 3 then
4614          Res := Pick (Args, 3);
4615
4616          if Chars (Res) /= Name_Requires then
4617             Res := Empty;
4618          end if;
4619
4620       else
4621          Res := Empty;
4622       end if;
4623
4624       return Res;
4625    end Get_Requires_From_Test_Case_Pragma;
4626
4627    -------------------------
4628    -- Get_Subprogram_Body --
4629    -------------------------
4630
4631    function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
4632       Decl : Node_Id;
4633
4634    begin
4635       Decl := Unit_Declaration_Node (E);
4636
4637       if Nkind (Decl) = N_Subprogram_Body then
4638          return Decl;
4639
4640       --  The below comment is bad, because it is possible for
4641       --  Nkind (Decl) to be an N_Subprogram_Body_Stub ???
4642
4643       else           --  Nkind (Decl) = N_Subprogram_Declaration
4644
4645          if Present (Corresponding_Body (Decl)) then
4646             return Unit_Declaration_Node (Corresponding_Body (Decl));
4647
4648          --  Imported subprogram case
4649
4650          else
4651             return Empty;
4652          end if;
4653       end if;
4654    end Get_Subprogram_Body;
4655
4656    ---------------------------
4657    -- Get_Subprogram_Entity --
4658    ---------------------------
4659
4660    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
4661       Nam  : Node_Id;
4662       Proc : Entity_Id;
4663
4664    begin
4665       if Nkind (Nod) = N_Accept_Statement then
4666          Nam := Entry_Direct_Name (Nod);
4667
4668       --  For an entry call, the prefix of the call is a selected component.
4669       --  Need additional code for internal calls ???
4670
4671       elsif Nkind (Nod) = N_Entry_Call_Statement then
4672          if Nkind (Name (Nod)) = N_Selected_Component then
4673             Nam := Entity (Selector_Name (Name (Nod)));
4674          else
4675             Nam := Empty;
4676          end if;
4677
4678       else
4679          Nam := Name (Nod);
4680       end if;
4681
4682       if Nkind (Nam) = N_Explicit_Dereference then
4683          Proc := Etype (Prefix (Nam));
4684       elsif Is_Entity_Name (Nam) then
4685          Proc := Entity (Nam);
4686       else
4687          return Empty;
4688       end if;
4689
4690       if Is_Object (Proc) then
4691          Proc := Etype (Proc);
4692       end if;
4693
4694       if Ekind (Proc) = E_Access_Subprogram_Type then
4695          Proc := Directly_Designated_Type (Proc);
4696       end if;
4697
4698       if not Is_Subprogram (Proc)
4699         and then Ekind (Proc) /= E_Subprogram_Type
4700       then
4701          return Empty;
4702       else
4703          return Proc;
4704       end if;
4705    end Get_Subprogram_Entity;
4706
4707    -----------------------------
4708    -- Get_Task_Body_Procedure --
4709    -----------------------------
4710
4711    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
4712    begin
4713       --  Note: A task type may be the completion of a private type with
4714       --  discriminants. When performing elaboration checks on a task
4715       --  declaration, the current view of the type may be the private one,
4716       --  and the procedure that holds the body of the task is held in its
4717       --  underlying type.
4718
4719       --  This is an odd function, why not have Task_Body_Procedure do
4720       --  the following digging???
4721
4722       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
4723    end Get_Task_Body_Procedure;
4724
4725    -----------------------
4726    -- Has_Access_Values --
4727    -----------------------
4728
4729    function Has_Access_Values (T : Entity_Id) return Boolean is
4730       Typ : constant Entity_Id := Underlying_Type (T);
4731
4732    begin
4733       --  Case of a private type which is not completed yet. This can only
4734       --  happen in the case of a generic format type appearing directly, or
4735       --  as a component of the type to which this function is being applied
4736       --  at the top level. Return False in this case, since we certainly do
4737       --  not know that the type contains access types.
4738
4739       if No (Typ) then
4740          return False;
4741
4742       elsif Is_Access_Type (Typ) then
4743          return True;
4744
4745       elsif Is_Array_Type (Typ) then
4746          return Has_Access_Values (Component_Type (Typ));
4747
4748       elsif Is_Record_Type (Typ) then
4749          declare
4750             Comp : Entity_Id;
4751
4752          begin
4753             --  Loop to Check components
4754
4755             Comp := First_Component_Or_Discriminant (Typ);
4756             while Present (Comp) loop
4757
4758                --  Check for access component, tag field does not count, even
4759                --  though it is implemented internally using an access type.
4760
4761                if Has_Access_Values (Etype (Comp))
4762                  and then Chars (Comp) /= Name_uTag
4763                then
4764                   return True;
4765                end if;
4766
4767                Next_Component_Or_Discriminant (Comp);
4768             end loop;
4769          end;
4770
4771          return False;
4772
4773       else
4774          return False;
4775       end if;
4776    end Has_Access_Values;
4777
4778    ------------------------------
4779    -- Has_Compatible_Alignment --
4780    ------------------------------
4781
4782    function Has_Compatible_Alignment
4783      (Obj  : Entity_Id;
4784       Expr : Node_Id) return Alignment_Result
4785    is
4786       function Has_Compatible_Alignment_Internal
4787         (Obj     : Entity_Id;
4788          Expr    : Node_Id;
4789          Default : Alignment_Result) return Alignment_Result;
4790       --  This is the internal recursive function that actually does the work.
4791       --  There is one additional parameter, which says what the result should
4792       --  be if no alignment information is found, and there is no definite
4793       --  indication of compatible alignments. At the outer level, this is set
4794       --  to Unknown, but for internal recursive calls in the case where types
4795       --  are known to be correct, it is set to Known_Compatible.
4796
4797       ---------------------------------------
4798       -- Has_Compatible_Alignment_Internal --
4799       ---------------------------------------
4800
4801       function Has_Compatible_Alignment_Internal
4802         (Obj     : Entity_Id;
4803          Expr    : Node_Id;
4804          Default : Alignment_Result) return Alignment_Result
4805       is
4806          Result : Alignment_Result := Known_Compatible;
4807          --  Holds the current status of the result. Note that once a value of
4808          --  Known_Incompatible is set, it is sticky and does not get changed
4809          --  to Unknown (the value in Result only gets worse as we go along,
4810          --  never better).
4811
4812          Offs : Uint := No_Uint;
4813          --  Set to a factor of the offset from the base object when Expr is a
4814          --  selected or indexed component, based on Component_Bit_Offset and
4815          --  Component_Size respectively. A negative value is used to represent
4816          --  a value which is not known at compile time.
4817
4818          procedure Check_Prefix;
4819          --  Checks the prefix recursively in the case where the expression
4820          --  is an indexed or selected component.
4821
4822          procedure Set_Result (R : Alignment_Result);
4823          --  If R represents a worse outcome (unknown instead of known
4824          --  compatible, or known incompatible), then set Result to R.
4825
4826          ------------------
4827          -- Check_Prefix --
4828          ------------------
4829
4830          procedure Check_Prefix is
4831          begin
4832             --  The subtlety here is that in doing a recursive call to check
4833             --  the prefix, we have to decide what to do in the case where we
4834             --  don't find any specific indication of an alignment problem.
4835
4836             --  At the outer level, we normally set Unknown as the result in
4837             --  this case, since we can only set Known_Compatible if we really
4838             --  know that the alignment value is OK, but for the recursive
4839             --  call, in the case where the types match, and we have not
4840             --  specified a peculiar alignment for the object, we are only
4841             --  concerned about suspicious rep clauses, the default case does
4842             --  not affect us, since the compiler will, in the absence of such
4843             --  rep clauses, ensure that the alignment is correct.
4844
4845             if Default = Known_Compatible
4846               or else
4847                 (Etype (Obj) = Etype (Expr)
4848                   and then (Unknown_Alignment (Obj)
4849                              or else
4850                                Alignment (Obj) = Alignment (Etype (Obj))))
4851             then
4852                Set_Result
4853                  (Has_Compatible_Alignment_Internal
4854                     (Obj, Prefix (Expr), Known_Compatible));
4855
4856             --  In all other cases, we need a full check on the prefix
4857
4858             else
4859                Set_Result
4860                  (Has_Compatible_Alignment_Internal
4861                     (Obj, Prefix (Expr), Unknown));
4862             end if;
4863          end Check_Prefix;
4864
4865          ----------------
4866          -- Set_Result --
4867          ----------------
4868
4869          procedure Set_Result (R : Alignment_Result) is
4870          begin
4871             if R > Result then
4872                Result := R;
4873             end if;
4874          end Set_Result;
4875
4876       --  Start of processing for Has_Compatible_Alignment_Internal
4877
4878       begin
4879          --  If Expr is a selected component, we must make sure there is no
4880          --  potentially troublesome component clause, and that the record is
4881          --  not packed.
4882
4883          if Nkind (Expr) = N_Selected_Component then
4884
4885             --  Packed record always generate unknown alignment
4886
4887             if Is_Packed (Etype (Prefix (Expr))) then
4888                Set_Result (Unknown);
4889             end if;
4890
4891             --  Check prefix and component offset
4892
4893             Check_Prefix;
4894             Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
4895
4896          --  If Expr is an indexed component, we must make sure there is no
4897          --  potentially troublesome Component_Size clause and that the array
4898          --  is not bit-packed.
4899
4900          elsif Nkind (Expr) = N_Indexed_Component then
4901             declare
4902                Typ : constant Entity_Id := Etype (Prefix (Expr));
4903                Ind : constant Node_Id   := First_Index (Typ);
4904
4905             begin
4906                --  Bit packed array always generates unknown alignment
4907
4908                if Is_Bit_Packed_Array (Typ) then
4909                   Set_Result (Unknown);
4910                end if;
4911
4912                --  Check prefix and component offset
4913
4914                Check_Prefix;
4915                Offs := Component_Size (Typ);
4916
4917                --  Small optimization: compute the full offset when possible
4918
4919                if Offs /= No_Uint
4920                  and then Offs > Uint_0
4921                  and then Present (Ind)
4922                  and then Nkind (Ind) = N_Range
4923                  and then Compile_Time_Known_Value (Low_Bound (Ind))
4924                  and then Compile_Time_Known_Value (First (Expressions (Expr)))
4925                then
4926                   Offs := Offs * (Expr_Value (First (Expressions (Expr)))
4927                                     - Expr_Value (Low_Bound ((Ind))));
4928                end if;
4929             end;
4930          end if;
4931
4932          --  If we have a null offset, the result is entirely determined by
4933          --  the base object and has already been computed recursively.
4934
4935          if Offs = Uint_0 then
4936             null;
4937
4938          --  Case where we know the alignment of the object
4939
4940          elsif Known_Alignment (Obj) then
4941             declare
4942                ObjA : constant Uint := Alignment (Obj);
4943                ExpA : Uint          := No_Uint;
4944                SizA : Uint          := No_Uint;
4945
4946             begin
4947                --  If alignment of Obj is 1, then we are always OK
4948
4949                if ObjA = 1 then
4950                   Set_Result (Known_Compatible);
4951
4952                --  Alignment of Obj is greater than 1, so we need to check
4953
4954                else
4955                   --  If we have an offset, see if it is compatible
4956
4957                   if Offs /= No_Uint and Offs > Uint_0 then
4958                      if Offs mod (System_Storage_Unit * ObjA) /= 0 then
4959                         Set_Result (Known_Incompatible);
4960                      end if;
4961
4962                      --  See if Expr is an object with known alignment
4963
4964                   elsif Is_Entity_Name (Expr)
4965                     and then Known_Alignment (Entity (Expr))
4966                   then
4967                      ExpA := Alignment (Entity (Expr));
4968
4969                      --  Otherwise, we can use the alignment of the type of
4970                      --  Expr given that we already checked for
4971                      --  discombobulating rep clauses for the cases of indexed
4972                      --  and selected components above.
4973
4974                   elsif Known_Alignment (Etype (Expr)) then
4975                      ExpA := Alignment (Etype (Expr));
4976
4977                      --  Otherwise the alignment is unknown
4978
4979                   else
4980                      Set_Result (Default);
4981                   end if;
4982
4983                   --  If we got an alignment, see if it is acceptable
4984
4985                   if ExpA /= No_Uint and then ExpA < ObjA then
4986                      Set_Result (Known_Incompatible);
4987                   end if;
4988
4989                   --  If Expr is not a piece of a larger object, see if size
4990                   --  is given. If so, check that it is not too small for the
4991                   --  required alignment.
4992
4993                   if Offs /= No_Uint then
4994                      null;
4995
4996                      --  See if Expr is an object with known size
4997
4998                   elsif Is_Entity_Name (Expr)
4999                     and then Known_Static_Esize (Entity (Expr))
5000                   then
5001                      SizA := Esize (Entity (Expr));
5002
5003                      --  Otherwise, we check the object size of the Expr type
5004
5005                   elsif Known_Static_Esize (Etype (Expr)) then
5006                      SizA := Esize (Etype (Expr));
5007                   end if;
5008
5009                   --  If we got a size, see if it is a multiple of the Obj
5010                   --  alignment, if not, then the alignment cannot be
5011                   --  acceptable, since the size is always a multiple of the
5012                   --  alignment.
5013
5014                   if SizA /= No_Uint then
5015                      if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
5016                         Set_Result (Known_Incompatible);
5017                      end if;
5018                   end if;
5019                end if;
5020             end;
5021
5022          --  If we do not know required alignment, any non-zero offset is a
5023          --  potential problem (but certainly may be OK, so result is unknown).
5024
5025          elsif Offs /= No_Uint then
5026             Set_Result (Unknown);
5027
5028          --  If we can't find the result by direct comparison of alignment
5029          --  values, then there is still one case that we can determine known
5030          --  result, and that is when we can determine that the types are the
5031          --  same, and no alignments are specified. Then we known that the
5032          --  alignments are compatible, even if we don't know the alignment
5033          --  value in the front end.
5034
5035          elsif Etype (Obj) = Etype (Expr) then
5036
5037             --  Types are the same, but we have to check for possible size
5038             --  and alignments on the Expr object that may make the alignment
5039             --  different, even though the types are the same.
5040
5041             if Is_Entity_Name (Expr) then
5042
5043                --  First check alignment of the Expr object. Any alignment less
5044                --  than Maximum_Alignment is worrisome since this is the case
5045                --  where we do not know the alignment of Obj.
5046
5047                if Known_Alignment (Entity (Expr))
5048                  and then
5049                    UI_To_Int (Alignment (Entity (Expr))) <
5050                                                     Ttypes.Maximum_Alignment
5051                then
5052                   Set_Result (Unknown);
5053
5054                   --  Now check size of Expr object. Any size that is not an
5055                   --  even multiple of Maximum_Alignment is also worrisome
5056                   --  since it may cause the alignment of the object to be less
5057                   --  than the alignment of the type.
5058
5059                elsif Known_Static_Esize (Entity (Expr))
5060                  and then
5061                    (UI_To_Int (Esize (Entity (Expr))) mod
5062                      (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
5063                                                                         /= 0
5064                then
5065                   Set_Result (Unknown);
5066
5067                   --  Otherwise same type is decisive
5068
5069                else
5070                   Set_Result (Known_Compatible);
5071                end if;
5072             end if;
5073
5074          --  Another case to deal with is when there is an explicit size or
5075          --  alignment clause when the types are not the same. If so, then the
5076          --  result is Unknown. We don't need to do this test if the Default is
5077          --  Unknown, since that result will be set in any case.
5078
5079          elsif Default /= Unknown
5080            and then (Has_Size_Clause      (Etype (Expr))
5081                       or else
5082                      Has_Alignment_Clause (Etype (Expr)))
5083          then
5084             Set_Result (Unknown);
5085
5086          --  If no indication found, set default
5087
5088          else
5089             Set_Result (Default);
5090          end if;
5091
5092          --  Return worst result found
5093
5094          return Result;
5095       end Has_Compatible_Alignment_Internal;
5096
5097    --  Start of processing for Has_Compatible_Alignment
5098
5099    begin
5100       --  If Obj has no specified alignment, then set alignment from the type
5101       --  alignment. Perhaps we should always do this, but for sure we should
5102       --  do it when there is an address clause since we can do more if the
5103       --  alignment is known.
5104
5105       if Unknown_Alignment (Obj) then
5106          Set_Alignment (Obj, Alignment (Etype (Obj)));
5107       end if;
5108
5109       --  Now do the internal call that does all the work
5110
5111       return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
5112    end Has_Compatible_Alignment;
5113
5114    ----------------------
5115    -- Has_Declarations --
5116    ----------------------
5117
5118    function Has_Declarations (N : Node_Id) return Boolean is
5119    begin
5120       return Nkind_In (Nkind (N), N_Accept_Statement,
5121                                   N_Block_Statement,
5122                                   N_Compilation_Unit_Aux,
5123                                   N_Entry_Body,
5124                                   N_Package_Body,
5125                                   N_Protected_Body,
5126                                   N_Subprogram_Body,
5127                                   N_Task_Body,
5128                                   N_Package_Specification);
5129    end Has_Declarations;
5130
5131    -------------------------------------------
5132    -- Has_Discriminant_Dependent_Constraint --
5133    -------------------------------------------
5134
5135    function Has_Discriminant_Dependent_Constraint
5136      (Comp : Entity_Id) return Boolean
5137    is
5138       Comp_Decl  : constant Node_Id := Parent (Comp);
5139       Subt_Indic : constant Node_Id :=
5140                      Subtype_Indication (Component_Definition (Comp_Decl));
5141       Constr     : Node_Id;
5142       Assn       : Node_Id;
5143
5144    begin
5145       if Nkind (Subt_Indic) = N_Subtype_Indication then
5146          Constr := Constraint (Subt_Indic);
5147
5148          if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
5149             Assn := First (Constraints (Constr));
5150             while Present (Assn) loop
5151                case Nkind (Assn) is
5152                   when N_Subtype_Indication |
5153                        N_Range              |
5154                        N_Identifier
5155                   =>
5156                      if Depends_On_Discriminant (Assn) then
5157                         return True;
5158                      end if;
5159
5160                   when N_Discriminant_Association =>
5161                      if Depends_On_Discriminant (Expression (Assn)) then
5162                         return True;
5163                      end if;
5164
5165                   when others =>
5166                      null;
5167
5168                end case;
5169
5170                Next (Assn);
5171             end loop;
5172          end if;
5173       end if;
5174
5175       return False;
5176    end Has_Discriminant_Dependent_Constraint;
5177
5178    --------------------
5179    -- Has_Infinities --
5180    --------------------
5181
5182    function Has_Infinities (E : Entity_Id) return Boolean is
5183    begin
5184       return
5185         Is_Floating_Point_Type (E)
5186           and then Nkind (Scalar_Range (E)) = N_Range
5187           and then Includes_Infinities (Scalar_Range (E));
5188    end Has_Infinities;
5189
5190    --------------------
5191    -- Has_Interfaces --
5192    --------------------
5193
5194    function Has_Interfaces
5195      (T             : Entity_Id;
5196       Use_Full_View : Boolean := True) return Boolean
5197    is
5198       Typ : Entity_Id := Base_Type (T);
5199
5200    begin
5201       --  Handle concurrent types
5202
5203       if Is_Concurrent_Type (Typ) then
5204          Typ := Corresponding_Record_Type (Typ);
5205       end if;
5206
5207       if not Present (Typ)
5208         or else not Is_Record_Type (Typ)
5209         or else not Is_Tagged_Type (Typ)
5210       then
5211          return False;
5212       end if;
5213
5214       --  Handle private types
5215
5216       if Use_Full_View
5217         and then Present (Full_View (Typ))
5218       then
5219          Typ := Full_View (Typ);
5220       end if;
5221
5222       --  Handle concurrent record types
5223
5224       if Is_Concurrent_Record_Type (Typ)
5225         and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
5226       then
5227          return True;
5228       end if;
5229
5230       loop
5231          if Is_Interface (Typ)
5232            or else
5233              (Is_Record_Type (Typ)
5234                and then Present (Interfaces (Typ))
5235                and then not Is_Empty_Elmt_List (Interfaces (Typ)))
5236          then
5237             return True;
5238          end if;
5239
5240          exit when Etype (Typ) = Typ
5241
5242             --  Handle private types
5243
5244             or else (Present (Full_View (Etype (Typ)))
5245                        and then Full_View (Etype (Typ)) = Typ)
5246
5247             --  Protect the frontend against wrong source with cyclic
5248             --  derivations
5249
5250             or else Etype (Typ) = T;
5251
5252          --  Climb to the ancestor type handling private types
5253
5254          if Present (Full_View (Etype (Typ))) then
5255             Typ := Full_View (Etype (Typ));
5256          else
5257             Typ := Etype (Typ);
5258          end if;
5259       end loop;
5260
5261       return False;
5262    end Has_Interfaces;
5263
5264    ------------------------
5265    -- Has_Null_Exclusion --
5266    ------------------------
5267
5268    function Has_Null_Exclusion (N : Node_Id) return Boolean is
5269    begin
5270       case Nkind (N) is
5271          when N_Access_Definition               |
5272               N_Access_Function_Definition      |
5273               N_Access_Procedure_Definition     |
5274               N_Access_To_Object_Definition     |
5275               N_Allocator                       |
5276               N_Derived_Type_Definition         |
5277               N_Function_Specification          |
5278               N_Subtype_Declaration             =>
5279             return Null_Exclusion_Present (N);
5280
5281          when N_Component_Definition            |
5282               N_Formal_Object_Declaration       |
5283               N_Object_Renaming_Declaration     =>
5284             if Present (Subtype_Mark (N)) then
5285                return Null_Exclusion_Present (N);
5286             else pragma Assert (Present (Access_Definition (N)));
5287                return Null_Exclusion_Present (Access_Definition (N));
5288             end if;
5289
5290          when N_Discriminant_Specification =>
5291             if Nkind (Discriminant_Type (N)) = N_Access_Definition then
5292                return Null_Exclusion_Present (Discriminant_Type (N));
5293             else
5294                return Null_Exclusion_Present (N);
5295             end if;
5296
5297          when N_Object_Declaration =>
5298             if Nkind (Object_Definition (N)) = N_Access_Definition then
5299                return Null_Exclusion_Present (Object_Definition (N));
5300             else
5301                return Null_Exclusion_Present (N);
5302             end if;
5303
5304          when N_Parameter_Specification =>
5305             if Nkind (Parameter_Type (N)) = N_Access_Definition then
5306                return Null_Exclusion_Present (Parameter_Type (N));
5307             else
5308                return Null_Exclusion_Present (N);
5309             end if;
5310
5311          when others =>
5312             return False;
5313
5314       end case;
5315    end Has_Null_Exclusion;
5316
5317    ------------------------
5318    -- Has_Null_Extension --
5319    ------------------------
5320
5321    function Has_Null_Extension (T : Entity_Id) return Boolean is
5322       B     : constant Entity_Id := Base_Type (T);
5323       Comps : Node_Id;
5324       Ext   : Node_Id;
5325
5326    begin
5327       if Nkind (Parent (B)) = N_Full_Type_Declaration
5328         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
5329       then
5330          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
5331
5332          if Present (Ext) then
5333             if Null_Present (Ext) then
5334                return True;
5335             else
5336                Comps := Component_List (Ext);
5337
5338                --  The null component list is rewritten during analysis to
5339                --  include the parent component. Any other component indicates
5340                --  that the extension was not originally null.
5341
5342                return Null_Present (Comps)
5343                  or else No (Next (First (Component_Items (Comps))));
5344             end if;
5345          else
5346             return False;
5347          end if;
5348
5349       else
5350          return False;
5351       end if;
5352    end Has_Null_Extension;
5353
5354    -------------------------------
5355    -- Has_Overriding_Initialize --
5356    -------------------------------
5357
5358    function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
5359       BT   : constant Entity_Id := Base_Type (T);
5360       P    : Elmt_Id;
5361
5362    begin
5363       if Is_Controlled (BT) then
5364          if Is_RTU (Scope (BT), Ada_Finalization) then
5365             return False;
5366
5367          elsif Present (Primitive_Operations (BT)) then
5368             P := First_Elmt (Primitive_Operations (BT));
5369             while Present (P) loop
5370                declare
5371                   Init : constant Entity_Id := Node (P);
5372                   Formal : constant Entity_Id := First_Formal (Init);
5373                begin
5374                   if Ekind (Init) = E_Procedure
5375                        and then Chars (Init) = Name_Initialize
5376                        and then Comes_From_Source (Init)
5377                        and then Present (Formal)
5378                        and then Etype (Formal) = BT
5379                        and then No (Next_Formal (Formal))
5380                        and then (Ada_Version < Ada_2012
5381                                    or else not Null_Present (Parent (Init)))
5382                   then
5383                      return True;
5384                   end if;
5385                end;
5386
5387                Next_Elmt (P);
5388             end loop;
5389          end if;
5390
5391          --  Here if type itself does not have a non-null Initialize operation:
5392          --  check immediate ancestor.
5393
5394          if Is_Derived_Type (BT)
5395            and then Has_Overriding_Initialize (Etype (BT))
5396          then
5397             return True;
5398          end if;
5399       end if;
5400
5401       return False;
5402    end Has_Overriding_Initialize;
5403
5404    --------------------------------------
5405    -- Has_Preelaborable_Initialization --
5406    --------------------------------------
5407
5408    function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
5409       Has_PE : Boolean;
5410
5411       procedure Check_Components (E : Entity_Id);
5412       --  Check component/discriminant chain, sets Has_PE False if a component
5413       --  or discriminant does not meet the preelaborable initialization rules.
5414
5415       ----------------------
5416       -- Check_Components --
5417       ----------------------
5418
5419       procedure Check_Components (E : Entity_Id) is
5420          Ent : Entity_Id;
5421          Exp : Node_Id;
5422
5423          function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
5424          --  Returns True if and only if the expression denoted by N does not
5425          --  violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
5426
5427          ---------------------------------
5428          -- Is_Preelaborable_Expression --
5429          ---------------------------------
5430
5431          function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
5432             Exp           : Node_Id;
5433             Assn          : Node_Id;
5434             Choice        : Node_Id;
5435             Comp_Type     : Entity_Id;
5436             Is_Array_Aggr : Boolean;
5437
5438          begin
5439             if Is_Static_Expression (N) then
5440                return True;
5441
5442             elsif Nkind (N) = N_Null then
5443                return True;
5444
5445             --  Attributes are allowed in general, even if their prefix is a
5446             --  formal type. (It seems that certain attributes known not to be
5447             --  static might not be allowed, but there are no rules to prevent
5448             --  them.)
5449
5450             elsif Nkind (N) = N_Attribute_Reference then
5451                return True;
5452
5453             --  The name of a discriminant evaluated within its parent type is
5454             --  defined to be preelaborable (10.2.1(8)). Note that we test for
5455             --  names that denote discriminals as well as discriminants to
5456             --  catch references occurring within init procs.
5457
5458             elsif Is_Entity_Name (N)
5459               and then
5460                 (Ekind (Entity (N)) = E_Discriminant
5461                   or else
5462                     ((Ekind (Entity (N)) = E_Constant
5463                        or else Ekind (Entity (N)) = E_In_Parameter)
5464                      and then Present (Discriminal_Link (Entity (N)))))
5465             then
5466                return True;
5467
5468             elsif Nkind (N) = N_Qualified_Expression then
5469                return Is_Preelaborable_Expression (Expression (N));
5470
5471             --  For aggregates we have to check that each of the associations
5472             --  is preelaborable.
5473
5474             elsif Nkind (N) = N_Aggregate
5475               or else Nkind (N) = N_Extension_Aggregate
5476             then
5477                Is_Array_Aggr := Is_Array_Type (Etype (N));
5478
5479                if Is_Array_Aggr then
5480                   Comp_Type := Component_Type (Etype (N));
5481                end if;
5482
5483                --  Check the ancestor part of extension aggregates, which must
5484                --  be either the name of a type that has preelaborable init or
5485                --  an expression that is preelaborable.
5486
5487                if Nkind (N) = N_Extension_Aggregate then
5488                   declare
5489                      Anc_Part : constant Node_Id := Ancestor_Part (N);
5490
5491                   begin
5492                      if Is_Entity_Name (Anc_Part)
5493                        and then Is_Type (Entity (Anc_Part))
5494                      then
5495                         if not Has_Preelaborable_Initialization
5496                                  (Entity (Anc_Part))
5497                         then
5498                            return False;
5499                         end if;
5500
5501                      elsif not Is_Preelaborable_Expression (Anc_Part) then
5502                         return False;
5503                      end if;
5504                   end;
5505                end if;
5506
5507                --  Check positional associations
5508
5509                Exp := First (Expressions (N));
5510                while Present (Exp) loop
5511                   if not Is_Preelaborable_Expression (Exp) then
5512                      return False;
5513                   end if;
5514
5515                   Next (Exp);
5516                end loop;
5517
5518                --  Check named associations
5519
5520                Assn := First (Component_Associations (N));
5521                while Present (Assn) loop
5522                   Choice := First (Choices (Assn));
5523                   while Present (Choice) loop
5524                      if Is_Array_Aggr then
5525                         if Nkind (Choice) = N_Others_Choice then
5526                            null;
5527
5528                         elsif Nkind (Choice) = N_Range then
5529                            if not Is_Static_Range (Choice) then
5530                               return False;
5531                            end if;
5532
5533                         elsif not Is_Static_Expression (Choice) then
5534                            return False;
5535                         end if;
5536
5537                      else
5538                         Comp_Type := Etype (Choice);
5539                      end if;
5540
5541                      Next (Choice);
5542                   end loop;
5543
5544                   --  If the association has a <> at this point, then we have
5545                   --  to check whether the component's type has preelaborable
5546                   --  initialization. Note that this only occurs when the
5547                   --  association's corresponding component does not have a
5548                   --  default expression, the latter case having already been
5549                   --  expanded as an expression for the association.
5550
5551                   if Box_Present (Assn) then
5552                      if not Has_Preelaborable_Initialization (Comp_Type) then
5553                         return False;
5554                      end if;
5555
5556                   --  In the expression case we check whether the expression
5557                   --  is preelaborable.
5558
5559                   elsif
5560                     not Is_Preelaborable_Expression (Expression (Assn))
5561                   then
5562                      return False;
5563                   end if;
5564
5565                   Next (Assn);
5566                end loop;
5567
5568                --  If we get here then aggregate as a whole is preelaborable
5569
5570                return True;
5571
5572             --  All other cases are not preelaborable
5573
5574             else
5575                return False;
5576             end if;
5577          end Is_Preelaborable_Expression;
5578
5579       --  Start of processing for Check_Components
5580
5581       begin
5582          --  Loop through entities of record or protected type
5583
5584          Ent := E;
5585          while Present (Ent) loop
5586
5587             --  We are interested only in components and discriminants
5588
5589             Exp := Empty;
5590
5591             case Ekind (Ent) is
5592                when E_Component =>
5593
5594                   --  Get default expression if any. If there is no declaration
5595                   --  node, it means we have an internal entity. The parent and
5596                   --  tag fields are examples of such entities. For such cases,
5597                   --  we just test the type of the entity.
5598
5599                   if Present (Declaration_Node (Ent)) then
5600                      Exp := Expression (Declaration_Node (Ent));
5601                   end if;
5602
5603                when E_Discriminant =>
5604
5605                   --  Note: for a renamed discriminant, the Declaration_Node
5606                   --  may point to the one from the ancestor, and have a
5607                   --  different expression, so use the proper attribute to
5608                   --  retrieve the expression from the derived constraint.
5609
5610                   Exp := Discriminant_Default_Value (Ent);
5611
5612                when others =>
5613                   goto Check_Next_Entity;
5614             end case;
5615
5616             --  A component has PI if it has no default expression and the
5617             --  component type has PI.
5618
5619             if No (Exp) then
5620                if not Has_Preelaborable_Initialization (Etype (Ent)) then
5621                   Has_PE := False;
5622                   exit;
5623                end if;
5624
5625             --  Require the default expression to be preelaborable
5626
5627             elsif not Is_Preelaborable_Expression (Exp) then
5628                Has_PE := False;
5629                exit;
5630             end if;
5631
5632          <<Check_Next_Entity>>
5633             Next_Entity (Ent);
5634          end loop;
5635       end Check_Components;
5636
5637    --  Start of processing for Has_Preelaborable_Initialization
5638
5639    begin
5640       --  Immediate return if already marked as known preelaborable init. This
5641       --  covers types for which this function has already been called once
5642       --  and returned True (in which case the result is cached), and also
5643       --  types to which a pragma Preelaborable_Initialization applies.
5644
5645       if Known_To_Have_Preelab_Init (E) then
5646          return True;
5647       end if;
5648
5649       --  If the type is a subtype representing a generic actual type, then
5650       --  test whether its base type has preelaborable initialization since
5651       --  the subtype representing the actual does not inherit this attribute
5652       --  from the actual or formal. (but maybe it should???)
5653
5654       if Is_Generic_Actual_Type (E) then
5655          return Has_Preelaborable_Initialization (Base_Type (E));
5656       end if;
5657
5658       --  All elementary types have preelaborable initialization
5659
5660       if Is_Elementary_Type (E) then
5661          Has_PE := True;
5662
5663       --  Array types have PI if the component type has PI
5664
5665       elsif Is_Array_Type (E) then
5666          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
5667
5668       --  A derived type has preelaborable initialization if its parent type
5669       --  has preelaborable initialization and (in the case of a derived record
5670       --  extension) if the non-inherited components all have preelaborable
5671       --  initialization. However, a user-defined controlled type with an
5672       --  overriding Initialize procedure does not have preelaborable
5673       --  initialization.
5674
5675       elsif Is_Derived_Type (E) then
5676
5677          --  If the derived type is a private extension then it doesn't have
5678          --  preelaborable initialization.
5679
5680          if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
5681             return False;
5682          end if;
5683
5684          --  First check whether ancestor type has preelaborable initialization
5685
5686          Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
5687
5688          --  If OK, check extension components (if any)
5689
5690          if Has_PE and then Is_Record_Type (E) then
5691             Check_Components (First_Entity (E));
5692          end if;
5693
5694          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
5695          --  with a user defined Initialize procedure does not have PI.
5696
5697          if Has_PE
5698            and then Is_Controlled (E)
5699            and then Has_Overriding_Initialize (E)
5700          then
5701             Has_PE := False;
5702          end if;
5703
5704       --  Private types not derived from a type having preelaborable init and
5705       --  that are not marked with pragma Preelaborable_Initialization do not
5706       --  have preelaborable initialization.
5707
5708       elsif Is_Private_Type (E) then
5709          return False;
5710
5711       --  Record type has PI if it is non private and all components have PI
5712
5713       elsif Is_Record_Type (E) then
5714          Has_PE := True;
5715          Check_Components (First_Entity (E));
5716
5717       --  Protected types must not have entries, and components must meet
5718       --  same set of rules as for record components.
5719
5720       elsif Is_Protected_Type (E) then
5721          if Has_Entries (E) then
5722             Has_PE := False;
5723          else
5724             Has_PE := True;
5725             Check_Components (First_Entity (E));
5726             Check_Components (First_Private_Entity (E));
5727          end if;
5728
5729       --  Type System.Address always has preelaborable initialization
5730
5731       elsif Is_RTE (E, RE_Address) then
5732          Has_PE := True;
5733
5734       --  In all other cases, type does not have preelaborable initialization
5735
5736       else
5737          return False;
5738       end if;
5739
5740       --  If type has preelaborable initialization, cache result
5741
5742       if Has_PE then
5743          Set_Known_To_Have_Preelab_Init (E);
5744       end if;
5745
5746       return Has_PE;
5747    end Has_Preelaborable_Initialization;
5748
5749    ---------------------------
5750    -- Has_Private_Component --
5751    ---------------------------
5752
5753    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
5754       Btype     : Entity_Id := Base_Type (Type_Id);
5755       Component : Entity_Id;
5756
5757    begin
5758       if Error_Posted (Type_Id)
5759         or else Error_Posted (Btype)
5760       then
5761          return False;
5762       end if;
5763
5764       if Is_Class_Wide_Type (Btype) then
5765          Btype := Root_Type (Btype);
5766       end if;
5767
5768       if Is_Private_Type (Btype) then
5769          declare
5770             UT : constant Entity_Id := Underlying_Type (Btype);
5771          begin
5772             if No (UT) then
5773                if No (Full_View (Btype)) then
5774                   return not Is_Generic_Type (Btype)
5775                     and then not Is_Generic_Type (Root_Type (Btype));
5776                else
5777                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
5778                end if;
5779             else
5780                return not Is_Frozen (UT) and then Has_Private_Component (UT);
5781             end if;
5782          end;
5783
5784       elsif Is_Array_Type (Btype) then
5785          return Has_Private_Component (Component_Type (Btype));
5786
5787       elsif Is_Record_Type (Btype) then
5788          Component := First_Component (Btype);
5789          while Present (Component) loop
5790             if Has_Private_Component (Etype (Component)) then
5791                return True;
5792             end if;
5793
5794             Next_Component (Component);
5795          end loop;
5796
5797          return False;
5798
5799       elsif Is_Protected_Type (Btype)
5800         and then Present (Corresponding_Record_Type (Btype))
5801       then
5802          return Has_Private_Component (Corresponding_Record_Type (Btype));
5803
5804       else
5805          return False;
5806       end if;
5807    end Has_Private_Component;
5808
5809    -----------------------------
5810    -- Has_Static_Array_Bounds --
5811    -----------------------------
5812
5813    function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
5814       Ndims : constant Nat := Number_Dimensions (Typ);
5815
5816       Index : Node_Id;
5817       Low   : Node_Id;
5818       High  : Node_Id;
5819
5820    begin
5821       --  Unconstrained types do not have static bounds
5822
5823       if not Is_Constrained (Typ) then
5824          return False;
5825       end if;
5826
5827       --  First treat string literals specially, as the lower bound and length
5828       --  of string literals are not stored like those of arrays.
5829
5830       --  A string literal always has static bounds
5831
5832       if Ekind (Typ) = E_String_Literal_Subtype then
5833          return True;
5834       end if;
5835
5836       --  Treat all dimensions in turn
5837
5838       Index := First_Index (Typ);
5839       for Indx in 1 .. Ndims loop
5840
5841          --  In case of an erroneous index which is not a discrete type, return
5842          --  that the type is not static.
5843
5844          if not Is_Discrete_Type (Etype (Index))
5845            or else Etype (Index) = Any_Type
5846          then
5847             return False;
5848          end if;
5849
5850          Get_Index_Bounds (Index, Low, High);
5851
5852          if Error_Posted (Low) or else Error_Posted (High) then
5853             return False;
5854          end if;
5855
5856          if Is_OK_Static_Expression (Low)
5857               and then
5858             Is_OK_Static_Expression (High)
5859          then
5860             null;
5861          else
5862             return False;
5863          end if;
5864
5865          Next (Index);
5866       end loop;
5867
5868       --  If we fall through the loop, all indexes matched
5869
5870       return True;
5871    end Has_Static_Array_Bounds;
5872
5873    ----------------
5874    -- Has_Stream --
5875    ----------------
5876
5877    function Has_Stream (T : Entity_Id) return Boolean is
5878       E : Entity_Id;
5879
5880    begin
5881       if No (T) then
5882          return False;
5883
5884       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
5885          return True;
5886
5887       elsif Is_Array_Type (T) then
5888          return Has_Stream (Component_Type (T));
5889
5890       elsif Is_Record_Type (T) then
5891          E := First_Component (T);
5892          while Present (E) loop
5893             if Has_Stream (Etype (E)) then
5894                return True;
5895             else
5896                Next_Component (E);
5897             end if;
5898          end loop;
5899
5900          return False;
5901
5902       elsif Is_Private_Type (T) then
5903          return Has_Stream (Underlying_Type (T));
5904
5905       else
5906          return False;
5907       end if;
5908    end Has_Stream;
5909
5910    ----------------
5911    -- Has_Suffix --
5912    ----------------
5913
5914    function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
5915    begin
5916       Get_Name_String (Chars (E));
5917       return Name_Buffer (Name_Len) = Suffix;
5918    end Has_Suffix;
5919
5920    --------------------------
5921    -- Has_Tagged_Component --
5922    --------------------------
5923
5924    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
5925       Comp : Entity_Id;
5926
5927    begin
5928       if Is_Private_Type (Typ)
5929         and then Present (Underlying_Type (Typ))
5930       then
5931          return Has_Tagged_Component (Underlying_Type (Typ));
5932
5933       elsif Is_Array_Type (Typ) then
5934          return Has_Tagged_Component (Component_Type (Typ));
5935
5936       elsif Is_Tagged_Type (Typ) then
5937          return True;
5938
5939       elsif Is_Record_Type (Typ) then
5940          Comp := First_Component (Typ);
5941          while Present (Comp) loop
5942             if Has_Tagged_Component (Etype (Comp)) then
5943                return True;
5944             end if;
5945
5946             Next_Component (Comp);
5947          end loop;
5948
5949          return False;
5950
5951       else
5952          return False;
5953       end if;
5954    end Has_Tagged_Component;
5955
5956    -------------------------
5957    -- Implementation_Kind --
5958    -------------------------
5959
5960    function Implementation_Kind (Subp : Entity_Id) return Name_Id is
5961       Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
5962    begin
5963       pragma Assert (Present (Impl_Prag));
5964       return
5965         Chars (Expression (Last (Pragma_Argument_Associations (Impl_Prag))));
5966    end Implementation_Kind;
5967
5968    --------------------------
5969    -- Implements_Interface --
5970    --------------------------
5971
5972    function Implements_Interface
5973      (Typ_Ent         : Entity_Id;
5974       Iface_Ent       : Entity_Id;
5975       Exclude_Parents : Boolean := False) return Boolean
5976    is
5977       Ifaces_List : Elist_Id;
5978       Elmt        : Elmt_Id;
5979       Iface       : Entity_Id := Base_Type (Iface_Ent);
5980       Typ         : Entity_Id := Base_Type (Typ_Ent);
5981
5982    begin
5983       if Is_Class_Wide_Type (Typ) then
5984          Typ := Root_Type (Typ);
5985       end if;
5986
5987       if not Has_Interfaces (Typ) then
5988          return False;
5989       end if;
5990
5991       if Is_Class_Wide_Type (Iface) then
5992          Iface := Root_Type (Iface);
5993       end if;
5994
5995       Collect_Interfaces (Typ, Ifaces_List);
5996
5997       Elmt := First_Elmt (Ifaces_List);
5998       while Present (Elmt) loop
5999          if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
6000            and then Exclude_Parents
6001          then
6002             null;
6003
6004          elsif Node (Elmt) = Iface then
6005             return True;
6006          end if;
6007
6008          Next_Elmt (Elmt);
6009       end loop;
6010
6011       return False;
6012    end Implements_Interface;
6013
6014    -----------------
6015    -- In_Instance --
6016    -----------------
6017
6018    function In_Instance return Boolean is
6019       Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
6020       S         : Entity_Id;
6021
6022    begin
6023       S := Current_Scope;
6024       while Present (S)
6025         and then S /= Standard_Standard
6026       loop
6027          if (Ekind (S) = E_Function
6028               or else Ekind (S) = E_Package
6029               or else Ekind (S) = E_Procedure)
6030            and then Is_Generic_Instance (S)
6031          then
6032             --  A child instance is always compiled in the context of a parent
6033             --  instance. Nevertheless, the actuals are not analyzed in an
6034             --  instance context. We detect this case by examining the current
6035             --  compilation unit, which must be a child instance, and checking
6036             --  that it is not currently on the scope stack.
6037
6038             if Is_Child_Unit (Curr_Unit)
6039               and then
6040                 Nkind (Unit (Cunit (Current_Sem_Unit)))
6041                   = N_Package_Instantiation
6042               and then not In_Open_Scopes (Curr_Unit)
6043             then
6044                return False;
6045             else
6046                return True;
6047             end if;
6048          end if;
6049
6050          S := Scope (S);
6051       end loop;
6052
6053       return False;
6054    end In_Instance;
6055
6056    ----------------------
6057    -- In_Instance_Body --
6058    ----------------------
6059
6060    function In_Instance_Body return Boolean is
6061       S : Entity_Id;
6062
6063    begin
6064       S := Current_Scope;
6065       while Present (S)
6066         and then S /= Standard_Standard
6067       loop
6068          if (Ekind (S) = E_Function
6069               or else Ekind (S) = E_Procedure)
6070            and then Is_Generic_Instance (S)
6071          then
6072             return True;
6073
6074          elsif Ekind (S) = E_Package
6075            and then In_Package_Body (S)
6076            and then Is_Generic_Instance (S)
6077          then
6078             return True;
6079          end if;
6080
6081          S := Scope (S);
6082       end loop;
6083
6084       return False;
6085    end In_Instance_Body;
6086
6087    -----------------------------
6088    -- In_Instance_Not_Visible --
6089    -----------------------------
6090
6091    function In_Instance_Not_Visible return Boolean is
6092       S : Entity_Id;
6093
6094    begin
6095       S := Current_Scope;
6096       while Present (S)
6097         and then S /= Standard_Standard
6098       loop
6099          if (Ekind (S) = E_Function
6100               or else Ekind (S) = E_Procedure)
6101            and then Is_Generic_Instance (S)
6102          then
6103             return True;
6104
6105          elsif Ekind (S) = E_Package
6106            and then (In_Package_Body (S) or else In_Private_Part (S))
6107            and then Is_Generic_Instance (S)
6108          then
6109             return True;
6110          end if;
6111
6112          S := Scope (S);
6113       end loop;
6114
6115       return False;
6116    end In_Instance_Not_Visible;
6117
6118    ------------------------------
6119    -- In_Instance_Visible_Part --
6120    ------------------------------
6121
6122    function In_Instance_Visible_Part return Boolean is
6123       S : Entity_Id;
6124
6125    begin
6126       S := Current_Scope;
6127       while Present (S)
6128         and then S /= Standard_Standard
6129       loop
6130          if Ekind (S) = E_Package
6131            and then Is_Generic_Instance (S)
6132            and then not In_Package_Body (S)
6133            and then not In_Private_Part (S)
6134          then
6135             return True;
6136          end if;
6137
6138          S := Scope (S);
6139       end loop;
6140
6141       return False;
6142    end In_Instance_Visible_Part;
6143
6144    ---------------------
6145    -- In_Package_Body --
6146    ---------------------
6147
6148    function In_Package_Body return Boolean is
6149       S : Entity_Id;
6150
6151    begin
6152       S := Current_Scope;
6153       while Present (S)
6154         and then S /= Standard_Standard
6155       loop
6156          if Ekind (S) = E_Package
6157            and then In_Package_Body (S)
6158          then
6159             return True;
6160          else
6161             S := Scope (S);
6162          end if;
6163       end loop;
6164
6165       return False;
6166    end In_Package_Body;
6167
6168    --------------------------------
6169    -- In_Parameter_Specification --
6170    --------------------------------
6171
6172    function In_Parameter_Specification (N : Node_Id) return Boolean is
6173       PN : Node_Id;
6174
6175    begin
6176       PN := Parent (N);
6177       while Present (PN) loop
6178          if Nkind (PN) = N_Parameter_Specification then
6179             return True;
6180          end if;
6181
6182          PN := Parent (PN);
6183       end loop;
6184
6185       return False;
6186    end In_Parameter_Specification;
6187
6188    --------------------------------------
6189    -- In_Subprogram_Or_Concurrent_Unit --
6190    --------------------------------------
6191
6192    function In_Subprogram_Or_Concurrent_Unit return Boolean is
6193       E : Entity_Id;
6194       K : Entity_Kind;
6195
6196    begin
6197       --  Use scope chain to check successively outer scopes
6198
6199       E := Current_Scope;
6200       loop
6201          K := Ekind (E);
6202
6203          if K in Subprogram_Kind
6204            or else K in Concurrent_Kind
6205            or else K in Generic_Subprogram_Kind
6206          then
6207             return True;
6208
6209          elsif E = Standard_Standard then
6210             return False;
6211          end if;
6212
6213          E := Scope (E);
6214       end loop;
6215    end In_Subprogram_Or_Concurrent_Unit;
6216
6217    ---------------------
6218    -- In_Visible_Part --
6219    ---------------------
6220
6221    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
6222    begin
6223       return
6224         Is_Package_Or_Generic_Package (Scope_Id)
6225           and then In_Open_Scopes (Scope_Id)
6226           and then not In_Package_Body (Scope_Id)
6227           and then not In_Private_Part (Scope_Id);
6228    end In_Visible_Part;
6229
6230    --------------------------------
6231    -- Incomplete_Or_Private_View --
6232    --------------------------------
6233
6234    function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is
6235       function Inspect_Decls
6236         (Decls : List_Id;
6237          Taft  : Boolean := False) return Entity_Id;
6238       --  Check whether a declarative region contains the incomplete or private
6239       --  view of Typ.
6240
6241       -------------------
6242       -- Inspect_Decls --
6243       -------------------
6244
6245       function Inspect_Decls
6246         (Decls : List_Id;
6247          Taft  : Boolean := False) return Entity_Id
6248       is
6249          Decl  : Node_Id;
6250          Match : Node_Id;
6251
6252       begin
6253          Decl := First (Decls);
6254          while Present (Decl) loop
6255             Match := Empty;
6256
6257             if Taft then
6258                if Nkind (Decl) = N_Incomplete_Type_Declaration then
6259                   Match := Defining_Identifier (Decl);
6260                end if;
6261
6262             else
6263                if Nkind_In (Decl, N_Private_Extension_Declaration,
6264                                   N_Private_Type_Declaration)
6265                then
6266                   Match := Defining_Identifier (Decl);
6267                end if;
6268             end if;
6269
6270             if Present (Match)
6271               and then Present (Full_View (Match))
6272               and then Full_View (Match) = Typ
6273             then
6274                return Match;
6275             end if;
6276
6277             Next (Decl);
6278          end loop;
6279
6280          return Empty;
6281       end Inspect_Decls;
6282
6283       --  Local variables
6284
6285       Prev : Entity_Id;
6286
6287    --  Start of processing for Incomplete_Or_Partial_View
6288
6289    begin
6290       --  Incomplete type case
6291
6292       Prev := Current_Entity_In_Scope (Typ);
6293
6294       if Present (Prev)
6295         and then Is_Incomplete_Type (Prev)
6296         and then Present (Full_View (Prev))
6297         and then Full_View (Prev) = Typ
6298       then
6299          return Prev;
6300       end if;
6301
6302       --  Private or Taft amendment type case
6303
6304       declare
6305          Pkg      : constant Entity_Id := Scope (Typ);
6306          Pkg_Decl : Node_Id := Pkg;
6307
6308       begin
6309          if Ekind (Pkg) = E_Package then
6310             while Nkind (Pkg_Decl) /= N_Package_Specification loop
6311                Pkg_Decl := Parent (Pkg_Decl);
6312             end loop;
6313
6314             --  It is knows that Typ has a private view, look for it in the
6315             --  visible declarations of the enclosing scope. A special case
6316             --  of this is when the two views have been exchanged - the full
6317             --  appears earlier than the private.
6318
6319             if Has_Private_Declaration (Typ) then
6320                Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
6321
6322                --  Exchanged view case, look in the private declarations
6323
6324                if No (Prev) then
6325                   Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
6326                end if;
6327
6328                return Prev;
6329
6330             --  Otherwise if this is the package body, then Typ is a potential
6331             --  Taft amendment type. The incomplete view should be located in
6332             --  the private declarations of the enclosing scope.
6333
6334             elsif In_Package_Body (Pkg) then
6335                return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
6336             end if;
6337          end if;
6338       end;
6339
6340       --  The type has no incomplete or private view
6341
6342       return Empty;
6343    end Incomplete_Or_Private_View;
6344
6345    ---------------------------------
6346    -- Insert_Explicit_Dereference --
6347    ---------------------------------
6348
6349    procedure Insert_Explicit_Dereference (N : Node_Id) is
6350       New_Prefix : constant Node_Id := Relocate_Node (N);
6351       Ent        : Entity_Id := Empty;
6352       Pref       : Node_Id;
6353       I          : Interp_Index;
6354       It         : Interp;
6355       T          : Entity_Id;
6356
6357    begin
6358       Save_Interps (N, New_Prefix);
6359
6360       Rewrite (N,
6361         Make_Explicit_Dereference (Sloc (Parent (N)),
6362           Prefix => New_Prefix));
6363
6364       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
6365
6366       if Is_Overloaded (New_Prefix) then
6367
6368          --  The dereference is also overloaded, and its interpretations are
6369          --  the designated types of the interpretations of the original node.
6370
6371          Set_Etype (N, Any_Type);
6372
6373          Get_First_Interp (New_Prefix, I, It);
6374          while Present (It.Nam) loop
6375             T := It.Typ;
6376
6377             if Is_Access_Type (T) then
6378                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
6379             end if;
6380
6381             Get_Next_Interp (I, It);
6382          end loop;
6383
6384          End_Interp_List;
6385
6386       else
6387          --  Prefix is unambiguous: mark the original prefix (which might
6388          --  Come_From_Source) as a reference, since the new (relocated) one
6389          --  won't be taken into account.
6390
6391          if Is_Entity_Name (New_Prefix) then
6392             Ent := Entity (New_Prefix);
6393             Pref := New_Prefix;
6394
6395          --  For a retrieval of a subcomponent of some composite object,
6396          --  retrieve the ultimate entity if there is one.
6397
6398          elsif Nkind (New_Prefix) = N_Selected_Component
6399            or else Nkind (New_Prefix) = N_Indexed_Component
6400          then
6401             Pref := Prefix (New_Prefix);
6402             while Present (Pref)
6403               and then
6404                 (Nkind (Pref) = N_Selected_Component
6405                   or else Nkind (Pref) = N_Indexed_Component)
6406             loop
6407                Pref := Prefix (Pref);
6408             end loop;
6409
6410             if Present (Pref) and then Is_Entity_Name (Pref) then
6411                Ent := Entity (Pref);
6412             end if;
6413          end if;
6414
6415          --  Place the reference on the entity node
6416
6417          if Present (Ent) then
6418             Generate_Reference (Ent, Pref);
6419          end if;
6420       end if;
6421    end Insert_Explicit_Dereference;
6422
6423    ------------------------------------------
6424    -- Inspect_Deferred_Constant_Completion --
6425    ------------------------------------------
6426
6427    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
6428       Decl   : Node_Id;
6429
6430    begin
6431       Decl := First (Decls);
6432       while Present (Decl) loop
6433
6434          --  Deferred constant signature
6435
6436          if Nkind (Decl) = N_Object_Declaration
6437            and then Constant_Present (Decl)
6438            and then No (Expression (Decl))
6439
6440             --  No need to check internally generated constants
6441
6442            and then Comes_From_Source (Decl)
6443
6444             --  The constant is not completed. A full object declaration or a
6445             --  pragma Import complete a deferred constant.
6446
6447            and then not Has_Completion (Defining_Identifier (Decl))
6448          then
6449             Error_Msg_N
6450               ("constant declaration requires initialization expression",
6451               Defining_Identifier (Decl));
6452          end if;
6453
6454          Decl := Next (Decl);
6455       end loop;
6456    end Inspect_Deferred_Constant_Completion;
6457
6458    -----------------------------
6459    -- Is_Actual_Out_Parameter --
6460    -----------------------------
6461
6462    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
6463       Formal : Entity_Id;
6464       Call   : Node_Id;
6465    begin
6466       Find_Actual (N, Formal, Call);
6467       return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
6468    end Is_Actual_Out_Parameter;
6469
6470    -------------------------
6471    -- Is_Actual_Parameter --
6472    -------------------------
6473
6474    function Is_Actual_Parameter (N : Node_Id) return Boolean is
6475       PK : constant Node_Kind := Nkind (Parent (N));
6476
6477    begin
6478       case PK is
6479          when N_Parameter_Association =>
6480             return N = Explicit_Actual_Parameter (Parent (N));
6481
6482          when N_Function_Call | N_Procedure_Call_Statement =>
6483             return Is_List_Member (N)
6484               and then
6485                 List_Containing (N) = Parameter_Associations (Parent (N));
6486
6487          when others =>
6488             return False;
6489       end case;
6490    end Is_Actual_Parameter;
6491
6492    --------------------------------
6493    -- Is_Actual_Tagged_Parameter --
6494    --------------------------------
6495
6496    function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
6497       Formal : Entity_Id;
6498       Call   : Node_Id;
6499    begin
6500       Find_Actual (N, Formal, Call);
6501       return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
6502    end Is_Actual_Tagged_Parameter;
6503
6504    ---------------------
6505    -- Is_Aliased_View --
6506    ---------------------
6507
6508    function Is_Aliased_View (Obj : Node_Id) return Boolean is
6509       E : Entity_Id;
6510
6511    begin
6512       if Is_Entity_Name (Obj) then
6513          E := Entity (Obj);
6514
6515          if Is_Object (E) and then not Is_Aliased (E) then
6516             Check_Restriction (No_Implicit_Aliasing, Obj);
6517          end if;
6518
6519          return
6520            (Is_Object (E)
6521              and then
6522                (Is_Aliased (E)
6523                   or else (Present (Renamed_Object (E))
6524                              and then Is_Aliased_View (Renamed_Object (E)))))
6525
6526            or else ((Is_Formal (E)
6527                       or else Ekind (E) = E_Generic_In_Out_Parameter
6528                       or else Ekind (E) = E_Generic_In_Parameter)
6529                     and then Is_Tagged_Type (Etype (E)))
6530
6531            or else (Is_Concurrent_Type (E)
6532                      and then In_Open_Scopes (E))
6533
6534             --  Current instance of type, either directly or as rewritten
6535             --  reference to the current object.
6536
6537            or else (Is_Entity_Name (Original_Node (Obj))
6538                      and then Present (Entity (Original_Node (Obj)))
6539                      and then Is_Type (Entity (Original_Node (Obj))))
6540
6541            or else (Is_Type (E) and then E = Current_Scope)
6542
6543            or else (Is_Incomplete_Or_Private_Type (E)
6544                      and then Full_View (E) = Current_Scope);
6545
6546       elsif Nkind (Obj) = N_Selected_Component then
6547          return Is_Aliased (Entity (Selector_Name (Obj)));
6548
6549       elsif Nkind (Obj) = N_Indexed_Component then
6550          return Has_Aliased_Components (Etype (Prefix (Obj)))
6551            or else
6552              (Is_Access_Type (Etype (Prefix (Obj)))
6553                and then Has_Aliased_Components
6554                           (Designated_Type (Etype (Prefix (Obj)))));
6555
6556       elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
6557          return Is_Tagged_Type (Etype (Obj))
6558            and then Is_Aliased_View (Expression (Obj));
6559
6560       elsif Nkind (Obj) = N_Explicit_Dereference then
6561          return Nkind (Original_Node (Obj)) /= N_Function_Call;
6562
6563       else
6564          return False;
6565       end if;
6566    end Is_Aliased_View;
6567
6568    -------------------------
6569    -- Is_Ancestor_Package --
6570    -------------------------
6571
6572    function Is_Ancestor_Package
6573      (E1 : Entity_Id;
6574       E2 : Entity_Id) return Boolean
6575    is
6576       Par : Entity_Id;
6577
6578    begin
6579       Par := E2;
6580       while Present (Par)
6581         and then Par /= Standard_Standard
6582       loop
6583          if Par = E1 then
6584             return True;
6585          end if;
6586
6587          Par := Scope (Par);
6588       end loop;
6589
6590       return False;
6591    end Is_Ancestor_Package;
6592
6593    ----------------------
6594    -- Is_Atomic_Object --
6595    ----------------------
6596
6597    function Is_Atomic_Object (N : Node_Id) return Boolean is
6598
6599       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
6600       --  Determines if given object has atomic components
6601
6602       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
6603       --  If prefix is an implicit dereference, examine designated type
6604
6605       ----------------------
6606       -- Is_Atomic_Prefix --
6607       ----------------------
6608
6609       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
6610       begin
6611          if Is_Access_Type (Etype (N)) then
6612             return
6613               Has_Atomic_Components (Designated_Type (Etype (N)));
6614          else
6615             return Object_Has_Atomic_Components (N);
6616          end if;
6617       end Is_Atomic_Prefix;
6618
6619       ----------------------------------
6620       -- Object_Has_Atomic_Components --
6621       ----------------------------------
6622
6623       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
6624       begin
6625          if Has_Atomic_Components (Etype (N))
6626            or else Is_Atomic (Etype (N))
6627          then
6628             return True;
6629
6630          elsif Is_Entity_Name (N)
6631            and then (Has_Atomic_Components (Entity (N))
6632                       or else Is_Atomic (Entity (N)))
6633          then
6634             return True;
6635
6636          elsif Nkind (N) = N_Indexed_Component
6637            or else Nkind (N) = N_Selected_Component
6638          then
6639             return Is_Atomic_Prefix (Prefix (N));
6640
6641          else
6642             return False;
6643          end if;
6644       end Object_Has_Atomic_Components;
6645
6646    --  Start of processing for Is_Atomic_Object
6647
6648    begin
6649       --  Predicate is not relevant to subprograms
6650
6651       if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
6652          return False;
6653
6654       elsif Is_Atomic (Etype (N))
6655         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
6656       then
6657          return True;
6658
6659       elsif Nkind (N) = N_Indexed_Component
6660         or else Nkind (N) = N_Selected_Component
6661       then
6662          return Is_Atomic_Prefix (Prefix (N));
6663
6664       else
6665          return False;
6666       end if;
6667    end Is_Atomic_Object;
6668
6669    -----------------------------
6670    -- Is_Concurrent_Interface --
6671    -----------------------------
6672
6673    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
6674    begin
6675       return
6676         Is_Interface (T)
6677           and then
6678             (Is_Protected_Interface (T)
6679                or else Is_Synchronized_Interface (T)
6680                or else Is_Task_Interface (T));
6681    end Is_Concurrent_Interface;
6682
6683    --------------------------------------
6684    -- Is_Controlling_Limited_Procedure --
6685    --------------------------------------
6686
6687    function Is_Controlling_Limited_Procedure
6688      (Proc_Nam : Entity_Id) return Boolean
6689    is
6690       Param_Typ : Entity_Id := Empty;
6691
6692    begin
6693       if Ekind (Proc_Nam) = E_Procedure
6694         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
6695       then
6696          Param_Typ := Etype (Parameter_Type (First (
6697                         Parameter_Specifications (Parent (Proc_Nam)))));
6698
6699       --  In this case where an Itype was created, the procedure call has been
6700       --  rewritten.
6701
6702       elsif Present (Associated_Node_For_Itype (Proc_Nam))
6703         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
6704         and then
6705           Present (Parameter_Associations
6706                      (Associated_Node_For_Itype (Proc_Nam)))
6707       then
6708          Param_Typ :=
6709            Etype (First (Parameter_Associations
6710                           (Associated_Node_For_Itype (Proc_Nam))));
6711       end if;
6712
6713       if Present (Param_Typ) then
6714          return
6715            Is_Interface (Param_Typ)
6716              and then Is_Limited_Record (Param_Typ);
6717       end if;
6718
6719       return False;
6720    end Is_Controlling_Limited_Procedure;
6721
6722    -----------------------------
6723    -- Is_CPP_Constructor_Call --
6724    -----------------------------
6725
6726    function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
6727    begin
6728       return Nkind (N) = N_Function_Call
6729         and then Is_CPP_Class (Etype (Etype (N)))
6730         and then Is_Constructor (Entity (Name (N)))
6731         and then Is_Imported (Entity (Name (N)));
6732    end Is_CPP_Constructor_Call;
6733
6734    -----------------
6735    -- Is_Delegate --
6736    -----------------
6737
6738    function Is_Delegate (T : Entity_Id) return Boolean is
6739       Desig_Type : Entity_Id;
6740
6741    begin
6742       if VM_Target /= CLI_Target then
6743          return False;
6744       end if;
6745
6746       --  Access-to-subprograms are delegates in CIL
6747
6748       if Ekind (T) = E_Access_Subprogram_Type then
6749          return True;
6750       end if;
6751
6752       if Ekind (T) not in Access_Kind then
6753
6754          --  A delegate is a managed pointer. If no designated type is defined
6755          --  it means that it's not a delegate.
6756
6757          return False;
6758       end if;
6759
6760       Desig_Type := Etype (Directly_Designated_Type (T));
6761
6762       if not Is_Tagged_Type (Desig_Type) then
6763          return False;
6764       end if;
6765
6766       --  Test if the type is inherited from [mscorlib]System.Delegate
6767
6768       while Etype (Desig_Type) /= Desig_Type loop
6769          if Chars (Scope (Desig_Type)) /= No_Name
6770            and then Is_Imported (Scope (Desig_Type))
6771            and then Get_Name_String (Chars (Scope (Desig_Type))) = "delegate"
6772          then
6773             return True;
6774          end if;
6775
6776          Desig_Type := Etype (Desig_Type);
6777       end loop;
6778
6779       return False;
6780    end Is_Delegate;
6781
6782    ----------------------------------------------
6783    -- Is_Dependent_Component_Of_Mutable_Object --
6784    ----------------------------------------------
6785
6786    function Is_Dependent_Component_Of_Mutable_Object
6787      (Object : Node_Id) return Boolean
6788    is
6789       P           : Node_Id;
6790       Prefix_Type : Entity_Id;
6791       P_Aliased   : Boolean := False;
6792       Comp        : Entity_Id;
6793
6794       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
6795       --  Returns True if and only if Comp is declared within a variant part
6796
6797       --------------------------------
6798       -- Is_Declared_Within_Variant --
6799       --------------------------------
6800
6801       function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
6802          Comp_Decl : constant Node_Id   := Parent (Comp);
6803          Comp_List : constant Node_Id   := Parent (Comp_Decl);
6804       begin
6805          return Nkind (Parent (Comp_List)) = N_Variant;
6806       end Is_Declared_Within_Variant;
6807
6808    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
6809
6810    begin
6811       if Is_Variable (Object) then
6812
6813          if Nkind (Object) = N_Selected_Component then
6814             P := Prefix (Object);
6815             Prefix_Type := Etype (P);
6816
6817             if Is_Entity_Name (P) then
6818
6819                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
6820                   Prefix_Type := Base_Type (Prefix_Type);
6821                end if;
6822
6823                if Is_Aliased (Entity (P)) then
6824                   P_Aliased := True;
6825                end if;
6826
6827             --  A discriminant check on a selected component may be expanded
6828             --  into a dereference when removing side-effects. Recover the
6829             --  original node and its type, which may be unconstrained.
6830
6831             elsif Nkind (P) = N_Explicit_Dereference
6832               and then not (Comes_From_Source (P))
6833             then
6834                P := Original_Node (P);
6835                Prefix_Type := Etype (P);
6836
6837             else
6838                --  Check for prefix being an aliased component???
6839
6840                null;
6841
6842             end if;
6843
6844             --  A heap object is constrained by its initial value
6845
6846             --  Ada 2005 (AI-363): Always assume the object could be mutable in
6847             --  the dereferenced case, since the access value might denote an
6848             --  unconstrained aliased object, whereas in Ada 95 the designated
6849             --  object is guaranteed to be constrained. A worst-case assumption
6850             --  has to apply in Ada 2005 because we can't tell at compile time
6851             --  whether the object is "constrained by its initial value"
6852             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are
6853             --  semantic rules -- these rules are acknowledged to need fixing).
6854
6855             if Ada_Version < Ada_2005 then
6856                if Is_Access_Type (Prefix_Type)
6857                  or else Nkind (P) = N_Explicit_Dereference
6858                then
6859                   return False;
6860                end if;
6861
6862             elsif Ada_Version >= Ada_2005 then
6863                if Is_Access_Type (Prefix_Type) then
6864
6865                   --  If the access type is pool-specific, and there is no
6866                   --  constrained partial view of the designated type, then the
6867                   --  designated object is known to be constrained.
6868
6869                   if Ekind (Prefix_Type) = E_Access_Type
6870                     and then not Has_Constrained_Partial_View
6871                                    (Designated_Type (Prefix_Type))
6872                   then
6873                      return False;
6874
6875                   --  Otherwise (general access type, or there is a constrained
6876                   --  partial view of the designated type), we need to check
6877                   --  based on the designated type.
6878
6879                   else
6880                      Prefix_Type := Designated_Type (Prefix_Type);
6881                   end if;
6882                end if;
6883             end if;
6884
6885             Comp :=
6886               Original_Record_Component (Entity (Selector_Name (Object)));
6887
6888             --  As per AI-0017, the renaming is illegal in a generic body, even
6889             --  if the subtype is indefinite.
6890
6891             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
6892
6893             if not Is_Constrained (Prefix_Type)
6894               and then (not Is_Indefinite_Subtype (Prefix_Type)
6895                          or else
6896                           (Is_Generic_Type (Prefix_Type)
6897                             and then Ekind (Current_Scope) = E_Generic_Package
6898                             and then In_Package_Body (Current_Scope)))
6899
6900               and then (Is_Declared_Within_Variant (Comp)
6901                           or else Has_Discriminant_Dependent_Constraint (Comp))
6902               and then (not P_Aliased or else Ada_Version >= Ada_2005)
6903             then
6904                return True;
6905
6906             else
6907                return
6908                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6909
6910             end if;
6911
6912          elsif Nkind (Object) = N_Indexed_Component
6913            or else Nkind (Object) = N_Slice
6914          then
6915             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
6916
6917          --  A type conversion that Is_Variable is a view conversion:
6918          --  go back to the denoted object.
6919
6920          elsif Nkind (Object) = N_Type_Conversion then
6921             return
6922               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
6923          end if;
6924       end if;
6925
6926       return False;
6927    end Is_Dependent_Component_Of_Mutable_Object;
6928
6929    ---------------------
6930    -- Is_Dereferenced --
6931    ---------------------
6932
6933    function Is_Dereferenced (N : Node_Id) return Boolean is
6934       P : constant Node_Id := Parent (N);
6935    begin
6936       return
6937          (Nkind (P) = N_Selected_Component
6938             or else
6939           Nkind (P) = N_Explicit_Dereference
6940             or else
6941           Nkind (P) = N_Indexed_Component
6942             or else
6943           Nkind (P) = N_Slice)
6944         and then Prefix (P) = N;
6945    end Is_Dereferenced;
6946
6947    ----------------------
6948    -- Is_Descendent_Of --
6949    ----------------------
6950
6951    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
6952       T    : Entity_Id;
6953       Etyp : Entity_Id;
6954
6955    begin
6956       pragma Assert (Nkind (T1) in N_Entity);
6957       pragma Assert (Nkind (T2) in N_Entity);
6958
6959       T := Base_Type (T1);
6960
6961       --  Immediate return if the types match
6962
6963       if T = T2 then
6964          return True;
6965
6966       --  Comment needed here ???
6967
6968       elsif Ekind (T) = E_Class_Wide_Type then
6969          return Etype (T) = T2;
6970
6971       --  All other cases
6972
6973       else
6974          loop
6975             Etyp := Etype (T);
6976
6977             --  Done if we found the type we are looking for
6978
6979             if Etyp = T2 then
6980                return True;
6981
6982             --  Done if no more derivations to check
6983
6984             elsif T = T1
6985               or else T = Etyp
6986             then
6987                return False;
6988
6989             --  Following test catches error cases resulting from prev errors
6990
6991             elsif No (Etyp) then
6992                return False;
6993
6994             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
6995                return False;
6996
6997             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
6998                return False;
6999             end if;
7000
7001             T := Base_Type (Etyp);
7002          end loop;
7003       end if;
7004    end Is_Descendent_Of;
7005
7006    ----------------------------
7007    -- Is_Expression_Function --
7008    ----------------------------
7009
7010    function Is_Expression_Function (Subp : Entity_Id) return Boolean is
7011       Decl : constant Node_Id := Unit_Declaration_Node (Subp);
7012
7013    begin
7014       return Ekind (Subp) = E_Function
7015         and then Nkind (Decl) = N_Subprogram_Declaration
7016         and then
7017           (Nkind (Original_Node (Decl)) = N_Expression_Function
7018             or else
7019               (Present (Corresponding_Body (Decl))
7020                 and then
7021                   Nkind (Original_Node
7022                      (Unit_Declaration_Node (Corresponding_Body (Decl))))
7023                  = N_Expression_Function));
7024    end Is_Expression_Function;
7025
7026    --------------
7027    -- Is_False --
7028    --------------
7029
7030    function Is_False (U : Uint) return Boolean is
7031    begin
7032       return (U = 0);
7033    end Is_False;
7034
7035    ---------------------------
7036    -- Is_Fixed_Model_Number --
7037    ---------------------------
7038
7039    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
7040       S : constant Ureal := Small_Value (T);
7041       M : Urealp.Save_Mark;
7042       R : Boolean;
7043    begin
7044       M := Urealp.Mark;
7045       R := (U = UR_Trunc (U / S) * S);
7046       Urealp.Release (M);
7047       return R;
7048    end Is_Fixed_Model_Number;
7049
7050    -------------------------------
7051    -- Is_Fully_Initialized_Type --
7052    -------------------------------
7053
7054    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
7055    begin
7056       if Is_Scalar_Type (Typ) then
7057          return False;
7058
7059       elsif Is_Access_Type (Typ) then
7060          return True;
7061
7062       elsif Is_Array_Type (Typ) then
7063          if Is_Fully_Initialized_Type (Component_Type (Typ)) then
7064             return True;
7065          end if;
7066
7067          --  An interesting case, if we have a constrained type one of whose
7068          --  bounds is known to be null, then there are no elements to be
7069          --  initialized, so all the elements are initialized!
7070
7071          if Is_Constrained (Typ) then
7072             declare
7073                Indx     : Node_Id;
7074                Indx_Typ : Entity_Id;
7075                Lbd, Hbd : Node_Id;
7076
7077             begin
7078                Indx := First_Index (Typ);
7079                while Present (Indx) loop
7080                   if Etype (Indx) = Any_Type then
7081                      return False;
7082
7083                   --  If index is a range, use directly
7084
7085                   elsif Nkind (Indx) = N_Range then
7086                      Lbd := Low_Bound  (Indx);
7087                      Hbd := High_Bound (Indx);
7088
7089                   else
7090                      Indx_Typ := Etype (Indx);
7091
7092                      if Is_Private_Type (Indx_Typ)  then
7093                         Indx_Typ := Full_View (Indx_Typ);
7094                      end if;
7095
7096                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
7097                         return False;
7098                      else
7099                         Lbd := Type_Low_Bound  (Indx_Typ);
7100                         Hbd := Type_High_Bound (Indx_Typ);
7101                      end if;
7102                   end if;
7103
7104                   if Compile_Time_Known_Value (Lbd)
7105                     and then Compile_Time_Known_Value (Hbd)
7106                   then
7107                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
7108                         return True;
7109                      end if;
7110                   end if;
7111
7112                   Next_Index (Indx);
7113                end loop;
7114             end;
7115          end if;
7116
7117          --  If no null indexes, then type is not fully initialized
7118
7119          return False;
7120
7121       --  Record types
7122
7123       elsif Is_Record_Type (Typ) then
7124          if Has_Discriminants (Typ)
7125            and then
7126              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
7127            and then Is_Fully_Initialized_Variant (Typ)
7128          then
7129             return True;
7130          end if;
7131
7132          --  Controlled records are considered to be fully initialized if
7133          --  there is a user defined Initialize routine. This may not be
7134          --  entirely correct, but as the spec notes, we are guessing here
7135          --  what is best from the point of view of issuing warnings.
7136
7137          if Is_Controlled (Typ) then
7138             declare
7139                Utyp : constant Entity_Id := Underlying_Type (Typ);
7140
7141             begin
7142                if Present (Utyp) then
7143                   declare
7144                      Init : constant Entity_Id :=
7145                               (Find_Prim_Op
7146                                  (Underlying_Type (Typ), Name_Initialize));
7147
7148                   begin
7149                      if Present (Init)
7150                        and then Comes_From_Source (Init)
7151                        and then not
7152                          Is_Predefined_File_Name
7153                            (File_Name (Get_Source_File_Index (Sloc (Init))))
7154                      then
7155                         return True;
7156
7157                      elsif Has_Null_Extension (Typ)
7158                         and then
7159                           Is_Fully_Initialized_Type
7160                             (Etype (Base_Type (Typ)))
7161                      then
7162                         return True;
7163                      end if;
7164                   end;
7165                end if;
7166             end;
7167          end if;
7168
7169          --  Otherwise see if all record components are initialized
7170
7171          declare
7172             Ent : Entity_Id;
7173
7174          begin
7175             Ent := First_Entity (Typ);
7176             while Present (Ent) loop
7177                if Ekind (Ent) = E_Component
7178                  and then (No (Parent (Ent))
7179                              or else No (Expression (Parent (Ent))))
7180                  and then not Is_Fully_Initialized_Type (Etype (Ent))
7181
7182                   --  Special VM case for tag components, which need to be
7183                   --  defined in this case, but are never initialized as VMs
7184                   --  are using other dispatching mechanisms. Ignore this
7185                   --  uninitialized case. Note that this applies both to the
7186                   --  uTag entry and the main vtable pointer (CPP_Class case).
7187
7188                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
7189                then
7190                   return False;
7191                end if;
7192
7193                Next_Entity (Ent);
7194             end loop;
7195          end;
7196
7197          --  No uninitialized components, so type is fully initialized.
7198          --  Note that this catches the case of no components as well.
7199
7200          return True;
7201
7202       elsif Is_Concurrent_Type (Typ) then
7203          return True;
7204
7205       elsif Is_Private_Type (Typ) then
7206          declare
7207             U : constant Entity_Id := Underlying_Type (Typ);
7208
7209          begin
7210             if No (U) then
7211                return False;
7212             else
7213                return Is_Fully_Initialized_Type (U);
7214             end if;
7215          end;
7216
7217       else
7218          return False;
7219       end if;
7220    end Is_Fully_Initialized_Type;
7221
7222    ----------------------------------
7223    -- Is_Fully_Initialized_Variant --
7224    ----------------------------------
7225
7226    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
7227       Loc           : constant Source_Ptr := Sloc (Typ);
7228       Constraints   : constant List_Id    := New_List;
7229       Components    : constant Elist_Id   := New_Elmt_List;
7230       Comp_Elmt     : Elmt_Id;
7231       Comp_Id       : Node_Id;
7232       Comp_List     : Node_Id;
7233       Discr         : Entity_Id;
7234       Discr_Val     : Node_Id;
7235
7236       Report_Errors : Boolean;
7237       pragma Warnings (Off, Report_Errors);
7238
7239    begin
7240       if Serious_Errors_Detected > 0 then
7241          return False;
7242       end if;
7243
7244       if Is_Record_Type (Typ)
7245         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
7246         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
7247       then
7248          Comp_List := Component_List (Type_Definition (Parent (Typ)));
7249
7250          Discr := First_Discriminant (Typ);
7251          while Present (Discr) loop
7252             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
7253                Discr_Val := Expression (Parent (Discr));
7254
7255                if Present (Discr_Val)
7256                  and then Is_OK_Static_Expression (Discr_Val)
7257                then
7258                   Append_To (Constraints,
7259                     Make_Component_Association (Loc,
7260                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
7261                       Expression => New_Copy (Discr_Val)));
7262                else
7263                   return False;
7264                end if;
7265             else
7266                return False;
7267             end if;
7268
7269             Next_Discriminant (Discr);
7270          end loop;
7271
7272          Gather_Components
7273            (Typ           => Typ,
7274             Comp_List     => Comp_List,
7275             Governed_By   => Constraints,
7276             Into          => Components,
7277             Report_Errors => Report_Errors);
7278
7279          --  Check that each component present is fully initialized
7280
7281          Comp_Elmt := First_Elmt (Components);
7282          while Present (Comp_Elmt) loop
7283             Comp_Id := Node (Comp_Elmt);
7284
7285             if Ekind (Comp_Id) = E_Component
7286               and then (No (Parent (Comp_Id))
7287                          or else No (Expression (Parent (Comp_Id))))
7288               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
7289             then
7290                return False;
7291             end if;
7292
7293             Next_Elmt (Comp_Elmt);
7294          end loop;
7295
7296          return True;
7297
7298       elsif Is_Private_Type (Typ) then
7299          declare
7300             U : constant Entity_Id := Underlying_Type (Typ);
7301
7302          begin
7303             if No (U) then
7304                return False;
7305             else
7306                return Is_Fully_Initialized_Variant (U);
7307             end if;
7308          end;
7309       else
7310          return False;
7311       end if;
7312    end Is_Fully_Initialized_Variant;
7313
7314    -----------------
7315    -- Is_Iterator --
7316    -----------------
7317
7318    function Is_Iterator (Typ : Entity_Id) return Boolean is
7319       Ifaces_List : Elist_Id;
7320       Iface_Elmt  : Elmt_Id;
7321       Iface       : Entity_Id;
7322
7323    begin
7324       if Is_Class_Wide_Type (Typ)
7325         and then
7326           (Chars (Etype (Typ)) = Name_Forward_Iterator
7327              or else
7328            Chars (Etype (Typ)) = Name_Reversible_Iterator)
7329         and then
7330           Is_Predefined_File_Name
7331             (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
7332       then
7333          return True;
7334
7335       elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
7336          return False;
7337
7338       else
7339          Collect_Interfaces (Typ, Ifaces_List);
7340
7341          Iface_Elmt := First_Elmt (Ifaces_List);
7342          while Present (Iface_Elmt) loop
7343             Iface := Node (Iface_Elmt);
7344             if Chars (Iface) = Name_Forward_Iterator
7345               and then
7346                 Is_Predefined_File_Name
7347                   (Unit_File_Name (Get_Source_Unit (Iface)))
7348             then
7349                return True;
7350             end if;
7351
7352             Next_Elmt (Iface_Elmt);
7353          end loop;
7354
7355          return False;
7356       end if;
7357    end Is_Iterator;
7358
7359    ------------
7360    -- Is_LHS --
7361    ------------
7362
7363    --  We seem to have a lot of overlapping functions that do similar things
7364    --  (testing for left hand sides or lvalues???). Anyway, since this one is
7365    --  purely syntactic, it should be in Sem_Aux I would think???
7366
7367    function Is_LHS (N : Node_Id) return Boolean is
7368       P : constant Node_Id := Parent (N);
7369
7370    begin
7371       if Nkind (P) = N_Assignment_Statement then
7372          return Name (P) = N;
7373
7374       elsif
7375         Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
7376       then
7377          return N = Prefix (P) and then Is_LHS (P);
7378
7379       else
7380          return False;
7381       end if;
7382    end Is_LHS;
7383
7384    ----------------------------
7385    -- Is_Inherited_Operation --
7386    ----------------------------
7387
7388    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
7389       Kind : constant Node_Kind := Nkind (Parent (E));
7390    begin
7391       pragma Assert (Is_Overloadable (E));
7392       return Kind = N_Full_Type_Declaration
7393         or else Kind = N_Private_Extension_Declaration
7394         or else Kind = N_Subtype_Declaration
7395         or else (Ekind (E) = E_Enumeration_Literal
7396                   and then Is_Derived_Type (Etype (E)));
7397    end Is_Inherited_Operation;
7398
7399    -------------------------------------
7400    -- Is_Inherited_Operation_For_Type --
7401    -------------------------------------
7402
7403    function Is_Inherited_Operation_For_Type
7404      (E : Entity_Id; Typ : Entity_Id) return Boolean
7405    is
7406    begin
7407       return Is_Inherited_Operation (E)
7408         and then Etype (Parent (E)) = Typ;
7409    end Is_Inherited_Operation_For_Type;
7410
7411    -----------------------------
7412    -- Is_Library_Level_Entity --
7413    -----------------------------
7414
7415    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
7416    begin
7417       --  The following is a small optimization, and it also properly handles
7418       --  discriminals, which in task bodies might appear in expressions before
7419       --  the corresponding procedure has been created, and which therefore do
7420       --  not have an assigned scope.
7421
7422       if Is_Formal (E) then
7423          return False;
7424       end if;
7425
7426       --  Normal test is simply that the enclosing dynamic scope is Standard
7427
7428       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
7429    end Is_Library_Level_Entity;
7430
7431    ---------------------------------
7432    -- Is_Local_Variable_Reference --
7433    ---------------------------------
7434
7435    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
7436    begin
7437       if not Is_Entity_Name (Expr) then
7438          return False;
7439
7440       else
7441          declare
7442             Ent : constant Entity_Id := Entity (Expr);
7443             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
7444          begin
7445             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
7446                return False;
7447             else
7448                return Present (Sub) and then Sub = Current_Subprogram;
7449             end if;
7450          end;
7451       end if;
7452    end Is_Local_Variable_Reference;
7453
7454    -------------------------
7455    -- Is_Object_Reference --
7456    -------------------------
7457
7458    function Is_Object_Reference (N : Node_Id) return Boolean is
7459    begin
7460       if Is_Entity_Name (N) then
7461          return Present (Entity (N)) and then Is_Object (Entity (N));
7462
7463       else
7464          case Nkind (N) is
7465             when N_Indexed_Component | N_Slice =>
7466                return
7467                  Is_Object_Reference (Prefix (N))
7468                    or else Is_Access_Type (Etype (Prefix (N)));
7469
7470             --  In Ada95, a function call is a constant object; a procedure
7471             --  call is not.
7472
7473             when N_Function_Call =>
7474                return Etype (N) /= Standard_Void_Type;
7475
7476             --  A reference to the stream attribute Input is a function call
7477
7478             when N_Attribute_Reference =>
7479                return Attribute_Name (N) = Name_Input;
7480
7481             when N_Selected_Component =>
7482                return
7483                  Is_Object_Reference (Selector_Name (N))
7484                    and then
7485                      (Is_Object_Reference (Prefix (N))
7486                         or else Is_Access_Type (Etype (Prefix (N))));
7487
7488             when N_Explicit_Dereference =>
7489                return True;
7490
7491             --  A view conversion of a tagged object is an object reference
7492
7493             when N_Type_Conversion =>
7494                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
7495                  and then Is_Tagged_Type (Etype (Expression (N)))
7496                  and then Is_Object_Reference (Expression (N));
7497
7498             --  An unchecked type conversion is considered to be an object if
7499             --  the operand is an object (this construction arises only as a
7500             --  result of expansion activities).
7501
7502             when N_Unchecked_Type_Conversion =>
7503                return True;
7504
7505             when others =>
7506                return False;
7507          end case;
7508       end if;
7509    end Is_Object_Reference;
7510
7511    -----------------------------------
7512    -- Is_OK_Variable_For_Out_Formal --
7513    -----------------------------------
7514
7515    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
7516    begin
7517       Note_Possible_Modification (AV, Sure => True);
7518
7519       --  We must reject parenthesized variable names. The check for
7520       --  Comes_From_Source is present because there are currently
7521       --  cases where the compiler violates this rule (e.g. passing
7522       --  a task object to its controlled Initialize routine).
7523
7524       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
7525          return False;
7526
7527       --  A variable is always allowed
7528
7529       elsif Is_Variable (AV) then
7530          return True;
7531
7532       --  Unchecked conversions are allowed only if they come from the
7533       --  generated code, which sometimes uses unchecked conversions for out
7534       --  parameters in cases where code generation is unaffected. We tell
7535       --  source unchecked conversions by seeing if they are rewrites of an
7536       --  original Unchecked_Conversion function call, or of an explicit
7537       --  conversion of a function call.
7538
7539       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
7540          if Nkind (Original_Node (AV)) = N_Function_Call then
7541             return False;
7542
7543          elsif Comes_From_Source (AV)
7544            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
7545          then
7546             return False;
7547
7548          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
7549             return Is_OK_Variable_For_Out_Formal (Expression (AV));
7550
7551          else
7552             return True;
7553          end if;
7554
7555       --  Normal type conversions are allowed if argument is a variable
7556
7557       elsif Nkind (AV) = N_Type_Conversion then
7558          if Is_Variable (Expression (AV))
7559            and then Paren_Count (Expression (AV)) = 0
7560          then
7561             Note_Possible_Modification (Expression (AV), Sure => True);
7562             return True;
7563
7564          --  We also allow a non-parenthesized expression that raises
7565          --  constraint error if it rewrites what used to be a variable
7566
7567          elsif Raises_Constraint_Error (Expression (AV))
7568             and then Paren_Count (Expression (AV)) = 0
7569             and then Is_Variable (Original_Node (Expression (AV)))
7570          then
7571             return True;
7572
7573          --  Type conversion of something other than a variable
7574
7575          else
7576             return False;
7577          end if;
7578
7579       --  If this node is rewritten, then test the original form, if that is
7580       --  OK, then we consider the rewritten node OK (for example, if the
7581       --  original node is a conversion, then Is_Variable will not be true
7582       --  but we still want to allow the conversion if it converts a variable).
7583
7584       elsif Original_Node (AV) /= AV then
7585
7586          --  In Ada2012, the explicit dereference may be a rewritten call to a
7587          --  Reference function.
7588
7589          if Ada_Version >= Ada_2012
7590            and then Nkind (Original_Node (AV)) = N_Function_Call
7591            and then
7592              Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
7593          then
7594             return True;
7595
7596          else
7597             return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
7598          end if;
7599
7600       --  All other non-variables are rejected
7601
7602       else
7603          return False;
7604       end if;
7605    end Is_OK_Variable_For_Out_Formal;
7606
7607    -----------------------------------
7608    -- Is_Partially_Initialized_Type --
7609    -----------------------------------
7610
7611    function Is_Partially_Initialized_Type
7612      (Typ              : Entity_Id;
7613       Include_Implicit : Boolean := True) return Boolean
7614    is
7615    begin
7616       if Is_Scalar_Type (Typ) then
7617          return False;
7618
7619       elsif Is_Access_Type (Typ) then
7620          return Include_Implicit;
7621
7622       elsif Is_Array_Type (Typ) then
7623
7624          --  If component type is partially initialized, so is array type
7625
7626          if Is_Partially_Initialized_Type
7627               (Component_Type (Typ), Include_Implicit)
7628          then
7629             return True;
7630
7631          --  Otherwise we are only partially initialized if we are fully
7632          --  initialized (this is the empty array case, no point in us
7633          --  duplicating that code here).
7634
7635          else
7636             return Is_Fully_Initialized_Type (Typ);
7637          end if;
7638
7639       elsif Is_Record_Type (Typ) then
7640
7641          --  A discriminated type is always partially initialized if in
7642          --  all mode
7643
7644          if Has_Discriminants (Typ) and then Include_Implicit then
7645             return True;
7646
7647          --  A tagged type is always partially initialized
7648
7649          elsif Is_Tagged_Type (Typ) then
7650             return True;
7651
7652          --  Case of non-discriminated record
7653
7654          else
7655             declare
7656                Ent : Entity_Id;
7657
7658                Component_Present : Boolean := False;
7659                --  Set True if at least one component is present. If no
7660                --  components are present, then record type is fully
7661                --  initialized (another odd case, like the null array).
7662
7663             begin
7664                --  Loop through components
7665
7666                Ent := First_Entity (Typ);
7667                while Present (Ent) loop
7668                   if Ekind (Ent) = E_Component then
7669                      Component_Present := True;
7670
7671                      --  If a component has an initialization expression then
7672                      --  the enclosing record type is partially initialized
7673
7674                      if Present (Parent (Ent))
7675                        and then Present (Expression (Parent (Ent)))
7676                      then
7677                         return True;
7678
7679                      --  If a component is of a type which is itself partially
7680                      --  initialized, then the enclosing record type is also.
7681
7682                      elsif Is_Partially_Initialized_Type
7683                              (Etype (Ent), Include_Implicit)
7684                      then
7685                         return True;
7686                      end if;
7687                   end if;
7688
7689                   Next_Entity (Ent);
7690                end loop;
7691
7692                --  No initialized components found. If we found any components
7693                --  they were all uninitialized so the result is false.
7694
7695                if Component_Present then
7696                   return False;
7697
7698                --  But if we found no components, then all the components are
7699                --  initialized so we consider the type to be initialized.
7700
7701                else
7702                   return True;
7703                end if;
7704             end;
7705          end if;
7706
7707       --  Concurrent types are always fully initialized
7708
7709       elsif Is_Concurrent_Type (Typ) then
7710          return True;
7711
7712       --  For a private type, go to underlying type. If there is no underlying
7713       --  type then just assume this partially initialized. Not clear if this
7714       --  can happen in a non-error case, but no harm in testing for this.
7715
7716       elsif Is_Private_Type (Typ) then
7717          declare
7718             U : constant Entity_Id := Underlying_Type (Typ);
7719          begin
7720             if No (U) then
7721                return True;
7722             else
7723                return Is_Partially_Initialized_Type (U, Include_Implicit);
7724             end if;
7725          end;
7726
7727       --  For any other type (are there any?) assume partially initialized
7728
7729       else
7730          return True;
7731       end if;
7732    end Is_Partially_Initialized_Type;
7733
7734    ------------------------------------
7735    -- Is_Potentially_Persistent_Type --
7736    ------------------------------------
7737
7738    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
7739       Comp : Entity_Id;
7740       Indx : Node_Id;
7741
7742    begin
7743       --  For private type, test corresponding full type
7744
7745       if Is_Private_Type (T) then
7746          return Is_Potentially_Persistent_Type (Full_View (T));
7747
7748       --  Scalar types are potentially persistent
7749
7750       elsif Is_Scalar_Type (T) then
7751          return True;
7752
7753       --  Record type is potentially persistent if not tagged and the types of
7754       --  all it components are potentially persistent, and no component has
7755       --  an initialization expression.
7756
7757       elsif Is_Record_Type (T)
7758         and then not Is_Tagged_Type (T)
7759         and then not Is_Partially_Initialized_Type (T)
7760       then
7761          Comp := First_Component (T);
7762          while Present (Comp) loop
7763             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
7764                return False;
7765             else
7766                Next_Entity (Comp);
7767             end if;
7768          end loop;
7769
7770          return True;
7771
7772       --  Array type is potentially persistent if its component type is
7773       --  potentially persistent and if all its constraints are static.
7774
7775       elsif Is_Array_Type (T) then
7776          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
7777             return False;
7778          end if;
7779
7780          Indx := First_Index (T);
7781          while Present (Indx) loop
7782             if not Is_OK_Static_Subtype (Etype (Indx)) then
7783                return False;
7784             else
7785                Next_Index (Indx);
7786             end if;
7787          end loop;
7788
7789          return True;
7790
7791       --  All other types are not potentially persistent
7792
7793       else
7794          return False;
7795       end if;
7796    end Is_Potentially_Persistent_Type;
7797
7798    ---------------------------------
7799    -- Is_Protected_Self_Reference --
7800    ---------------------------------
7801
7802    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
7803
7804       function In_Access_Definition (N : Node_Id) return Boolean;
7805       --  Returns true if N belongs to an access definition
7806
7807       --------------------------
7808       -- In_Access_Definition --
7809       --------------------------
7810
7811       function In_Access_Definition (N : Node_Id) return Boolean is
7812          P : Node_Id;
7813
7814       begin
7815          P := Parent (N);
7816          while Present (P) loop
7817             if Nkind (P) = N_Access_Definition then
7818                return True;
7819             end if;
7820
7821             P := Parent (P);
7822          end loop;
7823
7824          return False;
7825       end In_Access_Definition;
7826
7827    --  Start of processing for Is_Protected_Self_Reference
7828
7829    begin
7830       --  Verify that prefix is analyzed and has the proper form. Note that
7831       --  the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address,
7832       --  which also produce the address of an entity, do not analyze their
7833       --  prefix because they denote entities that are not necessarily visible.
7834       --  Neither of them can apply to a protected type.
7835
7836       return Ada_Version >= Ada_2005
7837         and then Is_Entity_Name (N)
7838         and then Present (Entity (N))
7839         and then Is_Protected_Type (Entity (N))
7840         and then In_Open_Scopes (Entity (N))
7841         and then not In_Access_Definition (N);
7842    end Is_Protected_Self_Reference;
7843
7844    -----------------------------
7845    -- Is_RCI_Pkg_Spec_Or_Body --
7846    -----------------------------
7847
7848    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
7849
7850       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
7851       --  Return True if the unit of Cunit is an RCI package declaration
7852
7853       ---------------------------
7854       -- Is_RCI_Pkg_Decl_Cunit --
7855       ---------------------------
7856
7857       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
7858          The_Unit : constant Node_Id := Unit (Cunit);
7859
7860       begin
7861          if Nkind (The_Unit) /= N_Package_Declaration then
7862             return False;
7863          end if;
7864
7865          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
7866       end Is_RCI_Pkg_Decl_Cunit;
7867
7868    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
7869
7870    begin
7871       return Is_RCI_Pkg_Decl_Cunit (Cunit)
7872         or else
7873          (Nkind (Unit (Cunit)) = N_Package_Body
7874            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
7875    end Is_RCI_Pkg_Spec_Or_Body;
7876
7877    -----------------------------------------
7878    -- Is_Remote_Access_To_Class_Wide_Type --
7879    -----------------------------------------
7880
7881    function Is_Remote_Access_To_Class_Wide_Type
7882      (E : Entity_Id) return Boolean
7883    is
7884    begin
7885       --  A remote access to class-wide type is a general access to object type
7886       --  declared in the visible part of a Remote_Types or Remote_Call_
7887       --  Interface unit.
7888
7889       return Ekind (E) = E_General_Access_Type
7890         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7891    end Is_Remote_Access_To_Class_Wide_Type;
7892
7893    -----------------------------------------
7894    -- Is_Remote_Access_To_Subprogram_Type --
7895    -----------------------------------------
7896
7897    function Is_Remote_Access_To_Subprogram_Type
7898      (E : Entity_Id) return Boolean
7899    is
7900    begin
7901       return (Ekind (E) = E_Access_Subprogram_Type
7902                 or else (Ekind (E) = E_Record_Type
7903                            and then Present (Corresponding_Remote_Type (E))))
7904         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
7905    end Is_Remote_Access_To_Subprogram_Type;
7906
7907    --------------------
7908    -- Is_Remote_Call --
7909    --------------------
7910
7911    function Is_Remote_Call (N : Node_Id) return Boolean is
7912    begin
7913       if Nkind (N) /= N_Procedure_Call_Statement
7914         and then Nkind (N) /= N_Function_Call
7915       then
7916          --  An entry call cannot be remote
7917
7918          return False;
7919
7920       elsif Nkind (Name (N)) in N_Has_Entity
7921         and then Is_Remote_Call_Interface (Entity (Name (N)))
7922       then
7923          --  A subprogram declared in the spec of a RCI package is remote
7924
7925          return True;
7926
7927       elsif Nkind (Name (N)) = N_Explicit_Dereference
7928         and then Is_Remote_Access_To_Subprogram_Type
7929                    (Etype (Prefix (Name (N))))
7930       then
7931          --  The dereference of a RAS is a remote call
7932
7933          return True;
7934
7935       elsif Present (Controlling_Argument (N))
7936         and then Is_Remote_Access_To_Class_Wide_Type
7937           (Etype (Controlling_Argument (N)))
7938       then
7939          --  Any primitive operation call with a controlling argument of
7940          --  a RACW type is a remote call.
7941
7942          return True;
7943       end if;
7944
7945       --  All other calls are local calls
7946
7947       return False;
7948    end Is_Remote_Call;
7949
7950    ----------------------
7951    -- Is_Renamed_Entry --
7952    ----------------------
7953
7954    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
7955       Orig_Node : Node_Id := Empty;
7956       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
7957
7958       function Is_Entry (Nam : Node_Id) return Boolean;
7959       --  Determine whether Nam is an entry. Traverse selectors if there are
7960       --  nested selected components.
7961
7962       --------------
7963       -- Is_Entry --
7964       --------------
7965
7966       function Is_Entry (Nam : Node_Id) return Boolean is
7967       begin
7968          if Nkind (Nam) = N_Selected_Component then
7969             return Is_Entry (Selector_Name (Nam));
7970          end if;
7971
7972          return Ekind (Entity (Nam)) = E_Entry;
7973       end Is_Entry;
7974
7975    --  Start of processing for Is_Renamed_Entry
7976
7977    begin
7978       if Present (Alias (Proc_Nam)) then
7979          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
7980       end if;
7981
7982       --  Look for a rewritten subprogram renaming declaration
7983
7984       if Nkind (Subp_Decl) = N_Subprogram_Declaration
7985         and then Present (Original_Node (Subp_Decl))
7986       then
7987          Orig_Node := Original_Node (Subp_Decl);
7988       end if;
7989
7990       --  The rewritten subprogram is actually an entry
7991
7992       if Present (Orig_Node)
7993         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
7994         and then Is_Entry (Name (Orig_Node))
7995       then
7996          return True;
7997       end if;
7998
7999       return False;
8000    end Is_Renamed_Entry;
8001
8002    ----------------------------
8003    -- Is_Reversible_Iterator --
8004    ----------------------------
8005
8006    function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
8007       Ifaces_List : Elist_Id;
8008       Iface_Elmt  : Elmt_Id;
8009       Iface       : Entity_Id;
8010
8011    begin
8012       if Is_Class_Wide_Type (Typ)
8013         and then  Chars (Etype (Typ)) = Name_Reversible_Iterator
8014         and then
8015           Is_Predefined_File_Name
8016             (Unit_File_Name (Get_Source_Unit (Etype (Typ))))
8017       then
8018          return True;
8019
8020       elsif not Is_Tagged_Type (Typ)
8021         or else not Is_Derived_Type (Typ)
8022       then
8023          return False;
8024
8025       else
8026          Collect_Interfaces (Typ, Ifaces_List);
8027
8028          Iface_Elmt := First_Elmt (Ifaces_List);
8029          while Present (Iface_Elmt) loop
8030             Iface := Node (Iface_Elmt);
8031             if Chars (Iface) = Name_Reversible_Iterator
8032               and then
8033                 Is_Predefined_File_Name
8034                   (Unit_File_Name (Get_Source_Unit (Iface)))
8035             then
8036                return True;
8037             end if;
8038
8039             Next_Elmt (Iface_Elmt);
8040          end loop;
8041       end if;
8042
8043       return False;
8044    end Is_Reversible_Iterator;
8045
8046    ----------------------
8047    -- Is_Selector_Name --
8048    ----------------------
8049
8050    function Is_Selector_Name (N : Node_Id) return Boolean is
8051    begin
8052       if not Is_List_Member (N) then
8053          declare
8054             P : constant Node_Id   := Parent (N);
8055             K : constant Node_Kind := Nkind (P);
8056          begin
8057             return
8058               (K = N_Expanded_Name          or else
8059                K = N_Generic_Association    or else
8060                K = N_Parameter_Association  or else
8061                K = N_Selected_Component)
8062               and then Selector_Name (P) = N;
8063          end;
8064
8065       else
8066          declare
8067             L : constant List_Id := List_Containing (N);
8068             P : constant Node_Id := Parent (L);
8069          begin
8070             return (Nkind (P) = N_Discriminant_Association
8071                      and then Selector_Names (P) = L)
8072               or else
8073                    (Nkind (P) = N_Component_Association
8074                      and then Choices (P) = L);
8075          end;
8076       end if;
8077    end Is_Selector_Name;
8078
8079    ----------------------------------
8080    -- Is_SPARK_Initialization_Expr --
8081    ----------------------------------
8082
8083    function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is
8084       Is_Ok     : Boolean;
8085       Expr      : Node_Id;
8086       Comp_Assn : Node_Id;
8087       Orig_N    : constant Node_Id := Original_Node (N);
8088
8089    begin
8090       Is_Ok := True;
8091
8092       if not Comes_From_Source (Orig_N) then
8093          goto Done;
8094       end if;
8095
8096       pragma Assert (Nkind (Orig_N) in N_Subexpr);
8097
8098       case Nkind (Orig_N) is
8099          when N_Character_Literal |
8100               N_Integer_Literal   |
8101               N_Real_Literal      |
8102               N_String_Literal    =>
8103             null;
8104
8105          when N_Identifier    |
8106               N_Expanded_Name =>
8107             if Is_Entity_Name (Orig_N)
8108               and then Present (Entity (Orig_N))  --  needed in some cases
8109             then
8110                case Ekind (Entity (Orig_N)) is
8111                   when E_Constant            |
8112                        E_Enumeration_Literal |
8113                        E_Named_Integer       |
8114                        E_Named_Real          =>
8115                      null;
8116                   when others =>
8117                      if Is_Type (Entity (Orig_N)) then
8118                         null;
8119                      else
8120                         Is_Ok := False;
8121                      end if;
8122                end case;
8123             end if;
8124
8125          when N_Qualified_Expression |
8126               N_Type_Conversion      =>
8127             Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N));
8128
8129          when N_Unary_Op =>
8130             Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
8131
8132          when N_Binary_Op       |
8133               N_Short_Circuit   |
8134               N_Membership_Test =>
8135             Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N))
8136               and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N));
8137
8138          when N_Aggregate           |
8139               N_Extension_Aggregate =>
8140             if Nkind (Orig_N) = N_Extension_Aggregate then
8141                Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N));
8142             end if;
8143
8144             Expr := First (Expressions (Orig_N));
8145             while Present (Expr) loop
8146                if not Is_SPARK_Initialization_Expr (Expr) then
8147                   Is_Ok := False;
8148                   goto Done;
8149                end if;
8150
8151                Next (Expr);
8152             end loop;
8153
8154             Comp_Assn := First (Component_Associations (Orig_N));
8155             while Present (Comp_Assn) loop
8156                Expr := Expression (Comp_Assn);
8157                if Present (Expr)  --  needed for box association
8158                  and then not Is_SPARK_Initialization_Expr (Expr)
8159                then
8160                   Is_Ok := False;
8161                   goto Done;
8162                end if;
8163
8164                Next (Comp_Assn);
8165             end loop;
8166
8167          when N_Attribute_Reference =>
8168             if Nkind (Prefix (Orig_N)) in N_Subexpr then
8169                Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N));
8170             end if;
8171
8172             Expr := First (Expressions (Orig_N));
8173             while Present (Expr) loop
8174                if not Is_SPARK_Initialization_Expr (Expr) then
8175                   Is_Ok := False;
8176                   goto Done;
8177                end if;
8178
8179                Next (Expr);
8180             end loop;
8181
8182          --  Selected components might be expanded named not yet resolved, so
8183          --  default on the safe side. (Eg on sparklex.ads)
8184
8185          when N_Selected_Component =>
8186             null;
8187
8188          when others =>
8189             Is_Ok := False;
8190       end case;
8191
8192    <<Done>>
8193       return Is_Ok;
8194    end Is_SPARK_Initialization_Expr;
8195
8196    -------------------------------
8197    -- Is_SPARK_Object_Reference --
8198    -------------------------------
8199
8200    function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is
8201    begin
8202       if Is_Entity_Name (N) then
8203          return Present (Entity (N))
8204            and then
8205              (Ekind_In (Entity (N), E_Constant, E_Variable)
8206               or else Ekind (Entity (N)) in Formal_Kind);
8207
8208       else
8209          case Nkind (N) is
8210             when N_Selected_Component =>
8211                return Is_SPARK_Object_Reference (Prefix (N));
8212
8213             when others =>
8214                return False;
8215          end case;
8216       end if;
8217    end Is_SPARK_Object_Reference;
8218
8219    ------------------
8220    -- Is_Statement --
8221    ------------------
8222
8223    function Is_Statement (N : Node_Id) return Boolean is
8224    begin
8225       return
8226         Nkind (N) in N_Statement_Other_Than_Procedure_Call
8227           or else Nkind (N) = N_Procedure_Call_Statement;
8228    end Is_Statement;
8229
8230    --------------------------------------------------
8231    -- Is_Subprogram_Stub_Without_Prior_Declaration --
8232    --------------------------------------------------
8233
8234    function Is_Subprogram_Stub_Without_Prior_Declaration
8235      (N : Node_Id) return Boolean
8236    is
8237    begin
8238       --  A subprogram stub without prior declaration serves as declaration for
8239       --  the actual subprogram body. As such, it has an attached defining
8240       --  entity of E_[Generic_]Function or E_[Generic_]Procedure.
8241
8242       return Nkind (N) = N_Subprogram_Body_Stub
8243         and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
8244    end Is_Subprogram_Stub_Without_Prior_Declaration;
8245
8246    ---------------------------------
8247    -- Is_Synchronized_Tagged_Type --
8248    ---------------------------------
8249
8250    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
8251       Kind : constant Entity_Kind := Ekind (Base_Type (E));
8252
8253    begin
8254       --  A task or protected type derived from an interface is a tagged type.
8255       --  Such a tagged type is called a synchronized tagged type, as are
8256       --  synchronized interfaces and private extensions whose declaration
8257       --  includes the reserved word synchronized.
8258
8259       return (Is_Tagged_Type (E)
8260                 and then (Kind = E_Task_Type
8261                            or else Kind = E_Protected_Type))
8262             or else
8263              (Is_Interface (E)
8264                 and then Is_Synchronized_Interface (E))
8265             or else
8266              (Ekind (E) = E_Record_Type_With_Private
8267                 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
8268                 and then (Synchronized_Present (Parent (E))
8269                            or else Is_Synchronized_Interface (Etype (E))));
8270    end Is_Synchronized_Tagged_Type;
8271
8272    -----------------
8273    -- Is_Transfer --
8274    -----------------
8275
8276    function Is_Transfer (N : Node_Id) return Boolean is
8277       Kind : constant Node_Kind := Nkind (N);
8278
8279    begin
8280       if Kind = N_Simple_Return_Statement
8281            or else
8282          Kind = N_Extended_Return_Statement
8283            or else
8284          Kind = N_Goto_Statement
8285            or else
8286          Kind = N_Raise_Statement
8287            or else
8288          Kind = N_Requeue_Statement
8289       then
8290          return True;
8291
8292       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
8293         and then No (Condition (N))
8294       then
8295          return True;
8296
8297       elsif Kind = N_Procedure_Call_Statement
8298         and then Is_Entity_Name (Name (N))
8299         and then Present (Entity (Name (N)))
8300         and then No_Return (Entity (Name (N)))
8301       then
8302          return True;
8303
8304       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
8305          return True;
8306
8307       else
8308          return False;
8309       end if;
8310    end Is_Transfer;
8311
8312    -------------
8313    -- Is_True --
8314    -------------
8315
8316    function Is_True (U : Uint) return Boolean is
8317    begin
8318       return (U /= 0);
8319    end Is_True;
8320
8321    -------------------------------
8322    -- Is_Universal_Numeric_Type --
8323    -------------------------------
8324
8325    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
8326    begin
8327       return T = Universal_Integer or else T = Universal_Real;
8328    end Is_Universal_Numeric_Type;
8329
8330    -------------------
8331    -- Is_Value_Type --
8332    -------------------
8333
8334    function Is_Value_Type (T : Entity_Id) return Boolean is
8335    begin
8336       return VM_Target = CLI_Target
8337         and then Nkind (T) in N_Has_Chars
8338         and then Chars (T) /= No_Name
8339         and then Get_Name_String (Chars (T)) = "valuetype";
8340    end Is_Value_Type;
8341
8342    ---------------------
8343    -- Is_VMS_Operator --
8344    ---------------------
8345
8346    function Is_VMS_Operator (Op : Entity_Id) return Boolean is
8347    begin
8348       --  The VMS operators are declared in a child of System that is loaded
8349       --  through pragma Extend_System. In some rare cases a program is run
8350       --  with this extension but without indicating that the target is VMS.
8351
8352       return Ekind (Op) = E_Function
8353         and then Is_Intrinsic_Subprogram (Op)
8354         and then
8355           ((Present_System_Aux
8356             and then Scope (Op) = System_Aux_Id)
8357            or else
8358            (True_VMS_Target
8359              and then Scope (Scope (Op)) = RTU_Entity (System)));
8360    end Is_VMS_Operator;
8361
8362    -----------------
8363    -- Is_Variable --
8364    -----------------
8365
8366    function Is_Variable
8367      (N                 : Node_Id;
8368       Use_Original_Node : Boolean := True) return Boolean
8369    is
8370       Orig_Node : Node_Id;
8371
8372       function In_Protected_Function (E : Entity_Id) return Boolean;
8373       --  Within a protected function, the private components of the enclosing
8374       --  protected type are constants. A function nested within a (protected)
8375       --  procedure is not itself protected.
8376
8377       function Is_Variable_Prefix (P : Node_Id) return Boolean;
8378       --  Prefixes can involve implicit dereferences, in which case we must
8379       --  test for the case of a reference of a constant access type, which can
8380       --  can never be a variable.
8381
8382       ---------------------------
8383       -- In_Protected_Function --
8384       ---------------------------
8385
8386       function In_Protected_Function (E : Entity_Id) return Boolean is
8387          Prot : constant Entity_Id := Scope (E);
8388          S    : Entity_Id;
8389
8390       begin
8391          if not Is_Protected_Type (Prot) then
8392             return False;
8393          else
8394             S := Current_Scope;
8395             while Present (S) and then S /= Prot loop
8396                if Ekind (S) = E_Function and then Scope (S) = Prot then
8397                   return True;
8398                end if;
8399
8400                S := Scope (S);
8401             end loop;
8402
8403             return False;
8404          end if;
8405       end In_Protected_Function;
8406
8407       ------------------------
8408       -- Is_Variable_Prefix --
8409       ------------------------
8410
8411       function Is_Variable_Prefix (P : Node_Id) return Boolean is
8412       begin
8413          if Is_Access_Type (Etype (P)) then
8414             return not Is_Access_Constant (Root_Type (Etype (P)));
8415
8416          --  For the case of an indexed component whose prefix has a packed
8417          --  array type, the prefix has been rewritten into a type conversion.
8418          --  Determine variable-ness from the converted expression.
8419
8420          elsif Nkind (P) = N_Type_Conversion
8421            and then not Comes_From_Source (P)
8422            and then Is_Array_Type (Etype (P))
8423            and then Is_Packed (Etype (P))
8424          then
8425             return Is_Variable (Expression (P));
8426
8427          else
8428             return Is_Variable (P);
8429          end if;
8430       end Is_Variable_Prefix;
8431
8432    --  Start of processing for Is_Variable
8433
8434    begin
8435       --  Check if we perform the test on the original node since this may be a
8436       --  test of syntactic categories which must not be disturbed by whatever
8437       --  rewriting might have occurred. For example, an aggregate, which is
8438       --  certainly NOT a variable, could be turned into a variable by
8439       --  expansion.
8440
8441       if Use_Original_Node then
8442          Orig_Node := Original_Node (N);
8443       else
8444          Orig_Node := N;
8445       end if;
8446
8447       --  Definitely OK if Assignment_OK is set. Since this is something that
8448       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
8449
8450       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
8451          return True;
8452
8453       --  Normally we go to the original node, but there is one exception where
8454       --  we use the rewritten node, namely when it is an explicit dereference.
8455       --  The generated code may rewrite a prefix which is an access type with
8456       --  an explicit dereference. The dereference is a variable, even though
8457       --  the original node may not be (since it could be a constant of the
8458       --  access type).
8459
8460       --  In Ada 2005 we have a further case to consider: the prefix may be a
8461       --  function call given in prefix notation. The original node appears to
8462       --  be a selected component, but we need to examine the call.
8463
8464       elsif Nkind (N) = N_Explicit_Dereference
8465         and then Nkind (Orig_Node) /= N_Explicit_Dereference
8466         and then Present (Etype (Orig_Node))
8467         and then Is_Access_Type (Etype (Orig_Node))
8468       then
8469          --  Note that if the prefix is an explicit dereference that does not
8470          --  come from source, we must check for a rewritten function call in
8471          --  prefixed notation before other forms of rewriting, to prevent a
8472          --  compiler crash.
8473
8474          return
8475            (Nkind (Orig_Node) = N_Function_Call
8476              and then not Is_Access_Constant (Etype (Prefix (N))))
8477            or else
8478              Is_Variable_Prefix (Original_Node (Prefix (N)));
8479
8480       --  A function call is never a variable
8481
8482       elsif Nkind (N) = N_Function_Call then
8483          return False;
8484
8485       --  All remaining checks use the original node
8486
8487       elsif Is_Entity_Name (Orig_Node)
8488         and then Present (Entity (Orig_Node))
8489       then
8490          declare
8491             E : constant Entity_Id := Entity (Orig_Node);
8492             K : constant Entity_Kind := Ekind (E);
8493
8494          begin
8495             return (K = E_Variable
8496                       and then Nkind (Parent (E)) /= N_Exception_Handler)
8497               or else  (K = E_Component
8498                           and then not In_Protected_Function (E))
8499               or else  K = E_Out_Parameter
8500               or else  K = E_In_Out_Parameter
8501               or else  K = E_Generic_In_Out_Parameter
8502
8503                --  Current instance of type
8504
8505               or else (Is_Type (E) and then In_Open_Scopes (E))
8506               or else (Is_Incomplete_Or_Private_Type (E)
8507                         and then In_Open_Scopes (Full_View (E)));
8508          end;
8509
8510       else
8511          case Nkind (Orig_Node) is
8512             when N_Indexed_Component | N_Slice =>
8513                return Is_Variable_Prefix (Prefix (Orig_Node));
8514
8515             when N_Selected_Component =>
8516                return Is_Variable_Prefix (Prefix (Orig_Node))
8517                  and then Is_Variable (Selector_Name (Orig_Node));
8518
8519             --  For an explicit dereference, the type of the prefix cannot
8520             --  be an access to constant or an access to subprogram.
8521
8522             when N_Explicit_Dereference =>
8523                declare
8524                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
8525                begin
8526                   return Is_Access_Type (Typ)
8527                     and then not Is_Access_Constant (Root_Type (Typ))
8528                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
8529                end;
8530
8531             --  The type conversion is the case where we do not deal with the
8532             --  context dependent special case of an actual parameter. Thus
8533             --  the type conversion is only considered a variable for the
8534             --  purposes of this routine if the target type is tagged. However,
8535             --  a type conversion is considered to be a variable if it does not
8536             --  come from source (this deals for example with the conversions
8537             --  of expressions to their actual subtypes).
8538
8539             when N_Type_Conversion =>
8540                return Is_Variable (Expression (Orig_Node))
8541                  and then
8542                    (not Comes_From_Source (Orig_Node)
8543                       or else
8544                         (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
8545                           and then
8546                          Is_Tagged_Type (Etype (Expression (Orig_Node)))));
8547
8548             --  GNAT allows an unchecked type conversion as a variable. This
8549             --  only affects the generation of internal expanded code, since
8550             --  calls to instantiations of Unchecked_Conversion are never
8551             --  considered variables (since they are function calls).
8552             --  This is also true for expression actions.
8553
8554             when N_Unchecked_Type_Conversion =>
8555                return Is_Variable (Expression (Orig_Node));
8556
8557             when others =>
8558                return False;
8559          end case;
8560       end if;
8561    end Is_Variable;
8562
8563    ---------------------------
8564    -- Is_Visibly_Controlled --
8565    ---------------------------
8566
8567    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
8568       Root : constant Entity_Id := Root_Type (T);
8569    begin
8570       return Chars (Scope (Root)) = Name_Finalization
8571         and then Chars (Scope (Scope (Root))) = Name_Ada
8572         and then Scope (Scope (Scope (Root))) = Standard_Standard;
8573    end Is_Visibly_Controlled;
8574
8575    ------------------------
8576    -- Is_Volatile_Object --
8577    ------------------------
8578
8579    function Is_Volatile_Object (N : Node_Id) return Boolean is
8580
8581       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
8582       --  Determines if given object has volatile components
8583
8584       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
8585       --  If prefix is an implicit dereference, examine designated type
8586
8587       ------------------------
8588       -- Is_Volatile_Prefix --
8589       ------------------------
8590
8591       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
8592          Typ  : constant Entity_Id := Etype (N);
8593
8594       begin
8595          if Is_Access_Type (Typ) then
8596             declare
8597                Dtyp : constant Entity_Id := Designated_Type (Typ);
8598
8599             begin
8600                return Is_Volatile (Dtyp)
8601                  or else Has_Volatile_Components (Dtyp);
8602             end;
8603
8604          else
8605             return Object_Has_Volatile_Components (N);
8606          end if;
8607       end Is_Volatile_Prefix;
8608
8609       ------------------------------------
8610       -- Object_Has_Volatile_Components --
8611       ------------------------------------
8612
8613       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
8614          Typ : constant Entity_Id := Etype (N);
8615
8616       begin
8617          if Is_Volatile (Typ)
8618            or else Has_Volatile_Components (Typ)
8619          then
8620             return True;
8621
8622          elsif Is_Entity_Name (N)
8623            and then (Has_Volatile_Components (Entity (N))
8624                       or else Is_Volatile (Entity (N)))
8625          then
8626             return True;
8627
8628          elsif Nkind (N) = N_Indexed_Component
8629            or else Nkind (N) = N_Selected_Component
8630          then
8631             return Is_Volatile_Prefix (Prefix (N));
8632
8633          else
8634             return False;
8635          end if;
8636       end Object_Has_Volatile_Components;
8637
8638    --  Start of processing for Is_Volatile_Object
8639
8640    begin
8641       if Is_Volatile (Etype (N))
8642         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
8643       then
8644          return True;
8645
8646       elsif Nkind (N) = N_Indexed_Component
8647         or else Nkind (N) = N_Selected_Component
8648       then
8649          return Is_Volatile_Prefix (Prefix (N));
8650
8651       else
8652          return False;
8653       end if;
8654    end Is_Volatile_Object;
8655
8656    ---------------------------
8657    -- Itype_Has_Declaration --
8658    ---------------------------
8659
8660    function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
8661    begin
8662       pragma Assert (Is_Itype (Id));
8663       return Present (Parent (Id))
8664         and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
8665                                         N_Subtype_Declaration)
8666         and then Defining_Entity (Parent (Id)) = Id;
8667    end Itype_Has_Declaration;
8668
8669    -------------------------
8670    -- Kill_Current_Values --
8671    -------------------------
8672
8673    procedure Kill_Current_Values
8674      (Ent                  : Entity_Id;
8675       Last_Assignment_Only : Boolean := False)
8676    is
8677    begin
8678       --  ??? do we have to worry about clearing cached checks?
8679
8680       if Is_Assignable (Ent) then
8681          Set_Last_Assignment (Ent, Empty);
8682       end if;
8683
8684       if Is_Object (Ent) then
8685          if not Last_Assignment_Only then
8686             Kill_Checks (Ent);
8687             Set_Current_Value (Ent, Empty);
8688
8689             if not Can_Never_Be_Null (Ent) then
8690                Set_Is_Known_Non_Null (Ent, False);
8691             end if;
8692
8693             Set_Is_Known_Null (Ent, False);
8694
8695             --  Reset Is_Known_Valid unless type is always valid, or if we have
8696             --  a loop parameter (loop parameters are always valid, since their
8697             --  bounds are defined by the bounds given in the loop header).
8698
8699             if not Is_Known_Valid (Etype (Ent))
8700               and then Ekind (Ent) /= E_Loop_Parameter
8701             then
8702                Set_Is_Known_Valid (Ent, False);
8703             end if;
8704          end if;
8705       end if;
8706    end Kill_Current_Values;
8707
8708    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
8709       S : Entity_Id;
8710
8711       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
8712       --  Clear current value for entity E and all entities chained to E
8713
8714       ------------------------------------------
8715       -- Kill_Current_Values_For_Entity_Chain --
8716       ------------------------------------------
8717
8718       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
8719          Ent : Entity_Id;
8720       begin
8721          Ent := E;
8722          while Present (Ent) loop
8723             Kill_Current_Values (Ent, Last_Assignment_Only);
8724             Next_Entity (Ent);
8725          end loop;
8726       end Kill_Current_Values_For_Entity_Chain;
8727
8728    --  Start of processing for Kill_Current_Values
8729
8730    begin
8731       --  Kill all saved checks, a special case of killing saved values
8732
8733       if not Last_Assignment_Only then
8734          Kill_All_Checks;
8735       end if;
8736
8737       --  Loop through relevant scopes, which includes the current scope and
8738       --  any parent scopes if the current scope is a block or a package.
8739
8740       S := Current_Scope;
8741       Scope_Loop : loop
8742
8743          --  Clear current values of all entities in current scope
8744
8745          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
8746
8747          --  If scope is a package, also clear current values of all private
8748          --  entities in the scope.
8749
8750          if Is_Package_Or_Generic_Package (S)
8751            or else Is_Concurrent_Type (S)
8752          then
8753             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
8754          end if;
8755
8756          --  If this is a not a subprogram, deal with parents
8757
8758          if not Is_Subprogram (S) then
8759             S := Scope (S);
8760             exit Scope_Loop when S = Standard_Standard;
8761          else
8762             exit Scope_Loop;
8763          end if;
8764       end loop Scope_Loop;
8765    end Kill_Current_Values;
8766
8767    --------------------------
8768    -- Kill_Size_Check_Code --
8769    --------------------------
8770
8771    procedure Kill_Size_Check_Code (E : Entity_Id) is
8772    begin
8773       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
8774         and then Present (Size_Check_Code (E))
8775       then
8776          Remove (Size_Check_Code (E));
8777          Set_Size_Check_Code (E, Empty);
8778       end if;
8779    end Kill_Size_Check_Code;
8780
8781    --------------------------
8782    -- Known_To_Be_Assigned --
8783    --------------------------
8784
8785    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
8786       P : constant Node_Id := Parent (N);
8787
8788    begin
8789       case Nkind (P) is
8790
8791          --  Test left side of assignment
8792
8793          when N_Assignment_Statement =>
8794             return N = Name (P);
8795
8796             --  Function call arguments are never lvalues
8797
8798          when N_Function_Call =>
8799             return False;
8800
8801          --  Positional parameter for procedure or accept call
8802
8803          when N_Procedure_Call_Statement |
8804               N_Accept_Statement
8805           =>
8806             declare
8807                Proc : Entity_Id;
8808                Form : Entity_Id;
8809                Act  : Node_Id;
8810
8811             begin
8812                Proc := Get_Subprogram_Entity (P);
8813
8814                if No (Proc) then
8815                   return False;
8816                end if;
8817
8818                --  If we are not a list member, something is strange, so
8819                --  be conservative and return False.
8820
8821                if not Is_List_Member (N) then
8822                   return False;
8823                end if;
8824
8825                --  We are going to find the right formal by stepping forward
8826                --  through the formals, as we step backwards in the actuals.
8827
8828                Form := First_Formal (Proc);
8829                Act  := N;
8830                loop
8831                   --  If no formal, something is weird, so be conservative
8832                   --  and return False.
8833
8834                   if No (Form) then
8835                      return False;
8836                   end if;
8837
8838                   Prev (Act);
8839                   exit when No (Act);
8840                   Next_Formal (Form);
8841                end loop;
8842
8843                return Ekind (Form) /= E_In_Parameter;
8844             end;
8845
8846          --  Named parameter for procedure or accept call
8847
8848          when N_Parameter_Association =>
8849             declare
8850                Proc : Entity_Id;
8851                Form : Entity_Id;
8852
8853             begin
8854                Proc := Get_Subprogram_Entity (Parent (P));
8855
8856                if No (Proc) then
8857                   return False;
8858                end if;
8859
8860                --  Loop through formals to find the one that matches
8861
8862                Form := First_Formal (Proc);
8863                loop
8864                   --  If no matching formal, that's peculiar, some kind of
8865                   --  previous error, so return False to be conservative.
8866
8867                   if No (Form) then
8868                      return False;
8869                   end if;
8870
8871                   --  Else test for match
8872
8873                   if Chars (Form) = Chars (Selector_Name (P)) then
8874                      return Ekind (Form) /= E_In_Parameter;
8875                   end if;
8876
8877                   Next_Formal (Form);
8878                end loop;
8879             end;
8880
8881          --  Test for appearing in a conversion that itself appears
8882          --  in an lvalue context, since this should be an lvalue.
8883
8884          when N_Type_Conversion =>
8885             return Known_To_Be_Assigned (P);
8886
8887          --  All other references are definitely not known to be modifications
8888
8889          when others =>
8890             return False;
8891
8892       end case;
8893    end Known_To_Be_Assigned;
8894
8895    ---------------------------
8896    -- Last_Source_Statement --
8897    ---------------------------
8898
8899    function Last_Source_Statement (HSS : Node_Id) return Node_Id is
8900       N : Node_Id;
8901
8902    begin
8903       N := Last (Statements (HSS));
8904       while Present (N) loop
8905          exit when Comes_From_Source (N);
8906          Prev (N);
8907       end loop;
8908
8909       return N;
8910    end Last_Source_Statement;
8911
8912    ----------------------------------
8913    -- Matching_Static_Array_Bounds --
8914    ----------------------------------
8915
8916    function Matching_Static_Array_Bounds
8917      (L_Typ : Node_Id;
8918       R_Typ : Node_Id) return Boolean
8919    is
8920       L_Ndims : constant Nat := Number_Dimensions (L_Typ);
8921       R_Ndims : constant Nat := Number_Dimensions (R_Typ);
8922
8923       L_Index : Node_Id;
8924       R_Index : Node_Id;
8925       L_Low   : Node_Id;
8926       L_High  : Node_Id;
8927       L_Len   : Uint;
8928       R_Low   : Node_Id;
8929       R_High  : Node_Id;
8930       R_Len   : Uint;
8931
8932    begin
8933       if L_Ndims /= R_Ndims then
8934          return False;
8935       end if;
8936
8937       --  Unconstrained types do not have static bounds
8938
8939       if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
8940          return False;
8941       end if;
8942
8943       --  First treat specially the first dimension, as the lower bound and
8944       --  length of string literals are not stored like those of arrays.
8945
8946       if Ekind (L_Typ) = E_String_Literal_Subtype then
8947          L_Low := String_Literal_Low_Bound (L_Typ);
8948          L_Len := String_Literal_Length (L_Typ);
8949       else
8950          L_Index := First_Index (L_Typ);
8951          Get_Index_Bounds (L_Index, L_Low, L_High);
8952
8953          if         Is_OK_Static_Expression (L_Low)
8954            and then Is_OK_Static_Expression (L_High)
8955          then
8956             if Expr_Value (L_High) < Expr_Value (L_Low) then
8957                L_Len := Uint_0;
8958             else
8959                L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
8960             end if;
8961          else
8962             return False;
8963          end if;
8964       end if;
8965
8966       if Ekind (R_Typ) = E_String_Literal_Subtype then
8967          R_Low := String_Literal_Low_Bound (R_Typ);
8968          R_Len := String_Literal_Length (R_Typ);
8969       else
8970          R_Index := First_Index (R_Typ);
8971          Get_Index_Bounds (R_Index, R_Low, R_High);
8972
8973          if         Is_OK_Static_Expression (R_Low)
8974            and then Is_OK_Static_Expression (R_High)
8975          then
8976             if Expr_Value (R_High) < Expr_Value (R_Low) then
8977                R_Len := Uint_0;
8978             else
8979                R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
8980             end if;
8981          else
8982             return False;
8983          end if;
8984       end if;
8985
8986       if         Is_OK_Static_Expression (L_Low)
8987         and then Is_OK_Static_Expression (R_Low)
8988         and then Expr_Value (L_Low) = Expr_Value (R_Low)
8989         and then L_Len = R_Len
8990       then
8991          null;
8992       else
8993          return False;
8994       end if;
8995
8996       --  Then treat all other dimensions
8997
8998       for Indx in 2 .. L_Ndims loop
8999          Next (L_Index);
9000          Next (R_Index);
9001
9002          Get_Index_Bounds (L_Index, L_Low, L_High);
9003          Get_Index_Bounds (R_Index, R_Low, R_High);
9004
9005          if         Is_OK_Static_Expression (L_Low)
9006            and then Is_OK_Static_Expression (L_High)
9007            and then Is_OK_Static_Expression (R_Low)
9008            and then Is_OK_Static_Expression (R_High)
9009            and then Expr_Value (L_Low)  = Expr_Value (R_Low)
9010            and then Expr_Value (L_High) = Expr_Value (R_High)
9011          then
9012             null;
9013          else
9014             return False;
9015          end if;
9016       end loop;
9017
9018       --  If we fall through the loop, all indexes matched
9019
9020       return True;
9021    end Matching_Static_Array_Bounds;
9022
9023    -------------------
9024    -- May_Be_Lvalue --
9025    -------------------
9026
9027    function May_Be_Lvalue (N : Node_Id) return Boolean is
9028       P : constant Node_Id := Parent (N);
9029
9030    begin
9031       case Nkind (P) is
9032
9033          --  Test left side of assignment
9034
9035          when N_Assignment_Statement =>
9036             return N = Name (P);
9037
9038          --  Test prefix of component or attribute. Note that the prefix of an
9039          --  explicit or implicit dereference cannot be an l-value.
9040
9041          when N_Attribute_Reference =>
9042             return N = Prefix (P)
9043               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
9044
9045          --  For an expanded name, the name is an lvalue if the expanded name
9046          --  is an lvalue, but the prefix is never an lvalue, since it is just
9047          --  the scope where the name is found.
9048
9049          when N_Expanded_Name =>
9050             if N = Prefix (P) then
9051                return May_Be_Lvalue (P);
9052             else
9053                return False;
9054             end if;
9055
9056          --  For a selected component A.B, A is certainly an lvalue if A.B is.
9057          --  B is a little interesting, if we have A.B := 3, there is some
9058          --  discussion as to whether B is an lvalue or not, we choose to say
9059          --  it is. Note however that A is not an lvalue if it is of an access
9060          --  type since this is an implicit dereference.
9061
9062          when N_Selected_Component =>
9063             if N = Prefix (P)
9064               and then Present (Etype (N))
9065               and then Is_Access_Type (Etype (N))
9066             then
9067                return False;
9068             else
9069                return May_Be_Lvalue (P);
9070             end if;
9071
9072          --  For an indexed component or slice, the index or slice bounds is
9073          --  never an lvalue. The prefix is an lvalue if the indexed component
9074          --  or slice is an lvalue, except if it is an access type, where we
9075          --  have an implicit dereference.
9076
9077          when N_Indexed_Component | N_Slice =>
9078             if N /= Prefix (P)
9079               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
9080             then
9081                return False;
9082             else
9083                return May_Be_Lvalue (P);
9084             end if;
9085
9086          --  Prefix of a reference is an lvalue if the reference is an lvalue
9087
9088          when N_Reference =>
9089             return May_Be_Lvalue (P);
9090
9091          --  Prefix of explicit dereference is never an lvalue
9092
9093          when N_Explicit_Dereference =>
9094             return False;
9095
9096          --  Positional parameter for subprogram, entry, or accept call.
9097          --  In older versions of Ada function call arguments are never
9098          --  lvalues. In Ada 2012 functions can have in-out parameters.
9099
9100          when N_Function_Call            |
9101               N_Procedure_Call_Statement |
9102               N_Entry_Call_Statement     |
9103               N_Accept_Statement
9104          =>
9105             if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
9106                return False;
9107             end if;
9108
9109             --  The following mechanism is clumsy and fragile. A single flag
9110             --  set in Resolve_Actuals would be preferable ???
9111
9112             declare
9113                Proc : Entity_Id;
9114                Form : Entity_Id;
9115                Act  : Node_Id;
9116
9117             begin
9118                Proc := Get_Subprogram_Entity (P);
9119
9120                if No (Proc) then
9121                   return True;
9122                end if;
9123
9124                --  If we are not a list member, something is strange, so be
9125                --  conservative and return True.
9126
9127                if not Is_List_Member (N) then
9128                   return True;
9129                end if;
9130
9131                --  We are going to find the right formal by stepping forward
9132                --  through the formals, as we step backwards in the actuals.
9133
9134                Form := First_Formal (Proc);
9135                Act  := N;
9136                loop
9137                   --  If no formal, something is weird, so be conservative and
9138                   --  return True.
9139
9140                   if No (Form) then
9141                      return True;
9142                   end if;
9143
9144                   Prev (Act);
9145                   exit when No (Act);
9146                   Next_Formal (Form);
9147                end loop;
9148
9149                return Ekind (Form) /= E_In_Parameter;
9150             end;
9151
9152          --  Named parameter for procedure or accept call
9153
9154          when N_Parameter_Association =>
9155             declare
9156                Proc : Entity_Id;
9157                Form : Entity_Id;
9158
9159             begin
9160                Proc := Get_Subprogram_Entity (Parent (P));
9161
9162                if No (Proc) then
9163                   return True;
9164                end if;
9165
9166                --  Loop through formals to find the one that matches
9167
9168                Form := First_Formal (Proc);
9169                loop
9170                   --  If no matching formal, that's peculiar, some kind of
9171                   --  previous error, so return True to be conservative.
9172
9173                   if No (Form) then
9174                      return True;
9175                   end if;
9176
9177                   --  Else test for match
9178
9179                   if Chars (Form) = Chars (Selector_Name (P)) then
9180                      return Ekind (Form) /= E_In_Parameter;
9181                   end if;
9182
9183                   Next_Formal (Form);
9184                end loop;
9185             end;
9186
9187          --  Test for appearing in a conversion that itself appears in an
9188          --  lvalue context, since this should be an lvalue.
9189
9190          when N_Type_Conversion =>
9191             return May_Be_Lvalue (P);
9192
9193          --  Test for appearance in object renaming declaration
9194
9195          when N_Object_Renaming_Declaration =>
9196             return True;
9197
9198          --  All other references are definitely not lvalues
9199
9200          when others =>
9201             return False;
9202
9203       end case;
9204    end May_Be_Lvalue;
9205
9206    -----------------------
9207    -- Mark_Coextensions --
9208    -----------------------
9209
9210    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
9211       Is_Dynamic : Boolean;
9212       --  Indicates whether the context causes nested coextensions to be
9213       --  dynamic or static
9214
9215       function Mark_Allocator (N : Node_Id) return Traverse_Result;
9216       --  Recognize an allocator node and label it as a dynamic coextension
9217
9218       --------------------
9219       -- Mark_Allocator --
9220       --------------------
9221
9222       function Mark_Allocator (N : Node_Id) return Traverse_Result is
9223       begin
9224          if Nkind (N) = N_Allocator then
9225             if Is_Dynamic then
9226                Set_Is_Dynamic_Coextension (N);
9227
9228             --  If the allocator expression is potentially dynamic, it may
9229             --  be expanded out of order and require dynamic allocation
9230             --  anyway, so we treat the coextension itself as dynamic.
9231             --  Potential optimization ???
9232
9233             elsif Nkind (Expression (N)) = N_Qualified_Expression
9234               and then Nkind (Expression (Expression (N))) = N_Op_Concat
9235             then
9236                Set_Is_Dynamic_Coextension (N);
9237
9238             else
9239                Set_Is_Static_Coextension (N);
9240             end if;
9241          end if;
9242
9243          return OK;
9244       end Mark_Allocator;
9245
9246       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
9247
9248    --  Start of processing Mark_Coextensions
9249
9250    begin
9251       case Nkind (Context_Nod) is
9252          when N_Assignment_Statement    |
9253               N_Simple_Return_Statement =>
9254             Is_Dynamic := Nkind (Expression (Context_Nod)) = N_Allocator;
9255
9256          when N_Object_Declaration =>
9257             Is_Dynamic := Nkind (Root_Nod) = N_Allocator;
9258
9259          --  This routine should not be called for constructs which may not
9260          --  contain coextensions.
9261
9262          when others =>
9263             raise Program_Error;
9264       end case;
9265
9266       Mark_Allocators (Root_Nod);
9267    end Mark_Coextensions;
9268
9269    ----------------------
9270    -- Needs_One_Actual --
9271    ----------------------
9272
9273    function Needs_One_Actual (E : Entity_Id) return Boolean is
9274       Formal : Entity_Id;
9275
9276    begin
9277       if Ada_Version >= Ada_2005
9278         and then Present (First_Formal (E))
9279       then
9280          Formal := Next_Formal (First_Formal (E));
9281          while Present (Formal) loop
9282             if No (Default_Value (Formal)) then
9283                return False;
9284             end if;
9285
9286             Next_Formal (Formal);
9287          end loop;
9288
9289          return True;
9290
9291       else
9292          return False;
9293       end if;
9294    end Needs_One_Actual;
9295
9296    ------------------------
9297    -- New_Copy_List_Tree --
9298    ------------------------
9299
9300    function New_Copy_List_Tree (List : List_Id) return List_Id is
9301       NL : List_Id;
9302       E  : Node_Id;
9303
9304    begin
9305       if List = No_List then
9306          return No_List;
9307
9308       else
9309          NL := New_List;
9310          E := First (List);
9311
9312          while Present (E) loop
9313             Append (New_Copy_Tree (E), NL);
9314             E := Next (E);
9315          end loop;
9316
9317          return NL;
9318       end if;
9319    end New_Copy_List_Tree;
9320
9321    -------------------
9322    -- New_Copy_Tree --
9323    -------------------
9324
9325    use Atree.Unchecked_Access;
9326    use Atree_Private_Part;
9327
9328    --  Our approach here requires a two pass traversal of the tree. The
9329    --  first pass visits all nodes that eventually will be copied looking
9330    --  for defining Itypes. If any defining Itypes are found, then they are
9331    --  copied, and an entry is added to the replacement map. In the second
9332    --  phase, the tree is copied, using the replacement map to replace any
9333    --  Itype references within the copied tree.
9334
9335    --  The following hash tables are used if the Map supplied has more
9336    --  than hash threshold entries to speed up access to the map. If
9337    --  there are fewer entries, then the map is searched sequentially
9338    --  (because setting up a hash table for only a few entries takes
9339    --  more time than it saves.
9340
9341    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
9342    --  Hash function used for hash operations
9343
9344    -------------------
9345    -- New_Copy_Hash --
9346    -------------------
9347
9348    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
9349    begin
9350       return Nat (E) mod (NCT_Header_Num'Last + 1);
9351    end New_Copy_Hash;
9352
9353    ---------------
9354    -- NCT_Assoc --
9355    ---------------
9356
9357    --  The hash table NCT_Assoc associates old entities in the table
9358    --  with their corresponding new entities (i.e. the pairs of entries
9359    --  presented in the original Map argument are Key-Element pairs).
9360
9361    package NCT_Assoc is new Simple_HTable (
9362      Header_Num => NCT_Header_Num,
9363      Element    => Entity_Id,
9364      No_Element => Empty,
9365      Key        => Entity_Id,
9366      Hash       => New_Copy_Hash,
9367      Equal      => Types."=");
9368
9369    ---------------------
9370    -- NCT_Itype_Assoc --
9371    ---------------------
9372
9373    --  The hash table NCT_Itype_Assoc contains entries only for those
9374    --  old nodes which have a non-empty Associated_Node_For_Itype set.
9375    --  The key is the associated node, and the element is the new node
9376    --  itself (NOT the associated node for the new node).
9377
9378    package NCT_Itype_Assoc is new Simple_HTable (
9379      Header_Num => NCT_Header_Num,
9380      Element    => Entity_Id,
9381      No_Element => Empty,
9382      Key        => Entity_Id,
9383      Hash       => New_Copy_Hash,
9384      Equal      => Types."=");
9385
9386    --  Start of processing for New_Copy_Tree function
9387
9388    function New_Copy_Tree
9389      (Source    : Node_Id;
9390       Map       : Elist_Id := No_Elist;
9391       New_Sloc  : Source_Ptr := No_Location;
9392       New_Scope : Entity_Id := Empty) return Node_Id
9393    is
9394       Actual_Map : Elist_Id := Map;
9395       --  This is the actual map for the copy. It is initialized with the
9396       --  given elements, and then enlarged as required for Itypes that are
9397       --  copied during the first phase of the copy operation. The visit
9398       --  procedures add elements to this map as Itypes are encountered.
9399       --  The reason we cannot use Map directly, is that it may well be
9400       --  (and normally is) initialized to No_Elist, and if we have mapped
9401       --  entities, we have to reset it to point to a real Elist.
9402
9403       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
9404       --  Called during second phase to map entities into their corresponding
9405       --  copies using Actual_Map. If the argument is not an entity, or is not
9406       --  in Actual_Map, then it is returned unchanged.
9407
9408       procedure Build_NCT_Hash_Tables;
9409       --  Builds hash tables (number of elements >= threshold value)
9410
9411       function Copy_Elist_With_Replacement
9412         (Old_Elist : Elist_Id) return Elist_Id;
9413       --  Called during second phase to copy element list doing replacements
9414
9415       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
9416       --  Called during the second phase to process a copied Itype. The actual
9417       --  copy happened during the first phase (so that we could make the entry
9418       --  in the mapping), but we still have to deal with the descendents of
9419       --  the copied Itype and copy them where necessary.
9420
9421       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
9422       --  Called during second phase to copy list doing replacements
9423
9424       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
9425       --  Called during second phase to copy node doing replacements
9426
9427       procedure Visit_Elist (E : Elist_Id);
9428       --  Called during first phase to visit all elements of an Elist
9429
9430       procedure Visit_Field (F : Union_Id; N : Node_Id);
9431       --  Visit a single field, recursing to call Visit_Node or Visit_List
9432       --  if the field is a syntactic descendent of the current node (i.e.
9433       --  its parent is Node N).
9434
9435       procedure Visit_Itype (Old_Itype : Entity_Id);
9436       --  Called during first phase to visit subsidiary fields of a defining
9437       --  Itype, and also create a copy and make an entry in the replacement
9438       --  map for the new copy.
9439
9440       procedure Visit_List (L : List_Id);
9441       --  Called during first phase to visit all elements of a List
9442
9443       procedure Visit_Node (N : Node_Or_Entity_Id);
9444       --  Called during first phase to visit a node and all its subtrees
9445
9446       -----------
9447       -- Assoc --
9448       -----------
9449
9450       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
9451          E   : Elmt_Id;
9452          Ent : Entity_Id;
9453
9454       begin
9455          if not Has_Extension (N) or else No (Actual_Map) then
9456             return N;
9457
9458          elsif NCT_Hash_Tables_Used then
9459             Ent := NCT_Assoc.Get (Entity_Id (N));
9460
9461             if Present (Ent) then
9462                return Ent;
9463             else
9464                return N;
9465             end if;
9466
9467          --  No hash table used, do serial search
9468
9469          else
9470             E := First_Elmt (Actual_Map);
9471             while Present (E) loop
9472                if Node (E) = N then
9473                   return Node (Next_Elmt (E));
9474                else
9475                   E := Next_Elmt (Next_Elmt (E));
9476                end if;
9477             end loop;
9478          end if;
9479
9480          return N;
9481       end Assoc;
9482
9483       ---------------------------
9484       -- Build_NCT_Hash_Tables --
9485       ---------------------------
9486
9487       procedure Build_NCT_Hash_Tables is
9488          Elmt : Elmt_Id;
9489          Ent  : Entity_Id;
9490       begin
9491          if NCT_Hash_Table_Setup then
9492             NCT_Assoc.Reset;
9493             NCT_Itype_Assoc.Reset;
9494          end if;
9495
9496          Elmt := First_Elmt (Actual_Map);
9497          while Present (Elmt) loop
9498             Ent := Node (Elmt);
9499
9500             --  Get new entity, and associate old and new
9501
9502             Next_Elmt (Elmt);
9503             NCT_Assoc.Set (Ent, Node (Elmt));
9504
9505             if Is_Type (Ent) then
9506                declare
9507                   Anode : constant Entity_Id :=
9508                             Associated_Node_For_Itype (Ent);
9509
9510                begin
9511                   if Present (Anode) then
9512
9513                      --  Enter a link between the associated node of the
9514                      --  old Itype and the new Itype, for updating later
9515                      --  when node is copied.
9516
9517                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
9518                   end if;
9519                end;
9520             end if;
9521
9522             Next_Elmt (Elmt);
9523          end loop;
9524
9525          NCT_Hash_Tables_Used := True;
9526          NCT_Hash_Table_Setup := True;
9527       end Build_NCT_Hash_Tables;
9528
9529       ---------------------------------
9530       -- Copy_Elist_With_Replacement --
9531       ---------------------------------
9532
9533       function Copy_Elist_With_Replacement
9534         (Old_Elist : Elist_Id) return Elist_Id
9535       is
9536          M         : Elmt_Id;
9537          New_Elist : Elist_Id;
9538
9539       begin
9540          if No (Old_Elist) then
9541             return No_Elist;
9542
9543          else
9544             New_Elist := New_Elmt_List;
9545
9546             M := First_Elmt (Old_Elist);
9547             while Present (M) loop
9548                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
9549                Next_Elmt (M);
9550             end loop;
9551          end if;
9552
9553          return New_Elist;
9554       end Copy_Elist_With_Replacement;
9555
9556       ---------------------------------
9557       -- Copy_Itype_With_Replacement --
9558       ---------------------------------
9559
9560       --  This routine exactly parallels its phase one analog Visit_Itype,
9561
9562       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
9563       begin
9564          --  Translate Next_Entity, Scope and Etype fields, in case they
9565          --  reference entities that have been mapped into copies.
9566
9567          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
9568          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
9569
9570          if Present (New_Scope) then
9571             Set_Scope    (New_Itype, New_Scope);
9572          else
9573             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
9574          end if;
9575
9576          --  Copy referenced fields
9577
9578          if Is_Discrete_Type (New_Itype) then
9579             Set_Scalar_Range (New_Itype,
9580               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
9581
9582          elsif Has_Discriminants (Base_Type (New_Itype)) then
9583             Set_Discriminant_Constraint (New_Itype,
9584               Copy_Elist_With_Replacement
9585                 (Discriminant_Constraint (New_Itype)));
9586
9587          elsif Is_Array_Type (New_Itype) then
9588             if Present (First_Index (New_Itype)) then
9589                Set_First_Index (New_Itype,
9590                  First (Copy_List_With_Replacement
9591                          (List_Containing (First_Index (New_Itype)))));
9592             end if;
9593
9594             if Is_Packed (New_Itype) then
9595                Set_Packed_Array_Type (New_Itype,
9596                  Copy_Node_With_Replacement
9597                    (Packed_Array_Type (New_Itype)));
9598             end if;
9599          end if;
9600       end Copy_Itype_With_Replacement;
9601
9602       --------------------------------
9603       -- Copy_List_With_Replacement --
9604       --------------------------------
9605
9606       function Copy_List_With_Replacement
9607         (Old_List : List_Id) return List_Id
9608       is
9609          New_List : List_Id;
9610          E        : Node_Id;
9611
9612       begin
9613          if Old_List = No_List then
9614             return No_List;
9615
9616          else
9617             New_List := Empty_List;
9618
9619             E := First (Old_List);
9620             while Present (E) loop
9621                Append (Copy_Node_With_Replacement (E), New_List);
9622                Next (E);
9623             end loop;
9624
9625             return New_List;
9626          end if;
9627       end Copy_List_With_Replacement;
9628
9629       --------------------------------
9630       -- Copy_Node_With_Replacement --
9631       --------------------------------
9632
9633       function Copy_Node_With_Replacement
9634         (Old_Node : Node_Id) return Node_Id
9635       is
9636          New_Node : Node_Id;
9637
9638          procedure Adjust_Named_Associations
9639            (Old_Node : Node_Id;
9640             New_Node : Node_Id);
9641          --  If a call node has named associations, these are chained through
9642          --  the First_Named_Actual, Next_Named_Actual links. These must be
9643          --  propagated separately to the new parameter list, because these
9644          --  are not syntactic fields.
9645
9646          function Copy_Field_With_Replacement
9647            (Field : Union_Id) return Union_Id;
9648          --  Given Field, which is a field of Old_Node, return a copy of it
9649          --  if it is a syntactic field (i.e. its parent is Node), setting
9650          --  the parent of the copy to poit to New_Node. Otherwise returns
9651          --  the field (possibly mapped if it is an entity).
9652
9653          -------------------------------
9654          -- Adjust_Named_Associations --
9655          -------------------------------
9656
9657          procedure Adjust_Named_Associations
9658            (Old_Node : Node_Id;
9659             New_Node : Node_Id)
9660          is
9661             Old_E : Node_Id;
9662             New_E : Node_Id;
9663
9664             Old_Next : Node_Id;
9665             New_Next : Node_Id;
9666
9667          begin
9668             Old_E := First (Parameter_Associations (Old_Node));
9669             New_E := First (Parameter_Associations (New_Node));
9670             while Present (Old_E) loop
9671                if Nkind (Old_E) = N_Parameter_Association
9672                  and then Present (Next_Named_Actual (Old_E))
9673                then
9674                   if First_Named_Actual (Old_Node)
9675                     =  Explicit_Actual_Parameter (Old_E)
9676                   then
9677                      Set_First_Named_Actual
9678                        (New_Node, Explicit_Actual_Parameter (New_E));
9679                   end if;
9680
9681                   --  Now scan parameter list from the beginning,to locate
9682                   --  next named actual, which can be out of order.
9683
9684                   Old_Next := First (Parameter_Associations (Old_Node));
9685                   New_Next := First (Parameter_Associations (New_Node));
9686
9687                   while Nkind (Old_Next) /= N_Parameter_Association
9688                     or else  Explicit_Actual_Parameter (Old_Next)
9689                       /= Next_Named_Actual (Old_E)
9690                   loop
9691                      Next (Old_Next);
9692                      Next (New_Next);
9693                   end loop;
9694
9695                   Set_Next_Named_Actual
9696                     (New_E, Explicit_Actual_Parameter (New_Next));
9697                end if;
9698
9699                Next (Old_E);
9700                Next (New_E);
9701             end loop;
9702          end Adjust_Named_Associations;
9703
9704          ---------------------------------
9705          -- Copy_Field_With_Replacement --
9706          ---------------------------------
9707
9708          function Copy_Field_With_Replacement
9709            (Field : Union_Id) return Union_Id
9710          is
9711          begin
9712             if Field = Union_Id (Empty) then
9713                return Field;
9714
9715             elsif Field in Node_Range then
9716                declare
9717                   Old_N : constant Node_Id := Node_Id (Field);
9718                   New_N : Node_Id;
9719
9720                begin
9721                   --  If syntactic field, as indicated by the parent pointer
9722                   --  being set, then copy the referenced node recursively.
9723
9724                   if Parent (Old_N) = Old_Node then
9725                      New_N := Copy_Node_With_Replacement (Old_N);
9726
9727                      if New_N /= Old_N then
9728                         Set_Parent (New_N, New_Node);
9729                      end if;
9730
9731                   --  For semantic fields, update possible entity reference
9732                   --  from the replacement map.
9733
9734                   else
9735                      New_N := Assoc (Old_N);
9736                   end if;
9737
9738                   return Union_Id (New_N);
9739                end;
9740
9741             elsif Field in List_Range then
9742                declare
9743                   Old_L : constant List_Id := List_Id (Field);
9744                   New_L : List_Id;
9745
9746                begin
9747                   --  If syntactic field, as indicated by the parent pointer,
9748                   --  then recursively copy the entire referenced list.
9749
9750                   if Parent (Old_L) = Old_Node then
9751                      New_L := Copy_List_With_Replacement (Old_L);
9752                      Set_Parent (New_L, New_Node);
9753
9754                   --  For semantic list, just returned unchanged
9755
9756                   else
9757                      New_L := Old_L;
9758                   end if;
9759
9760                   return Union_Id (New_L);
9761                end;
9762
9763             --  Anything other than a list or a node is returned unchanged
9764
9765             else
9766                return Field;
9767             end if;
9768          end Copy_Field_With_Replacement;
9769
9770       --  Start of processing for Copy_Node_With_Replacement
9771
9772       begin
9773          if Old_Node <= Empty_Or_Error then
9774             return Old_Node;
9775
9776          elsif Has_Extension (Old_Node) then
9777             return Assoc (Old_Node);
9778
9779          else
9780             New_Node := New_Copy (Old_Node);
9781
9782             --  If the node we are copying is the associated node of a
9783             --  previously copied Itype, then adjust the associated node
9784             --  of the copy of that Itype accordingly.
9785
9786             if Present (Actual_Map) then
9787                declare
9788                   E   : Elmt_Id;
9789                   Ent : Entity_Id;
9790
9791                begin
9792                   --  Case of hash table used
9793
9794                   if NCT_Hash_Tables_Used then
9795                      Ent := NCT_Itype_Assoc.Get (Old_Node);
9796
9797                      if Present (Ent) then
9798                         Set_Associated_Node_For_Itype (Ent, New_Node);
9799                      end if;
9800
9801                   --  Case of no hash table used
9802
9803                   else
9804                      E := First_Elmt (Actual_Map);
9805                      while Present (E) loop
9806                         if Is_Itype (Node (E))
9807                           and then
9808                             Old_Node = Associated_Node_For_Itype (Node (E))
9809                         then
9810                            Set_Associated_Node_For_Itype
9811                              (Node (Next_Elmt (E)), New_Node);
9812                         end if;
9813
9814                         E := Next_Elmt (Next_Elmt (E));
9815                      end loop;
9816                   end if;
9817                end;
9818             end if;
9819
9820             --  Recursively copy descendents
9821
9822             Set_Field1
9823               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
9824             Set_Field2
9825               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
9826             Set_Field3
9827               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
9828             Set_Field4
9829               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
9830             Set_Field5
9831               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
9832
9833             --  Adjust Sloc of new node if necessary
9834
9835             if New_Sloc /= No_Location then
9836                Set_Sloc (New_Node, New_Sloc);
9837
9838                --  If we adjust the Sloc, then we are essentially making
9839                --  a completely new node, so the Comes_From_Source flag
9840                --  should be reset to the proper default value.
9841
9842                Nodes.Table (New_Node).Comes_From_Source :=
9843                  Default_Node.Comes_From_Source;
9844             end if;
9845
9846             --  If the node is call and has named associations,
9847             --  set the corresponding links in the copy.
9848
9849             if (Nkind (Old_Node) = N_Function_Call
9850                  or else Nkind (Old_Node) = N_Entry_Call_Statement
9851                  or else
9852                    Nkind (Old_Node) = N_Procedure_Call_Statement)
9853               and then Present (First_Named_Actual (Old_Node))
9854             then
9855                Adjust_Named_Associations (Old_Node, New_Node);
9856             end if;
9857
9858             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
9859             --  The replacement mechanism applies to entities, and is not used
9860             --  here. Eventually we may need a more general graph-copying
9861             --  routine. For now, do a sequential search to find desired node.
9862
9863             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
9864               and then Present (First_Real_Statement (Old_Node))
9865             then
9866                declare
9867                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
9868                   N1, N2 : Node_Id;
9869
9870                begin
9871                   N1 := First (Statements (Old_Node));
9872                   N2 := First (Statements (New_Node));
9873
9874                   while N1 /= Old_F loop
9875                      Next (N1);
9876                      Next (N2);
9877                   end loop;
9878
9879                   Set_First_Real_Statement (New_Node, N2);
9880                end;
9881             end if;
9882          end if;
9883
9884          --  All done, return copied node
9885
9886          return New_Node;
9887       end Copy_Node_With_Replacement;
9888
9889       -----------------
9890       -- Visit_Elist --
9891       -----------------
9892
9893       procedure Visit_Elist (E : Elist_Id) is
9894          Elmt : Elmt_Id;
9895       begin
9896          if Present (E) then
9897             Elmt := First_Elmt (E);
9898
9899             while Elmt /= No_Elmt loop
9900                Visit_Node (Node (Elmt));
9901                Next_Elmt (Elmt);
9902             end loop;
9903          end if;
9904       end Visit_Elist;
9905
9906       -----------------
9907       -- Visit_Field --
9908       -----------------
9909
9910       procedure Visit_Field (F : Union_Id; N : Node_Id) is
9911       begin
9912          if F = Union_Id (Empty) then
9913             return;
9914
9915          elsif F in Node_Range then
9916
9917             --  Copy node if it is syntactic, i.e. its parent pointer is
9918             --  set to point to the field that referenced it (certain
9919             --  Itypes will also meet this criterion, which is fine, since
9920             --  these are clearly Itypes that do need to be copied, since
9921             --  we are copying their parent.)
9922
9923             if Parent (Node_Id (F)) = N then
9924                Visit_Node (Node_Id (F));
9925                return;
9926
9927             --  Another case, if we are pointing to an Itype, then we want
9928             --  to copy it if its associated node is somewhere in the tree
9929             --  being copied.
9930
9931             --  Note: the exclusion of self-referential copies is just an
9932             --  optimization, since the search of the already copied list
9933             --  would catch it, but it is a common case (Etype pointing
9934             --  to itself for an Itype that is a base type).
9935
9936             elsif Has_Extension (Node_Id (F))
9937               and then Is_Itype (Entity_Id (F))
9938               and then Node_Id (F) /= N
9939             then
9940                declare
9941                   P : Node_Id;
9942
9943                begin
9944                   P := Associated_Node_For_Itype (Node_Id (F));
9945                   while Present (P) loop
9946                      if P = Source then
9947                         Visit_Node (Node_Id (F));
9948                         return;
9949                      else
9950                         P := Parent (P);
9951                      end if;
9952                   end loop;
9953
9954                   --  An Itype whose parent is not being copied definitely
9955                   --  should NOT be copied, since it does not belong in any
9956                   --  sense to the copied subtree.
9957
9958                   return;
9959                end;
9960             end if;
9961
9962          elsif F in List_Range
9963            and then Parent (List_Id (F)) = N
9964          then
9965             Visit_List (List_Id (F));
9966             return;
9967          end if;
9968       end Visit_Field;
9969
9970       -----------------
9971       -- Visit_Itype --
9972       -----------------
9973
9974       procedure Visit_Itype (Old_Itype : Entity_Id) is
9975          New_Itype : Entity_Id;
9976          E         : Elmt_Id;
9977          Ent       : Entity_Id;
9978
9979       begin
9980          --  Itypes that describe the designated type of access to subprograms
9981          --  have the structure of subprogram declarations, with signatures,
9982          --  etc. Either we duplicate the signatures completely, or choose to
9983          --  share such itypes, which is fine because their elaboration will
9984          --  have no side effects.
9985
9986          if Ekind (Old_Itype) = E_Subprogram_Type then
9987             return;
9988          end if;
9989
9990          New_Itype := New_Copy (Old_Itype);
9991
9992          --  The new Itype has all the attributes of the old one, and
9993          --  we just copy the contents of the entity. However, the back-end
9994          --  needs different names for debugging purposes, so we create a
9995          --  new internal name for it in all cases.
9996
9997          Set_Chars (New_Itype, New_Internal_Name ('T'));
9998
9999          --  If our associated node is an entity that has already been copied,
10000          --  then set the associated node of the copy to point to the right
10001          --  copy. If we have copied an Itype that is itself the associated
10002          --  node of some previously copied Itype, then we set the right
10003          --  pointer in the other direction.
10004
10005          if Present (Actual_Map) then
10006
10007             --  Case of hash tables used
10008
10009             if NCT_Hash_Tables_Used then
10010
10011                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
10012
10013                if Present (Ent) then
10014                   Set_Associated_Node_For_Itype (New_Itype, Ent);
10015                end if;
10016
10017                Ent := NCT_Itype_Assoc.Get (Old_Itype);
10018                if Present (Ent) then
10019                   Set_Associated_Node_For_Itype (Ent, New_Itype);
10020
10021                --  If the hash table has no association for this Itype and
10022                --  its associated node, enter one now.
10023
10024                else
10025                   NCT_Itype_Assoc.Set
10026                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
10027                end if;
10028
10029             --  Case of hash tables not used
10030
10031             else
10032                E := First_Elmt (Actual_Map);
10033                while Present (E) loop
10034                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
10035                      Set_Associated_Node_For_Itype
10036                        (New_Itype, Node (Next_Elmt (E)));
10037                   end if;
10038
10039                   if Is_Type (Node (E))
10040                     and then
10041                       Old_Itype = Associated_Node_For_Itype (Node (E))
10042                   then
10043                      Set_Associated_Node_For_Itype
10044                        (Node (Next_Elmt (E)), New_Itype);
10045                   end if;
10046
10047                   E := Next_Elmt (Next_Elmt (E));
10048                end loop;
10049             end if;
10050          end if;
10051
10052          if Present (Freeze_Node (New_Itype)) then
10053             Set_Is_Frozen (New_Itype, False);
10054             Set_Freeze_Node (New_Itype, Empty);
10055          end if;
10056
10057          --  Add new association to map
10058
10059          if No (Actual_Map) then
10060             Actual_Map := New_Elmt_List;
10061          end if;
10062
10063          Append_Elmt (Old_Itype, Actual_Map);
10064          Append_Elmt (New_Itype, Actual_Map);
10065
10066          if NCT_Hash_Tables_Used then
10067             NCT_Assoc.Set (Old_Itype, New_Itype);
10068
10069          else
10070             NCT_Table_Entries := NCT_Table_Entries + 1;
10071
10072             if NCT_Table_Entries > NCT_Hash_Threshold then
10073                Build_NCT_Hash_Tables;
10074             end if;
10075          end if;
10076
10077          --  If a record subtype is simply copied, the entity list will be
10078          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
10079
10080          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
10081             Set_Cloned_Subtype (New_Itype, Old_Itype);
10082          end if;
10083
10084          --  Visit descendents that eventually get copied
10085
10086          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
10087
10088          if Is_Discrete_Type (Old_Itype) then
10089             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
10090
10091          elsif Has_Discriminants (Base_Type (Old_Itype)) then
10092             --  ??? This should involve call to Visit_Field
10093             Visit_Elist (Discriminant_Constraint (Old_Itype));
10094
10095          elsif Is_Array_Type (Old_Itype) then
10096             if Present (First_Index (Old_Itype)) then
10097                Visit_Field (Union_Id (List_Containing
10098                                 (First_Index (Old_Itype))),
10099                             Old_Itype);
10100             end if;
10101
10102             if Is_Packed (Old_Itype) then
10103                Visit_Field (Union_Id (Packed_Array_Type (Old_Itype)),
10104                             Old_Itype);
10105             end if;
10106          end if;
10107       end Visit_Itype;
10108
10109       ----------------
10110       -- Visit_List --
10111       ----------------
10112
10113       procedure Visit_List (L : List_Id) is
10114          N : Node_Id;
10115       begin
10116          if L /= No_List then
10117             N := First (L);
10118
10119             while Present (N) loop
10120                Visit_Node (N);
10121                Next (N);
10122             end loop;
10123          end if;
10124       end Visit_List;
10125
10126       ----------------
10127       -- Visit_Node --
10128       ----------------
10129
10130       procedure Visit_Node (N : Node_Or_Entity_Id) is
10131
10132       --  Start of processing for Visit_Node
10133
10134       begin
10135          --  Handle case of an Itype, which must be copied
10136
10137          if Has_Extension (N)
10138            and then Is_Itype (N)
10139          then
10140             --  Nothing to do if already in the list. This can happen with an
10141             --  Itype entity that appears more than once in the tree.
10142             --  Note that we do not want to visit descendents in this case.
10143
10144             --  Test for already in list when hash table is used
10145
10146             if NCT_Hash_Tables_Used then
10147                if Present (NCT_Assoc.Get (Entity_Id (N))) then
10148                   return;
10149                end if;
10150
10151             --  Test for already in list when hash table not used
10152
10153             else
10154                declare
10155                   E : Elmt_Id;
10156                begin
10157                   if Present (Actual_Map) then
10158                      E := First_Elmt (Actual_Map);
10159                      while Present (E) loop
10160                         if Node (E) = N then
10161                            return;
10162                         else
10163                            E := Next_Elmt (Next_Elmt (E));
10164                         end if;
10165                      end loop;
10166                   end if;
10167                end;
10168             end if;
10169
10170             Visit_Itype (N);
10171          end if;
10172
10173          --  Visit descendents
10174
10175          Visit_Field (Field1 (N), N);
10176          Visit_Field (Field2 (N), N);
10177          Visit_Field (Field3 (N), N);
10178          Visit_Field (Field4 (N), N);
10179          Visit_Field (Field5 (N), N);
10180       end Visit_Node;
10181
10182    --  Start of processing for New_Copy_Tree
10183
10184    begin
10185       Actual_Map := Map;
10186
10187       --  See if we should use hash table
10188
10189       if No (Actual_Map) then
10190          NCT_Hash_Tables_Used := False;
10191
10192       else
10193          declare
10194             Elmt : Elmt_Id;
10195
10196          begin
10197             NCT_Table_Entries := 0;
10198
10199             Elmt := First_Elmt (Actual_Map);
10200             while Present (Elmt) loop
10201                NCT_Table_Entries := NCT_Table_Entries + 1;
10202                Next_Elmt (Elmt);
10203                Next_Elmt (Elmt);
10204             end loop;
10205
10206             if NCT_Table_Entries > NCT_Hash_Threshold then
10207                Build_NCT_Hash_Tables;
10208             else
10209                NCT_Hash_Tables_Used := False;
10210             end if;
10211          end;
10212       end if;
10213
10214       --  Hash table set up if required, now start phase one by visiting
10215       --  top node (we will recursively visit the descendents).
10216
10217       Visit_Node (Source);
10218
10219       --  Now the second phase of the copy can start. First we process
10220       --  all the mapped entities, copying their descendents.
10221
10222       if Present (Actual_Map) then
10223          declare
10224             Elmt      : Elmt_Id;
10225             New_Itype : Entity_Id;
10226          begin
10227             Elmt := First_Elmt (Actual_Map);
10228             while Present (Elmt) loop
10229                Next_Elmt (Elmt);
10230                New_Itype := Node (Elmt);
10231                Copy_Itype_With_Replacement (New_Itype);
10232                Next_Elmt (Elmt);
10233             end loop;
10234          end;
10235       end if;
10236
10237       --  Now we can copy the actual tree
10238
10239       return Copy_Node_With_Replacement (Source);
10240    end New_Copy_Tree;
10241
10242    -------------------------
10243    -- New_External_Entity --
10244    -------------------------
10245
10246    function New_External_Entity
10247      (Kind         : Entity_Kind;
10248       Scope_Id     : Entity_Id;
10249       Sloc_Value   : Source_Ptr;
10250       Related_Id   : Entity_Id;
10251       Suffix       : Character;
10252       Suffix_Index : Nat := 0;
10253       Prefix       : Character := ' ') return Entity_Id
10254    is
10255       N : constant Entity_Id :=
10256             Make_Defining_Identifier (Sloc_Value,
10257               New_External_Name
10258                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
10259
10260    begin
10261       Set_Ekind          (N, Kind);
10262       Set_Is_Internal    (N, True);
10263       Append_Entity      (N, Scope_Id);
10264       Set_Public_Status  (N);
10265
10266       if Kind in Type_Kind then
10267          Init_Size_Align (N);
10268       end if;
10269
10270       return N;
10271    end New_External_Entity;
10272
10273    -------------------------
10274    -- New_Internal_Entity --
10275    -------------------------
10276
10277    function New_Internal_Entity
10278      (Kind       : Entity_Kind;
10279       Scope_Id   : Entity_Id;
10280       Sloc_Value : Source_Ptr;
10281       Id_Char    : Character) return Entity_Id
10282    is
10283       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
10284
10285    begin
10286       Set_Ekind          (N, Kind);
10287       Set_Is_Internal    (N, True);
10288       Append_Entity      (N, Scope_Id);
10289
10290       if Kind in Type_Kind then
10291          Init_Size_Align (N);
10292       end if;
10293
10294       return N;
10295    end New_Internal_Entity;
10296
10297    -----------------
10298    -- Next_Actual --
10299    -----------------
10300
10301    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
10302       N  : Node_Id;
10303
10304    begin
10305       --  If we are pointing at a positional parameter, it is a member of a
10306       --  node list (the list of parameters), and the next parameter is the
10307       --  next node on the list, unless we hit a parameter association, then
10308       --  we shift to using the chain whose head is the First_Named_Actual in
10309       --  the parent, and then is threaded using the Next_Named_Actual of the
10310       --  Parameter_Association. All this fiddling is because the original node
10311       --  list is in the textual call order, and what we need is the
10312       --  declaration order.
10313
10314       if Is_List_Member (Actual_Id) then
10315          N := Next (Actual_Id);
10316
10317          if Nkind (N) = N_Parameter_Association then
10318             return First_Named_Actual (Parent (Actual_Id));
10319          else
10320             return N;
10321          end if;
10322
10323       else
10324          return Next_Named_Actual (Parent (Actual_Id));
10325       end if;
10326    end Next_Actual;
10327
10328    procedure Next_Actual (Actual_Id : in out Node_Id) is
10329    begin
10330       Actual_Id := Next_Actual (Actual_Id);
10331    end Next_Actual;
10332
10333    -----------------------
10334    -- Normalize_Actuals --
10335    -----------------------
10336
10337    --  Chain actuals according to formals of subprogram. If there are no named
10338    --  associations, the chain is simply the list of Parameter Associations,
10339    --  since the order is the same as the declaration order. If there are named
10340    --  associations, then the First_Named_Actual field in the N_Function_Call
10341    --  or N_Procedure_Call_Statement node points to the Parameter_Association
10342    --  node for the parameter that comes first in declaration order. The
10343    --  remaining named parameters are then chained in declaration order using
10344    --  Next_Named_Actual.
10345
10346    --  This routine also verifies that the number of actuals is compatible with
10347    --  the number and default values of formals, but performs no type checking
10348    --  (type checking is done by the caller).
10349
10350    --  If the matching succeeds, Success is set to True and the caller proceeds
10351    --  with type-checking. If the match is unsuccessful, then Success is set to
10352    --  False, and the caller attempts a different interpretation, if there is
10353    --  one.
10354
10355    --  If the flag Report is on, the call is not overloaded, and a failure to
10356    --  match can be reported here, rather than in the caller.
10357
10358    procedure Normalize_Actuals
10359      (N       : Node_Id;
10360       S       : Entity_Id;
10361       Report  : Boolean;
10362       Success : out Boolean)
10363    is
10364       Actuals     : constant List_Id := Parameter_Associations (N);
10365       Actual      : Node_Id := Empty;
10366       Formal      : Entity_Id;
10367       Last        : Node_Id := Empty;
10368       First_Named : Node_Id := Empty;
10369       Found       : Boolean;
10370
10371       Formals_To_Match : Integer := 0;
10372       Actuals_To_Match : Integer := 0;
10373
10374       procedure Chain (A : Node_Id);
10375       --  Add named actual at the proper place in the list, using the
10376       --  Next_Named_Actual link.
10377
10378       function Reporting return Boolean;
10379       --  Determines if an error is to be reported. To report an error, we
10380       --  need Report to be True, and also we do not report errors caused
10381       --  by calls to init procs that occur within other init procs. Such
10382       --  errors must always be cascaded errors, since if all the types are
10383       --  declared correctly, the compiler will certainly build decent calls!
10384
10385       -----------
10386       -- Chain --
10387       -----------
10388
10389       procedure Chain (A : Node_Id) is
10390       begin
10391          if No (Last) then
10392
10393             --  Call node points to first actual in list
10394
10395             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
10396
10397          else
10398             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
10399          end if;
10400
10401          Last := A;
10402          Set_Next_Named_Actual (Last, Empty);
10403       end Chain;
10404
10405       ---------------
10406       -- Reporting --
10407       ---------------
10408
10409       function Reporting return Boolean is
10410       begin
10411          if not Report then
10412             return False;
10413
10414          elsif not Within_Init_Proc then
10415             return True;
10416
10417          elsif Is_Init_Proc (Entity (Name (N))) then
10418             return False;
10419
10420          else
10421             return True;
10422          end if;
10423       end Reporting;
10424
10425    --  Start of processing for Normalize_Actuals
10426
10427    begin
10428       if Is_Access_Type (S) then
10429
10430          --  The name in the call is a function call that returns an access
10431          --  to subprogram. The designated type has the list of formals.
10432
10433          Formal := First_Formal (Designated_Type (S));
10434       else
10435          Formal := First_Formal (S);
10436       end if;
10437
10438       while Present (Formal) loop
10439          Formals_To_Match := Formals_To_Match + 1;
10440          Next_Formal (Formal);
10441       end loop;
10442
10443       --  Find if there is a named association, and verify that no positional
10444       --  associations appear after named ones.
10445
10446       if Present (Actuals) then
10447          Actual := First (Actuals);
10448       end if;
10449
10450       while Present (Actual)
10451         and then Nkind (Actual) /= N_Parameter_Association
10452       loop
10453          Actuals_To_Match := Actuals_To_Match + 1;
10454          Next (Actual);
10455       end loop;
10456
10457       if No (Actual) and Actuals_To_Match = Formals_To_Match then
10458
10459          --  Most common case: positional notation, no defaults
10460
10461          Success := True;
10462          return;
10463
10464       elsif Actuals_To_Match > Formals_To_Match then
10465
10466          --  Too many actuals: will not work
10467
10468          if Reporting then
10469             if Is_Entity_Name (Name (N)) then
10470                Error_Msg_N ("too many arguments in call to&", Name (N));
10471             else
10472                Error_Msg_N ("too many arguments in call", N);
10473             end if;
10474          end if;
10475
10476          Success := False;
10477          return;
10478       end if;
10479
10480       First_Named := Actual;
10481
10482       while Present (Actual) loop
10483          if Nkind (Actual) /= N_Parameter_Association then
10484             Error_Msg_N
10485               ("positional parameters not allowed after named ones", Actual);
10486             Success := False;
10487             return;
10488
10489          else
10490             Actuals_To_Match := Actuals_To_Match + 1;
10491          end if;
10492
10493          Next (Actual);
10494       end loop;
10495
10496       if Present (Actuals) then
10497          Actual := First (Actuals);
10498       end if;
10499
10500       Formal := First_Formal (S);
10501       while Present (Formal) loop
10502
10503          --  Match the formals in order. If the corresponding actual is
10504          --  positional, nothing to do. Else scan the list of named actuals
10505          --  to find the one with the right name.
10506
10507          if Present (Actual)
10508            and then Nkind (Actual) /= N_Parameter_Association
10509          then
10510             Next (Actual);
10511             Actuals_To_Match := Actuals_To_Match - 1;
10512             Formals_To_Match := Formals_To_Match - 1;
10513
10514          else
10515             --  For named parameters, search the list of actuals to find
10516             --  one that matches the next formal name.
10517
10518             Actual := First_Named;
10519             Found  := False;
10520             while Present (Actual) loop
10521                if Chars (Selector_Name (Actual)) = Chars (Formal) then
10522                   Found := True;
10523                   Chain (Actual);
10524                   Actuals_To_Match := Actuals_To_Match - 1;
10525                   Formals_To_Match := Formals_To_Match - 1;
10526                   exit;
10527                end if;
10528
10529                Next (Actual);
10530             end loop;
10531
10532             if not Found then
10533                if Ekind (Formal) /= E_In_Parameter
10534                  or else No (Default_Value (Formal))
10535                then
10536                   if Reporting then
10537                      if (Comes_From_Source (S)
10538                           or else Sloc (S) = Standard_Location)
10539                        and then Is_Overloadable (S)
10540                      then
10541                         if No (Actuals)
10542                           and then
10543                            (Nkind (Parent (N)) = N_Procedure_Call_Statement
10544                              or else
10545                            (Nkind (Parent (N)) = N_Function_Call
10546                              or else
10547                             Nkind (Parent (N)) = N_Parameter_Association))
10548                           and then Ekind (S) /= E_Function
10549                         then
10550                            Set_Etype (N, Etype (S));
10551                         else
10552                            Error_Msg_Name_1 := Chars (S);
10553                            Error_Msg_Sloc := Sloc (S);
10554                            Error_Msg_NE
10555                              ("missing argument for parameter & " &
10556                                 "in call to % declared #", N, Formal);
10557                         end if;
10558
10559                      elsif Is_Overloadable (S) then
10560                         Error_Msg_Name_1 := Chars (S);
10561
10562                         --  Point to type derivation that generated the
10563                         --  operation.
10564
10565                         Error_Msg_Sloc := Sloc (Parent (S));
10566
10567                         Error_Msg_NE
10568                           ("missing argument for parameter & " &
10569                              "in call to % (inherited) #", N, Formal);
10570
10571                      else
10572                         Error_Msg_NE
10573                           ("missing argument for parameter &", N, Formal);
10574                      end if;
10575                   end if;
10576
10577                   Success := False;
10578                   return;
10579
10580                else
10581                   Formals_To_Match := Formals_To_Match - 1;
10582                end if;
10583             end if;
10584          end if;
10585
10586          Next_Formal (Formal);
10587       end loop;
10588
10589       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
10590          Success := True;
10591          return;
10592
10593       else
10594          if Reporting then
10595
10596             --  Find some superfluous named actual that did not get
10597             --  attached to the list of associations.
10598
10599             Actual := First (Actuals);
10600             while Present (Actual) loop
10601                if Nkind (Actual) = N_Parameter_Association
10602                  and then Actual /= Last
10603                  and then No (Next_Named_Actual (Actual))
10604                then
10605                   Error_Msg_N ("unmatched actual & in call",
10606                     Selector_Name (Actual));
10607                   exit;
10608                end if;
10609
10610                Next (Actual);
10611             end loop;
10612          end if;
10613
10614          Success := False;
10615          return;
10616       end if;
10617    end Normalize_Actuals;
10618
10619    --------------------------------
10620    -- Note_Possible_Modification --
10621    --------------------------------
10622
10623    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
10624       Modification_Comes_From_Source : constant Boolean :=
10625                                          Comes_From_Source (Parent (N));
10626
10627       Ent : Entity_Id;
10628       Exp : Node_Id;
10629
10630    begin
10631       --  Loop to find referenced entity, if there is one
10632
10633       Exp := N;
10634       loop
10635          <<Continue>>
10636          Ent := Empty;
10637
10638          if Is_Entity_Name (Exp) then
10639             Ent := Entity (Exp);
10640
10641             --  If the entity is missing, it is an undeclared identifier,
10642             --  and there is nothing to annotate.
10643
10644             if No (Ent) then
10645                return;
10646             end if;
10647
10648          elsif Nkind (Exp) = N_Explicit_Dereference then
10649             declare
10650                P : constant Node_Id := Prefix (Exp);
10651
10652             begin
10653                --  In formal verification mode, keep track of all reads and
10654                --  writes through explicit dereferences.
10655
10656                if Alfa_Mode then
10657                   Alfa.Generate_Dereference (N, 'm');
10658                end if;
10659
10660                if Nkind (P) = N_Selected_Component
10661                  and then Present (
10662                    Entry_Formal (Entity (Selector_Name (P))))
10663                then
10664                   --  Case of a reference to an entry formal
10665
10666                   Ent := Entry_Formal (Entity (Selector_Name (P)));
10667
10668                elsif Nkind (P) = N_Identifier
10669                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
10670                  and then Present (Expression (Parent (Entity (P))))
10671                  and then Nkind (Expression (Parent (Entity (P))))
10672                    = N_Reference
10673                then
10674                   --  Case of a reference to a value on which side effects have
10675                   --  been removed.
10676
10677                   Exp := Prefix (Expression (Parent (Entity (P))));
10678                   goto Continue;
10679
10680                else
10681                   return;
10682
10683                end if;
10684             end;
10685
10686          elsif     Nkind (Exp) = N_Type_Conversion
10687            or else Nkind (Exp) = N_Unchecked_Type_Conversion
10688          then
10689             Exp := Expression (Exp);
10690             goto Continue;
10691
10692          elsif     Nkind (Exp) = N_Slice
10693            or else Nkind (Exp) = N_Indexed_Component
10694            or else Nkind (Exp) = N_Selected_Component
10695          then
10696             Exp := Prefix (Exp);
10697             goto Continue;
10698
10699          else
10700             return;
10701          end if;
10702
10703          --  Now look for entity being referenced
10704
10705          if Present (Ent) then
10706             if Is_Object (Ent) then
10707                if Comes_From_Source (Exp)
10708                  or else Modification_Comes_From_Source
10709                then
10710                   --  Give warning if pragma unmodified given and we are
10711                   --  sure this is a modification.
10712
10713                   if Has_Pragma_Unmodified (Ent) and then Sure then
10714                      Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
10715                   end if;
10716
10717                   Set_Never_Set_In_Source (Ent, False);
10718                end if;
10719
10720                Set_Is_True_Constant (Ent, False);
10721                Set_Current_Value    (Ent, Empty);
10722                Set_Is_Known_Null    (Ent, False);
10723
10724                if not Can_Never_Be_Null (Ent) then
10725                   Set_Is_Known_Non_Null (Ent, False);
10726                end if;
10727
10728                --  Follow renaming chain
10729
10730                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
10731                  and then Present (Renamed_Object (Ent))
10732                then
10733                   Exp := Renamed_Object (Ent);
10734                   goto Continue;
10735
10736                --  The expression may be the renaming of a subcomponent of an
10737                --  array or container. The assignment to the subcomponent is
10738                --  a modification of the container.
10739
10740                elsif Comes_From_Source (Original_Node (Exp))
10741                  and then Nkind_In (Original_Node (Exp), N_Selected_Component,
10742                                                          N_Indexed_Component)
10743                then
10744                   Exp := Prefix (Original_Node (Exp));
10745                   goto Continue;
10746                end if;
10747
10748                --  Generate a reference only if the assignment comes from
10749                --  source. This excludes, for example, calls to a dispatching
10750                --  assignment operation when the left-hand side is tagged.
10751
10752                if Modification_Comes_From_Source then
10753                   Generate_Reference (Ent, Exp, 'm');
10754
10755                   --  If the target of the assignment is the bound variable
10756                   --  in an iterator, indicate that the corresponding array
10757                   --  or container is also modified.
10758
10759                   if Ada_Version >= Ada_2012
10760                     and then
10761                       Nkind (Parent (Ent)) = N_Iterator_Specification
10762                   then
10763                      declare
10764                         Domain : constant Node_Id := Name (Parent (Ent));
10765
10766                      begin
10767                         --  TBD : in the full version of the construct, the
10768                         --  domain of iteration can be given by an expression.
10769
10770                         if Is_Entity_Name (Domain) then
10771                            Generate_Reference      (Entity (Domain), Exp, 'm');
10772                            Set_Is_True_Constant    (Entity (Domain), False);
10773                            Set_Never_Set_In_Source (Entity (Domain), False);
10774                         end if;
10775                      end;
10776                   end if;
10777                end if;
10778
10779                Check_Nested_Access (Ent);
10780             end if;
10781
10782             Kill_Checks (Ent);
10783
10784             --  If we are sure this is a modification from source, and we know
10785             --  this modifies a constant, then give an appropriate warning.
10786
10787             if Overlays_Constant (Ent)
10788               and then Modification_Comes_From_Source
10789               and then Sure
10790             then
10791                declare
10792                   A : constant Node_Id := Address_Clause (Ent);
10793                begin
10794                   if Present (A) then
10795                      declare
10796                         Exp : constant Node_Id := Expression (A);
10797                      begin
10798                         if Nkind (Exp) = N_Attribute_Reference
10799                           and then Attribute_Name (Exp) = Name_Address
10800                           and then Is_Entity_Name (Prefix (Exp))
10801                         then
10802                            Error_Msg_Sloc := Sloc (A);
10803                            Error_Msg_NE
10804                              ("constant& may be modified via address clause#?",
10805                               N, Entity (Prefix (Exp)));
10806                         end if;
10807                      end;
10808                   end if;
10809                end;
10810             end if;
10811
10812             return;
10813          end if;
10814       end loop;
10815    end Note_Possible_Modification;
10816
10817    -------------------------
10818    -- Object_Access_Level --
10819    -------------------------
10820
10821    function Object_Access_Level (Obj : Node_Id) return Uint is
10822       E : Entity_Id;
10823
10824    --  Returns the static accessibility level of the view denoted by Obj. Note
10825    --  that the value returned is the result of a call to Scope_Depth. Only
10826    --  scope depths associated with dynamic scopes can actually be returned.
10827    --  Since only relative levels matter for accessibility checking, the fact
10828    --  that the distance between successive levels of accessibility is not
10829    --  always one is immaterial (invariant: if level(E2) is deeper than
10830    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
10831
10832       function Reference_To (Obj : Node_Id) return Node_Id;
10833       --  An explicit dereference is created when removing side-effects from
10834       --  expressions for constraint checking purposes. In this case a local
10835       --  access type is created for it. The correct access level is that of
10836       --  the original source node. We detect this case by noting that the
10837       --  prefix of the dereference is created by an object declaration whose
10838       --  initial expression is a reference.
10839
10840       ------------------
10841       -- Reference_To --
10842       ------------------
10843
10844       function Reference_To (Obj : Node_Id) return Node_Id is
10845          Pref : constant Node_Id := Prefix (Obj);
10846       begin
10847          if Is_Entity_Name (Pref)
10848            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
10849            and then Present (Expression (Parent (Entity (Pref))))
10850            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
10851          then
10852             return (Prefix (Expression (Parent (Entity (Pref)))));
10853          else
10854             return Empty;
10855          end if;
10856       end Reference_To;
10857
10858    --  Start of processing for Object_Access_Level
10859
10860    begin
10861       if Nkind (Obj) = N_Defining_Identifier
10862         or else Is_Entity_Name (Obj)
10863       then
10864          if Nkind (Obj) = N_Defining_Identifier then
10865             E := Obj;
10866          else
10867             E := Entity (Obj);
10868          end if;
10869
10870          if Is_Prival (E) then
10871             E := Prival_Link (E);
10872          end if;
10873
10874          --  If E is a type then it denotes a current instance. For this case
10875          --  we add one to the normal accessibility level of the type to ensure
10876          --  that current instances are treated as always being deeper than
10877          --  than the level of any visible named access type (see 3.10.2(21)).
10878
10879          if Is_Type (E) then
10880             return Type_Access_Level (E) +  1;
10881
10882          elsif Present (Renamed_Object (E)) then
10883             return Object_Access_Level (Renamed_Object (E));
10884
10885          --  Similarly, if E is a component of the current instance of a
10886          --  protected type, any instance of it is assumed to be at a deeper
10887          --  level than the type. For a protected object (whose type is an
10888          --  anonymous protected type) its components are at the same level
10889          --  as the type itself.
10890
10891          elsif not Is_Overloadable (E)
10892            and then Ekind (Scope (E)) = E_Protected_Type
10893            and then Comes_From_Source (Scope (E))
10894          then
10895             return Type_Access_Level (Scope (E)) + 1;
10896
10897          else
10898             return Scope_Depth (Enclosing_Dynamic_Scope (E));
10899          end if;
10900
10901       elsif Nkind (Obj) = N_Selected_Component then
10902          if Is_Access_Type (Etype (Prefix (Obj))) then
10903             return Type_Access_Level (Etype (Prefix (Obj)));
10904          else
10905             return Object_Access_Level (Prefix (Obj));
10906          end if;
10907
10908       elsif Nkind (Obj) = N_Indexed_Component then
10909          if Is_Access_Type (Etype (Prefix (Obj))) then
10910             return Type_Access_Level (Etype (Prefix (Obj)));
10911          else
10912             return Object_Access_Level (Prefix (Obj));
10913          end if;
10914
10915       elsif Nkind (Obj) = N_Explicit_Dereference then
10916
10917          --  If the prefix is a selected access discriminant then we make a
10918          --  recursive call on the prefix, which will in turn check the level
10919          --  of the prefix object of the selected discriminant.
10920
10921          if Nkind (Prefix (Obj)) = N_Selected_Component
10922            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
10923            and then
10924              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
10925          then
10926             return Object_Access_Level (Prefix (Obj));
10927
10928          elsif not (Comes_From_Source (Obj)) then
10929             declare
10930                Ref : constant Node_Id := Reference_To (Obj);
10931             begin
10932                if Present (Ref) then
10933                   return Object_Access_Level (Ref);
10934                else
10935                   return Type_Access_Level (Etype (Prefix (Obj)));
10936                end if;
10937             end;
10938
10939          else
10940             return Type_Access_Level (Etype (Prefix (Obj)));
10941          end if;
10942
10943       elsif Nkind (Obj) = N_Type_Conversion
10944         or else Nkind (Obj) = N_Unchecked_Type_Conversion
10945       then
10946          return Object_Access_Level (Expression (Obj));
10947
10948       elsif Nkind (Obj) = N_Function_Call then
10949
10950          --  Function results are objects, so we get either the access level of
10951          --  the function or, in the case of an indirect call, the level of the
10952          --  access-to-subprogram type. (This code is used for Ada 95, but it
10953          --  looks wrong, because it seems that we should be checking the level
10954          --  of the call itself, even for Ada 95. However, using the Ada 2005
10955          --  version of the code causes regressions in several tests that are
10956          --  compiled with -gnat95. ???)
10957
10958          if Ada_Version < Ada_2005 then
10959             if Is_Entity_Name (Name (Obj)) then
10960                return Subprogram_Access_Level (Entity (Name (Obj)));
10961             else
10962                return Type_Access_Level (Etype (Prefix (Name (Obj))));
10963             end if;
10964
10965          --  For Ada 2005, the level of the result object of a function call is
10966          --  defined to be the level of the call's innermost enclosing master.
10967          --  We determine that by querying the depth of the innermost enclosing
10968          --  dynamic scope.
10969
10970          else
10971             Return_Master_Scope_Depth_Of_Call : declare
10972
10973                function Innermost_Master_Scope_Depth
10974                  (N : Node_Id) return Uint;
10975                --  Returns the scope depth of the given node's innermost
10976                --  enclosing dynamic scope (effectively the accessibility
10977                --  level of the innermost enclosing master).
10978
10979                ----------------------------------
10980                -- Innermost_Master_Scope_Depth --
10981                ----------------------------------
10982
10983                function Innermost_Master_Scope_Depth
10984                  (N : Node_Id) return Uint
10985                is
10986                   Node_Par : Node_Id := Parent (N);
10987
10988                begin
10989                   --  Locate the nearest enclosing node (by traversing Parents)
10990                   --  that Defining_Entity can be applied to, and return the
10991                   --  depth of that entity's nearest enclosing dynamic scope.
10992
10993                   while Present (Node_Par) loop
10994                      case Nkind (Node_Par) is
10995                         when N_Component_Declaration           |
10996                              N_Entry_Declaration               |
10997                              N_Formal_Object_Declaration       |
10998                              N_Formal_Type_Declaration         |
10999                              N_Full_Type_Declaration           |
11000                              N_Incomplete_Type_Declaration     |
11001                              N_Loop_Parameter_Specification    |
11002                              N_Object_Declaration              |
11003                              N_Protected_Type_Declaration      |
11004                              N_Private_Extension_Declaration   |
11005                              N_Private_Type_Declaration        |
11006                              N_Subtype_Declaration             |
11007                              N_Function_Specification          |
11008                              N_Procedure_Specification         |
11009                              N_Task_Type_Declaration           |
11010                              N_Body_Stub                       |
11011                              N_Generic_Instantiation           |
11012                              N_Proper_Body                     |
11013                              N_Implicit_Label_Declaration      |
11014                              N_Package_Declaration             |
11015                              N_Single_Task_Declaration         |
11016                              N_Subprogram_Declaration          |
11017                              N_Generic_Declaration             |
11018                              N_Renaming_Declaration            |
11019                              N_Block_Statement                 |
11020                              N_Formal_Subprogram_Declaration   |
11021                              N_Abstract_Subprogram_Declaration |
11022                              N_Entry_Body                      |
11023                              N_Exception_Declaration           |
11024                              N_Formal_Package_Declaration      |
11025                              N_Number_Declaration              |
11026                              N_Package_Specification           |
11027                              N_Parameter_Specification         |
11028                              N_Single_Protected_Declaration    |
11029                              N_Subunit                         =>
11030
11031                            return Scope_Depth
11032                                     (Nearest_Dynamic_Scope
11033                                        (Defining_Entity (Node_Par)));
11034
11035                         when others =>
11036                            null;
11037                      end case;
11038
11039                      Node_Par := Parent (Node_Par);
11040                   end loop;
11041
11042                   pragma Assert (False);
11043
11044                   --  Should never reach the following return
11045
11046                   return Scope_Depth (Current_Scope) + 1;
11047                end Innermost_Master_Scope_Depth;
11048
11049             --  Start of processing for Return_Master_Scope_Depth_Of_Call
11050
11051             begin
11052                return Innermost_Master_Scope_Depth (Obj);
11053             end Return_Master_Scope_Depth_Of_Call;
11054          end if;
11055
11056       --  For convenience we handle qualified expressions, even though
11057       --  they aren't technically object names.
11058
11059       elsif Nkind (Obj) = N_Qualified_Expression then
11060          return Object_Access_Level (Expression (Obj));
11061
11062       --  Otherwise return the scope level of Standard.
11063       --  (If there are cases that fall through
11064       --  to this point they will be treated as
11065       --  having global accessibility for now. ???)
11066
11067       else
11068          return Scope_Depth (Standard_Standard);
11069       end if;
11070    end Object_Access_Level;
11071
11072    --------------------------------------
11073    -- Original_Corresponding_Operation --
11074    --------------------------------------
11075
11076    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
11077    is
11078       Typ : constant Entity_Id := Find_Dispatching_Type (S);
11079
11080    begin
11081       --  If S is an inherited primitive S2 the original corresponding
11082       --  operation of S is the original corresponding operation of S2
11083
11084       if Present (Alias (S))
11085         and then Find_Dispatching_Type (Alias (S)) /= Typ
11086       then
11087          return Original_Corresponding_Operation (Alias (S));
11088
11089       --  If S overrides an inherited subprogram S2 the original corresponding
11090       --  operation of S is the original corresponding operation of S2
11091
11092       elsif Present (Overridden_Operation (S)) then
11093          return Original_Corresponding_Operation (Overridden_Operation (S));
11094
11095       --  otherwise it is S itself
11096
11097       else
11098          return S;
11099       end if;
11100    end Original_Corresponding_Operation;
11101
11102    -----------------------
11103    -- Private_Component --
11104    -----------------------
11105
11106    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
11107       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
11108
11109       function Trace_Components
11110         (T     : Entity_Id;
11111          Check : Boolean) return Entity_Id;
11112       --  Recursive function that does the work, and checks against circular
11113       --  definition for each subcomponent type.
11114
11115       ----------------------
11116       -- Trace_Components --
11117       ----------------------
11118
11119       function Trace_Components
11120          (T     : Entity_Id;
11121           Check : Boolean) return Entity_Id
11122        is
11123          Btype     : constant Entity_Id := Base_Type (T);
11124          Component : Entity_Id;
11125          P         : Entity_Id;
11126          Candidate : Entity_Id := Empty;
11127
11128       begin
11129          if Check and then Btype = Ancestor then
11130             Error_Msg_N ("circular type definition", Type_Id);
11131             return Any_Type;
11132          end if;
11133
11134          if Is_Private_Type (Btype)
11135            and then not Is_Generic_Type (Btype)
11136          then
11137             if Present (Full_View (Btype))
11138               and then Is_Record_Type (Full_View (Btype))
11139               and then not Is_Frozen (Btype)
11140             then
11141                --  To indicate that the ancestor depends on a private type, the
11142                --  current Btype is sufficient. However, to check for circular
11143                --  definition we must recurse on the full view.
11144
11145                Candidate := Trace_Components (Full_View (Btype), True);
11146
11147                if Candidate = Any_Type then
11148                   return Any_Type;
11149                else
11150                   return Btype;
11151                end if;
11152
11153             else
11154                return Btype;
11155             end if;
11156
11157          elsif Is_Array_Type (Btype) then
11158             return Trace_Components (Component_Type (Btype), True);
11159
11160          elsif Is_Record_Type (Btype) then
11161             Component := First_Entity (Btype);
11162             while Present (Component)
11163               and then Comes_From_Source (Component)
11164             loop
11165                --  Skip anonymous types generated by constrained components
11166
11167                if not Is_Type (Component) then
11168                   P := Trace_Components (Etype (Component), True);
11169
11170                   if Present (P) then
11171                      if P = Any_Type then
11172                         return P;
11173                      else
11174                         Candidate := P;
11175                      end if;
11176                   end if;
11177                end if;
11178
11179                Next_Entity (Component);
11180             end loop;
11181
11182             return Candidate;
11183
11184          else
11185             return Empty;
11186          end if;
11187       end Trace_Components;
11188
11189    --  Start of processing for Private_Component
11190
11191    begin
11192       return Trace_Components (Type_Id, False);
11193    end Private_Component;
11194
11195    ---------------------------
11196    -- Primitive_Names_Match --
11197    ---------------------------
11198
11199    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
11200
11201       function Non_Internal_Name (E : Entity_Id) return Name_Id;
11202       --  Given an internal name, returns the corresponding non-internal name
11203
11204       ------------------------
11205       --  Non_Internal_Name --
11206       ------------------------
11207
11208       function Non_Internal_Name (E : Entity_Id) return Name_Id is
11209       begin
11210          Get_Name_String (Chars (E));
11211          Name_Len := Name_Len - 1;
11212          return Name_Find;
11213       end Non_Internal_Name;
11214
11215    --  Start of processing for Primitive_Names_Match
11216
11217    begin
11218       pragma Assert (Present (E1) and then Present (E2));
11219
11220       return Chars (E1) = Chars (E2)
11221         or else
11222            (not Is_Internal_Name (Chars (E1))
11223               and then Is_Internal_Name (Chars (E2))
11224               and then Non_Internal_Name (E2) = Chars (E1))
11225         or else
11226            (not Is_Internal_Name (Chars (E2))
11227               and then Is_Internal_Name (Chars (E1))
11228               and then Non_Internal_Name (E1) = Chars (E2))
11229         or else
11230            (Is_Predefined_Dispatching_Operation (E1)
11231               and then Is_Predefined_Dispatching_Operation (E2)
11232               and then Same_TSS (E1, E2))
11233         or else
11234            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
11235    end Primitive_Names_Match;
11236
11237    -----------------------
11238    -- Process_End_Label --
11239    -----------------------
11240
11241    procedure Process_End_Label
11242      (N   : Node_Id;
11243       Typ : Character;
11244       Ent : Entity_Id)
11245    is
11246       Loc  : Source_Ptr;
11247       Nam  : Node_Id;
11248       Scop : Entity_Id;
11249
11250       Label_Ref : Boolean;
11251       --  Set True if reference to end label itself is required
11252
11253       Endl : Node_Id;
11254       --  Gets set to the operator symbol or identifier that references the
11255       --  entity Ent. For the child unit case, this is the identifier from the
11256       --  designator. For other cases, this is simply Endl.
11257
11258       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
11259       --  N is an identifier node that appears as a parent unit reference in
11260       --  the case where Ent is a child unit. This procedure generates an
11261       --  appropriate cross-reference entry. E is the corresponding entity.
11262
11263       -------------------------
11264       -- Generate_Parent_Ref --
11265       -------------------------
11266
11267       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
11268       begin
11269          --  If names do not match, something weird, skip reference
11270
11271          if Chars (E) = Chars (N) then
11272
11273             --  Generate the reference. We do NOT consider this as a reference
11274             --  for unreferenced symbol purposes.
11275
11276             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
11277
11278             if Style_Check then
11279                Style.Check_Identifier (N, E);
11280             end if;
11281          end if;
11282       end Generate_Parent_Ref;
11283
11284    --  Start of processing for Process_End_Label
11285
11286    begin
11287       --  If no node, ignore. This happens in some error situations, and
11288       --  also for some internally generated structures where no end label
11289       --  references are required in any case.
11290
11291       if No (N) then
11292          return;
11293       end if;
11294
11295       --  Nothing to do if no End_Label, happens for internally generated
11296       --  constructs where we don't want an end label reference anyway. Also
11297       --  nothing to do if Endl is a string literal, which means there was
11298       --  some prior error (bad operator symbol)
11299
11300       Endl := End_Label (N);
11301
11302       if No (Endl) or else Nkind (Endl) = N_String_Literal then
11303          return;
11304       end if;
11305
11306       --  Reference node is not in extended main source unit
11307
11308       if not In_Extended_Main_Source_Unit (N) then
11309
11310          --  Generally we do not collect references except for the extended
11311          --  main source unit. The one exception is the 'e' entry for a
11312          --  package spec, where it is useful for a client to have the
11313          --  ending information to define scopes.
11314
11315          if Typ /= 'e' then
11316             return;
11317
11318          else
11319             Label_Ref := False;
11320
11321             --  For this case, we can ignore any parent references, but we
11322             --  need the package name itself for the 'e' entry.
11323
11324             if Nkind (Endl) = N_Designator then
11325                Endl := Identifier (Endl);
11326             end if;
11327          end if;
11328
11329       --  Reference is in extended main source unit
11330
11331       else
11332          Label_Ref := True;
11333
11334          --  For designator, generate references for the parent entries
11335
11336          if Nkind (Endl) = N_Designator then
11337
11338             --  Generate references for the prefix if the END line comes from
11339             --  source (otherwise we do not need these references) We climb the
11340             --  scope stack to find the expected entities.
11341
11342             if Comes_From_Source (Endl) then
11343                Nam  := Name (Endl);
11344                Scop := Current_Scope;
11345                while Nkind (Nam) = N_Selected_Component loop
11346                   Scop := Scope (Scop);
11347                   exit when No (Scop);
11348                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
11349                   Nam := Prefix (Nam);
11350                end loop;
11351
11352                if Present (Scop) then
11353                   Generate_Parent_Ref (Nam, Scope (Scop));
11354                end if;
11355             end if;
11356
11357             Endl := Identifier (Endl);
11358          end if;
11359       end if;
11360
11361       --  If the end label is not for the given entity, then either we have
11362       --  some previous error, or this is a generic instantiation for which
11363       --  we do not need to make a cross-reference in this case anyway. In
11364       --  either case we simply ignore the call.
11365
11366       if Chars (Ent) /= Chars (Endl) then
11367          return;
11368       end if;
11369
11370       --  If label was really there, then generate a normal reference and then
11371       --  adjust the location in the end label to point past the name (which
11372       --  should almost always be the semicolon).
11373
11374       Loc := Sloc (Endl);
11375
11376       if Comes_From_Source (Endl) then
11377
11378          --  If a label reference is required, then do the style check and
11379          --  generate an l-type cross-reference entry for the label
11380
11381          if Label_Ref then
11382             if Style_Check then
11383                Style.Check_Identifier (Endl, Ent);
11384             end if;
11385
11386             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
11387          end if;
11388
11389          --  Set the location to point past the label (normally this will
11390          --  mean the semicolon immediately following the label). This is
11391          --  done for the sake of the 'e' or 't' entry generated below.
11392
11393          Get_Decoded_Name_String (Chars (Endl));
11394          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
11395
11396       else
11397          --  In SPARK mode, no missing label is allowed for packages and
11398          --  subprogram bodies. Detect those cases by testing whether
11399          --  Process_End_Label was called for a body (Typ = 't') or a package.
11400
11401          if Restriction_Check_Required (SPARK)
11402            and then (Typ = 't' or else Ekind (Ent) = E_Package)
11403          then
11404             Error_Msg_Node_1 := Endl;
11405             Check_SPARK_Restriction ("`END &` required", Endl, Force => True);
11406          end if;
11407       end if;
11408
11409       --  Now generate the e/t reference
11410
11411       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
11412
11413       --  Restore Sloc, in case modified above, since we have an identifier
11414       --  and the normal Sloc should be left set in the tree.
11415
11416       Set_Sloc (Endl, Loc);
11417    end Process_End_Label;
11418
11419    ------------------------------------
11420    -- References_Generic_Formal_Type --
11421    ------------------------------------
11422
11423    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
11424
11425       function Process (N : Node_Id) return Traverse_Result;
11426       --  Process one node in search for generic formal type
11427
11428       -------------
11429       -- Process --
11430       -------------
11431
11432       function Process (N : Node_Id) return Traverse_Result is
11433       begin
11434          if Nkind (N) in N_Has_Entity then
11435             declare
11436                E : constant Entity_Id := Entity (N);
11437             begin
11438                if Present (E) then
11439                   if Is_Generic_Type (E) then
11440                      return Abandon;
11441                   elsif Present (Etype (E))
11442                     and then Is_Generic_Type (Etype (E))
11443                   then
11444                      return Abandon;
11445                   end if;
11446                end if;
11447             end;
11448          end if;
11449
11450          return Atree.OK;
11451       end Process;
11452
11453       function Traverse is new Traverse_Func (Process);
11454       --  Traverse tree to look for generic type
11455
11456    begin
11457       if Inside_A_Generic then
11458          return Traverse (N) = Abandon;
11459       else
11460          return False;
11461       end if;
11462    end References_Generic_Formal_Type;
11463
11464    --------------------
11465    -- Remove_Homonym --
11466    --------------------
11467
11468    procedure Remove_Homonym (E : Entity_Id) is
11469       Prev  : Entity_Id := Empty;
11470       H     : Entity_Id;
11471
11472    begin
11473       if E = Current_Entity (E) then
11474          if Present (Homonym (E)) then
11475             Set_Current_Entity (Homonym (E));
11476          else
11477             Set_Name_Entity_Id (Chars (E), Empty);
11478          end if;
11479       else
11480          H := Current_Entity (E);
11481          while Present (H) and then H /= E loop
11482             Prev := H;
11483             H    := Homonym (H);
11484          end loop;
11485
11486          Set_Homonym (Prev, Homonym (E));
11487       end if;
11488    end Remove_Homonym;
11489
11490    ---------------------
11491    -- Rep_To_Pos_Flag --
11492    ---------------------
11493
11494    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
11495    begin
11496       return New_Occurrence_Of
11497                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
11498    end Rep_To_Pos_Flag;
11499
11500    --------------------
11501    -- Require_Entity --
11502    --------------------
11503
11504    procedure Require_Entity (N : Node_Id) is
11505    begin
11506       if Is_Entity_Name (N) and then No (Entity (N)) then
11507          if Total_Errors_Detected /= 0 then
11508             Set_Entity (N, Any_Id);
11509          else
11510             raise Program_Error;
11511          end if;
11512       end if;
11513    end Require_Entity;
11514
11515    ------------------------------
11516    -- Requires_Transient_Scope --
11517    ------------------------------
11518
11519    --  A transient scope is required when variable-sized temporaries are
11520    --  allocated in the primary or secondary stack, or when finalization
11521    --  actions must be generated before the next instruction.
11522
11523    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
11524       Typ : constant Entity_Id := Underlying_Type (Id);
11525
11526    --  Start of processing for Requires_Transient_Scope
11527
11528    begin
11529       --  This is a private type which is not completed yet. This can only
11530       --  happen in a default expression (of a formal parameter or of a
11531       --  record component). Do not expand transient scope in this case
11532
11533       if No (Typ) then
11534          return False;
11535
11536       --  Do not expand transient scope for non-existent procedure return
11537
11538       elsif Typ = Standard_Void_Type then
11539          return False;
11540
11541       --  Elementary types do not require a transient scope
11542
11543       elsif Is_Elementary_Type (Typ) then
11544          return False;
11545
11546       --  Generally, indefinite subtypes require a transient scope, since the
11547       --  back end cannot generate temporaries, since this is not a valid type
11548       --  for declaring an object. It might be possible to relax this in the
11549       --  future, e.g. by declaring the maximum possible space for the type.
11550
11551       elsif Is_Indefinite_Subtype (Typ) then
11552          return True;
11553
11554       --  Functions returning tagged types may dispatch on result so their
11555       --  returned value is allocated on the secondary stack. Controlled
11556       --  type temporaries need finalization.
11557
11558       elsif Is_Tagged_Type (Typ)
11559         or else Has_Controlled_Component (Typ)
11560       then
11561          return not Is_Value_Type (Typ);
11562
11563       --  Record type
11564
11565       elsif Is_Record_Type (Typ) then
11566          declare
11567             Comp : Entity_Id;
11568          begin
11569             Comp := First_Entity (Typ);
11570             while Present (Comp) loop
11571                if Ekind (Comp) = E_Component
11572                   and then Requires_Transient_Scope (Etype (Comp))
11573                then
11574                   return True;
11575                else
11576                   Next_Entity (Comp);
11577                end if;
11578             end loop;
11579          end;
11580
11581          return False;
11582
11583       --  String literal types never require transient scope
11584
11585       elsif Ekind (Typ) = E_String_Literal_Subtype then
11586          return False;
11587
11588       --  Array type. Note that we already know that this is a constrained
11589       --  array, since unconstrained arrays will fail the indefinite test.
11590
11591       elsif Is_Array_Type (Typ) then
11592
11593          --  If component type requires a transient scope, the array does too
11594
11595          if Requires_Transient_Scope (Component_Type (Typ)) then
11596             return True;
11597
11598          --  Otherwise, we only need a transient scope if the size depends on
11599          --  the value of one or more discriminants.
11600
11601          else
11602             return Size_Depends_On_Discriminant (Typ);
11603          end if;
11604
11605       --  All other cases do not require a transient scope
11606
11607       else
11608          return False;
11609       end if;
11610    end Requires_Transient_Scope;
11611
11612    --------------------------
11613    -- Reset_Analyzed_Flags --
11614    --------------------------
11615
11616    procedure Reset_Analyzed_Flags (N : Node_Id) is
11617
11618       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
11619       --  Function used to reset Analyzed flags in tree. Note that we do
11620       --  not reset Analyzed flags in entities, since there is no need to
11621       --  reanalyze entities, and indeed, it is wrong to do so, since it
11622       --  can result in generating auxiliary stuff more than once.
11623
11624       --------------------
11625       -- Clear_Analyzed --
11626       --------------------
11627
11628       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
11629       begin
11630          if not Has_Extension (N) then
11631             Set_Analyzed (N, False);
11632          end if;
11633
11634          return OK;
11635       end Clear_Analyzed;
11636
11637       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
11638
11639    --  Start of processing for Reset_Analyzed_Flags
11640
11641    begin
11642       Reset_Analyzed (N);
11643    end Reset_Analyzed_Flags;
11644
11645    ---------------------------
11646    -- Safe_To_Capture_Value --
11647    ---------------------------
11648
11649    function Safe_To_Capture_Value
11650      (N    : Node_Id;
11651       Ent  : Entity_Id;
11652       Cond : Boolean := False) return Boolean
11653    is
11654    begin
11655       --  The only entities for which we track constant values are variables
11656       --  which are not renamings, constants, out parameters, and in out
11657       --  parameters, so check if we have this case.
11658
11659       --  Note: it may seem odd to track constant values for constants, but in
11660       --  fact this routine is used for other purposes than simply capturing
11661       --  the value. In particular, the setting of Known[_Non]_Null.
11662
11663       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
11664             or else
11665           Ekind (Ent) = E_Constant
11666             or else
11667           Ekind (Ent) = E_Out_Parameter
11668             or else
11669           Ekind (Ent) = E_In_Out_Parameter
11670       then
11671          null;
11672
11673       --  For conditionals, we also allow loop parameters and all formals,
11674       --  including in parameters.
11675
11676       elsif Cond
11677         and then
11678           (Ekind (Ent) = E_Loop_Parameter
11679              or else
11680            Ekind (Ent) = E_In_Parameter)
11681       then
11682          null;
11683
11684       --  For all other cases, not just unsafe, but impossible to capture
11685       --  Current_Value, since the above are the only entities which have
11686       --  Current_Value fields.
11687
11688       else
11689          return False;
11690       end if;
11691
11692       --  Skip if volatile or aliased, since funny things might be going on in
11693       --  these cases which we cannot necessarily track. Also skip any variable
11694       --  for which an address clause is given, or whose address is taken. Also
11695       --  never capture value of library level variables (an attempt to do so
11696       --  can occur in the case of package elaboration code).
11697
11698       if Treat_As_Volatile (Ent)
11699         or else Is_Aliased (Ent)
11700         or else Present (Address_Clause (Ent))
11701         or else Address_Taken (Ent)
11702         or else (Is_Library_Level_Entity (Ent)
11703                    and then Ekind (Ent) = E_Variable)
11704       then
11705          return False;
11706       end if;
11707
11708       --  OK, all above conditions are met. We also require that the scope of
11709       --  the reference be the same as the scope of the entity, not counting
11710       --  packages and blocks and loops.
11711
11712       declare
11713          E_Scope : constant Entity_Id := Scope (Ent);
11714          R_Scope : Entity_Id;
11715
11716       begin
11717          R_Scope := Current_Scope;
11718          while R_Scope /= Standard_Standard loop
11719             exit when R_Scope = E_Scope;
11720
11721             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
11722                return False;
11723             else
11724                R_Scope := Scope (R_Scope);
11725             end if;
11726          end loop;
11727       end;
11728
11729       --  We also require that the reference does not appear in a context
11730       --  where it is not sure to be executed (i.e. a conditional context
11731       --  or an exception handler). We skip this if Cond is True, since the
11732       --  capturing of values from conditional tests handles this ok.
11733
11734       if Cond then
11735          return True;
11736       end if;
11737
11738       declare
11739          Desc : Node_Id;
11740          P    : Node_Id;
11741
11742       begin
11743          Desc := N;
11744
11745          P := Parent (N);
11746          while Present (P) loop
11747             if         Nkind (P) = N_If_Statement
11748               or else  Nkind (P) = N_Case_Statement
11749               or else (Nkind (P) in N_Short_Circuit
11750                          and then Desc = Right_Opnd (P))
11751               or else (Nkind (P) = N_Conditional_Expression
11752                          and then Desc /= First (Expressions (P)))
11753               or else  Nkind (P) = N_Exception_Handler
11754               or else  Nkind (P) = N_Selective_Accept
11755               or else  Nkind (P) = N_Conditional_Entry_Call
11756               or else  Nkind (P) = N_Timed_Entry_Call
11757               or else  Nkind (P) = N_Asynchronous_Select
11758             then
11759                return False;
11760             else
11761                Desc := P;
11762                P    := Parent (P);
11763             end if;
11764          end loop;
11765       end;
11766
11767       --  OK, looks safe to set value
11768
11769       return True;
11770    end Safe_To_Capture_Value;
11771
11772    ---------------
11773    -- Same_Name --
11774    ---------------
11775
11776    function Same_Name (N1, N2 : Node_Id) return Boolean is
11777       K1 : constant Node_Kind := Nkind (N1);
11778       K2 : constant Node_Kind := Nkind (N2);
11779
11780    begin
11781       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
11782         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
11783       then
11784          return Chars (N1) = Chars (N2);
11785
11786       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
11787         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
11788       then
11789          return Same_Name (Selector_Name (N1), Selector_Name (N2))
11790            and then Same_Name (Prefix (N1), Prefix (N2));
11791
11792       else
11793          return False;
11794       end if;
11795    end Same_Name;
11796
11797    -----------------
11798    -- Same_Object --
11799    -----------------
11800
11801    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
11802       N1 : constant Node_Id := Original_Node (Node1);
11803       N2 : constant Node_Id := Original_Node (Node2);
11804       --  We do the tests on original nodes, since we are most interested
11805       --  in the original source, not any expansion that got in the way.
11806
11807       K1 : constant Node_Kind := Nkind (N1);
11808       K2 : constant Node_Kind := Nkind (N2);
11809
11810    begin
11811       --  First case, both are entities with same entity
11812
11813       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
11814          declare
11815             EN1 : constant Entity_Id := Entity (N1);
11816             EN2 : constant Entity_Id := Entity (N2);
11817          begin
11818             if Present (EN1) and then Present (EN2)
11819               and then (Ekind_In (EN1, E_Variable, E_Constant)
11820                          or else Is_Formal (EN1))
11821               and then EN1 = EN2
11822             then
11823                return True;
11824             end if;
11825          end;
11826       end if;
11827
11828       --  Second case, selected component with same selector, same record
11829
11830       if K1 = N_Selected_Component
11831         and then K2 = N_Selected_Component
11832         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
11833       then
11834          return Same_Object (Prefix (N1), Prefix (N2));
11835
11836       --  Third case, indexed component with same subscripts, same array
11837
11838       elsif K1 = N_Indexed_Component
11839         and then K2 = N_Indexed_Component
11840         and then Same_Object (Prefix (N1), Prefix (N2))
11841       then
11842          declare
11843             E1, E2 : Node_Id;
11844          begin
11845             E1 := First (Expressions (N1));
11846             E2 := First (Expressions (N2));
11847             while Present (E1) loop
11848                if not Same_Value (E1, E2) then
11849                   return False;
11850                else
11851                   Next (E1);
11852                   Next (E2);
11853                end if;
11854             end loop;
11855
11856             return True;
11857          end;
11858
11859       --  Fourth case, slice of same array with same bounds
11860
11861       elsif K1 = N_Slice
11862         and then K2 = N_Slice
11863         and then Nkind (Discrete_Range (N1)) = N_Range
11864         and then Nkind (Discrete_Range (N2)) = N_Range
11865         and then Same_Value (Low_Bound (Discrete_Range (N1)),
11866                              Low_Bound (Discrete_Range (N2)))
11867         and then Same_Value (High_Bound (Discrete_Range (N1)),
11868                              High_Bound (Discrete_Range (N2)))
11869       then
11870          return Same_Name (Prefix (N1), Prefix (N2));
11871
11872       --  All other cases, not clearly the same object
11873
11874       else
11875          return False;
11876       end if;
11877    end Same_Object;
11878
11879    ---------------
11880    -- Same_Type --
11881    ---------------
11882
11883    function Same_Type (T1, T2 : Entity_Id) return Boolean is
11884    begin
11885       if T1 = T2 then
11886          return True;
11887
11888       elsif not Is_Constrained (T1)
11889         and then not Is_Constrained (T2)
11890         and then Base_Type (T1) = Base_Type (T2)
11891       then
11892          return True;
11893
11894       --  For now don't bother with case of identical constraints, to be
11895       --  fiddled with later on perhaps (this is only used for optimization
11896       --  purposes, so it is not critical to do a best possible job)
11897
11898       else
11899          return False;
11900       end if;
11901    end Same_Type;
11902
11903    ----------------
11904    -- Same_Value --
11905    ----------------
11906
11907    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
11908    begin
11909       if Compile_Time_Known_Value (Node1)
11910         and then Compile_Time_Known_Value (Node2)
11911         and then Expr_Value (Node1) = Expr_Value (Node2)
11912       then
11913          return True;
11914       elsif Same_Object (Node1, Node2) then
11915          return True;
11916       else
11917          return False;
11918       end if;
11919    end Same_Value;
11920
11921    -----------------
11922    -- Save_Actual --
11923    -----------------
11924
11925    procedure Save_Actual (N : Node_Id;  Writable : Boolean := False) is
11926    begin
11927       if Ada_Version < Ada_2012 then
11928          return;
11929
11930       elsif Is_Entity_Name (N)
11931         or else
11932           Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
11933         or else
11934           (Nkind (N) = N_Attribute_Reference
11935             and then Attribute_Name (N) = Name_Access)
11936
11937       then
11938          --  We are only interested in IN OUT parameters of inner calls
11939
11940          if not Writable
11941            or else Nkind (Parent (N)) = N_Function_Call
11942            or else Nkind (Parent (N)) in N_Op
11943          then
11944             Actuals_In_Call.Increment_Last;
11945             Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
11946          end if;
11947       end if;
11948    end Save_Actual;
11949
11950    ------------------------
11951    -- Scope_Is_Transient --
11952    ------------------------
11953
11954    function Scope_Is_Transient return Boolean is
11955    begin
11956       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
11957    end Scope_Is_Transient;
11958
11959    ------------------
11960    -- Scope_Within --
11961    ------------------
11962
11963    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
11964       Scop : Entity_Id;
11965
11966    begin
11967       Scop := Scope1;
11968       while Scop /= Standard_Standard loop
11969          Scop := Scope (Scop);
11970
11971          if Scop = Scope2 then
11972             return True;
11973          end if;
11974       end loop;
11975
11976       return False;
11977    end Scope_Within;
11978
11979    --------------------------
11980    -- Scope_Within_Or_Same --
11981    --------------------------
11982
11983    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
11984       Scop : Entity_Id;
11985
11986    begin
11987       Scop := Scope1;
11988       while Scop /= Standard_Standard loop
11989          if Scop = Scope2 then
11990             return True;
11991          else
11992             Scop := Scope (Scop);
11993          end if;
11994       end loop;
11995
11996       return False;
11997    end Scope_Within_Or_Same;
11998
11999    --------------------
12000    -- Set_Convention --
12001    --------------------
12002
12003    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
12004    begin
12005       Basic_Set_Convention (E, Val);
12006
12007       if Is_Type (E)
12008         and then Is_Access_Subprogram_Type (Base_Type (E))
12009         and then Has_Foreign_Convention (E)
12010       then
12011          Set_Can_Use_Internal_Rep (E, False);
12012       end if;
12013    end Set_Convention;
12014
12015    ------------------------
12016    -- Set_Current_Entity --
12017    ------------------------
12018
12019    --  The given entity is to be set as the currently visible definition of its
12020    --  associated name (i.e. the Node_Id associated with its name). All we have
12021    --  to do is to get the name from the identifier, and then set the
12022    --  associated Node_Id to point to the given entity.
12023
12024    procedure Set_Current_Entity (E : Entity_Id) is
12025    begin
12026       Set_Name_Entity_Id (Chars (E), E);
12027    end Set_Current_Entity;
12028
12029    ---------------------------
12030    -- Set_Debug_Info_Needed --
12031    ---------------------------
12032
12033    procedure Set_Debug_Info_Needed (T : Entity_Id) is
12034
12035       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
12036       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
12037       --  Used to set debug info in a related node if not set already
12038
12039       --------------------------------------
12040       -- Set_Debug_Info_Needed_If_Not_Set --
12041       --------------------------------------
12042
12043       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
12044       begin
12045          if Present (E)
12046            and then not Needs_Debug_Info (E)
12047          then
12048             Set_Debug_Info_Needed (E);
12049
12050             --  For a private type, indicate that the full view also needs
12051             --  debug information.
12052
12053             if Is_Type (E)
12054               and then Is_Private_Type (E)
12055               and then Present (Full_View (E))
12056             then
12057                Set_Debug_Info_Needed (Full_View (E));
12058             end if;
12059          end if;
12060       end Set_Debug_Info_Needed_If_Not_Set;
12061
12062    --  Start of processing for Set_Debug_Info_Needed
12063
12064    begin
12065       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
12066       --  indicates that Debug_Info_Needed is never required for the entity.
12067
12068       if No (T)
12069         or else Debug_Info_Off (T)
12070       then
12071          return;
12072       end if;
12073
12074       --  Set flag in entity itself. Note that we will go through the following
12075       --  circuitry even if the flag is already set on T. That's intentional,
12076       --  it makes sure that the flag will be set in subsidiary entities.
12077
12078       Set_Needs_Debug_Info (T);
12079
12080       --  Set flag on subsidiary entities if not set already
12081
12082       if Is_Object (T) then
12083          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
12084
12085       elsif Is_Type (T) then
12086          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
12087
12088          if Is_Record_Type (T) then
12089             declare
12090                Ent : Entity_Id := First_Entity (T);
12091             begin
12092                while Present (Ent) loop
12093                   Set_Debug_Info_Needed_If_Not_Set (Ent);
12094                   Next_Entity (Ent);
12095                end loop;
12096             end;
12097
12098             --  For a class wide subtype, we also need debug information
12099             --  for the equivalent type.
12100
12101             if Ekind (T) = E_Class_Wide_Subtype then
12102                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
12103             end if;
12104
12105          elsif Is_Array_Type (T) then
12106             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
12107
12108             declare
12109                Indx : Node_Id := First_Index (T);
12110             begin
12111                while Present (Indx) loop
12112                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
12113                   Indx := Next_Index (Indx);
12114                end loop;
12115             end;
12116
12117             if Is_Packed (T) then
12118                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T));
12119             end if;
12120
12121          elsif Is_Access_Type (T) then
12122             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
12123
12124          elsif Is_Private_Type (T) then
12125             Set_Debug_Info_Needed_If_Not_Set (Full_View (T));
12126
12127          elsif Is_Protected_Type (T) then
12128             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
12129          end if;
12130       end if;
12131    end Set_Debug_Info_Needed;
12132
12133    ---------------------------------
12134    -- Set_Entity_With_Style_Check --
12135    ---------------------------------
12136
12137    procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
12138       Val_Actual : Entity_Id;
12139       Nod        : Node_Id;
12140
12141    begin
12142       --  Unconditionally set the entity
12143
12144       Set_Entity (N, Val);
12145
12146       --  Check for No_Implementation_Identifiers
12147
12148       if Restriction_Check_Required (No_Implementation_Identifiers) then
12149
12150          --  We have an implementation defined entity if it is marked as
12151          --  implementation defined, or is defined in a package marked as
12152          --  implementation defined. However, library packages themselves
12153          --  are excluded (we don't want to flag Interfaces itself, just
12154          --  the entities within it).
12155
12156          if (Is_Implementation_Defined (Val)
12157               and then not (Ekind_In (Val, E_Package, E_Generic_Package)
12158                               and then Is_Library_Level_Entity (Val)))
12159            or else Is_Implementation_Defined (Scope (Val))
12160          then
12161             Check_Restriction (No_Implementation_Identifiers, N);
12162          end if;
12163       end if;
12164
12165       --  Do the style check
12166
12167       if Style_Check
12168         and then not Suppress_Style_Checks (Val)
12169         and then not In_Instance
12170       then
12171          if Nkind (N) = N_Identifier then
12172             Nod := N;
12173          elsif Nkind (N) = N_Expanded_Name then
12174             Nod := Selector_Name (N);
12175          else
12176             return;
12177          end if;
12178
12179          --  A special situation arises for derived operations, where we want
12180          --  to do the check against the parent (since the Sloc of the derived
12181          --  operation points to the derived type declaration itself).
12182
12183          Val_Actual := Val;
12184          while not Comes_From_Source (Val_Actual)
12185            and then Nkind (Val_Actual) in N_Entity
12186            and then (Ekind (Val_Actual) = E_Enumeration_Literal
12187                       or else Is_Subprogram (Val_Actual)
12188                       or else Is_Generic_Subprogram (Val_Actual))
12189            and then Present (Alias (Val_Actual))
12190          loop
12191             Val_Actual := Alias (Val_Actual);
12192          end loop;
12193
12194          --  Renaming declarations for generic actuals do not come from source,
12195          --  and have a different name from that of the entity they rename, so
12196          --  there is no style check to perform here.
12197
12198          if Chars (Nod) = Chars (Val_Actual) then
12199             Style.Check_Identifier (Nod, Val_Actual);
12200          end if;
12201       end if;
12202
12203       Set_Entity (N, Val);
12204    end Set_Entity_With_Style_Check;
12205
12206    ------------------------
12207    -- Set_Name_Entity_Id --
12208    ------------------------
12209
12210    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
12211    begin
12212       Set_Name_Table_Info (Id, Int (Val));
12213    end Set_Name_Entity_Id;
12214
12215    ---------------------
12216    -- Set_Next_Actual --
12217    ---------------------
12218
12219    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
12220    begin
12221       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
12222          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
12223       end if;
12224    end Set_Next_Actual;
12225
12226    ----------------------------------
12227    -- Set_Optimize_Alignment_Flags --
12228    ----------------------------------
12229
12230    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
12231    begin
12232       if Optimize_Alignment = 'S' then
12233          Set_Optimize_Alignment_Space (E);
12234       elsif Optimize_Alignment = 'T' then
12235          Set_Optimize_Alignment_Time (E);
12236       end if;
12237    end Set_Optimize_Alignment_Flags;
12238
12239    -----------------------
12240    -- Set_Public_Status --
12241    -----------------------
12242
12243    procedure Set_Public_Status (Id : Entity_Id) is
12244       S : constant Entity_Id := Current_Scope;
12245
12246       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
12247       --  Determines if E is defined within handled statement sequence or
12248       --  an if statement, returns True if so, False otherwise.
12249
12250       ----------------------
12251       -- Within_HSS_Or_If --
12252       ----------------------
12253
12254       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
12255          N : Node_Id;
12256       begin
12257          N := Declaration_Node (E);
12258          loop
12259             N := Parent (N);
12260
12261             if No (N) then
12262                return False;
12263
12264             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
12265                                N_If_Statement)
12266             then
12267                return True;
12268             end if;
12269          end loop;
12270       end Within_HSS_Or_If;
12271
12272    --  Start of processing for Set_Public_Status
12273
12274    begin
12275       --  Everything in the scope of Standard is public
12276
12277       if S = Standard_Standard then
12278          Set_Is_Public (Id);
12279
12280       --  Entity is definitely not public if enclosing scope is not public
12281
12282       elsif not Is_Public (S) then
12283          return;
12284
12285       --  An object or function declaration that occurs in a handled sequence
12286       --  of statements or within an if statement is the declaration for a
12287       --  temporary object or local subprogram generated by the expander. It
12288       --  never needs to be made public and furthermore, making it public can
12289       --  cause back end problems.
12290
12291       elsif Nkind_In (Parent (Id), N_Object_Declaration,
12292                                    N_Function_Specification)
12293         and then Within_HSS_Or_If (Id)
12294       then
12295          return;
12296
12297       --  Entities in public packages or records are public
12298
12299       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
12300          Set_Is_Public (Id);
12301
12302       --  The bounds of an entry family declaration can generate object
12303       --  declarations that are visible to the back-end, e.g. in the
12304       --  the declaration of a composite type that contains tasks.
12305
12306       elsif Is_Concurrent_Type (S)
12307         and then not Has_Completion (S)
12308         and then Nkind (Parent (Id)) = N_Object_Declaration
12309       then
12310          Set_Is_Public (Id);
12311       end if;
12312    end Set_Public_Status;
12313
12314    -----------------------------
12315    -- Set_Referenced_Modified --
12316    -----------------------------
12317
12318    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
12319       Pref : Node_Id;
12320
12321    begin
12322       --  Deal with indexed or selected component where prefix is modified
12323
12324       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
12325          Pref := Prefix (N);
12326
12327          --  If prefix is access type, then it is the designated object that is
12328          --  being modified, which means we have no entity to set the flag on.
12329
12330          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
12331             return;
12332
12333             --  Otherwise chase the prefix
12334
12335          else
12336             Set_Referenced_Modified (Pref, Out_Param);
12337          end if;
12338
12339       --  Otherwise see if we have an entity name (only other case to process)
12340
12341       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
12342          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
12343          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
12344       end if;
12345    end Set_Referenced_Modified;
12346
12347    ----------------------------
12348    -- Set_Scope_Is_Transient --
12349    ----------------------------
12350
12351    procedure Set_Scope_Is_Transient (V : Boolean := True) is
12352    begin
12353       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
12354    end Set_Scope_Is_Transient;
12355
12356    -------------------
12357    -- Set_Size_Info --
12358    -------------------
12359
12360    procedure Set_Size_Info (T1, T2 : Entity_Id) is
12361    begin
12362       --  We copy Esize, but not RM_Size, since in general RM_Size is
12363       --  subtype specific and does not get inherited by all subtypes.
12364
12365       Set_Esize                     (T1, Esize                     (T2));
12366       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
12367
12368       if Is_Discrete_Or_Fixed_Point_Type (T1)
12369            and then
12370          Is_Discrete_Or_Fixed_Point_Type (T2)
12371       then
12372          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
12373       end if;
12374
12375       Set_Alignment                 (T1, Alignment                 (T2));
12376    end Set_Size_Info;
12377
12378    --------------------
12379    -- Static_Boolean --
12380    --------------------
12381
12382    function Static_Boolean (N : Node_Id) return Uint is
12383    begin
12384       Analyze_And_Resolve (N, Standard_Boolean);
12385
12386       if N = Error
12387         or else Error_Posted (N)
12388         or else Etype (N) = Any_Type
12389       then
12390          return No_Uint;
12391       end if;
12392
12393       if Is_Static_Expression (N) then
12394          if not Raises_Constraint_Error (N) then
12395             return Expr_Value (N);
12396          else
12397             return No_Uint;
12398          end if;
12399
12400       elsif Etype (N) = Any_Type then
12401          return No_Uint;
12402
12403       else
12404          Flag_Non_Static_Expr
12405            ("static boolean expression required here", N);
12406          return No_Uint;
12407       end if;
12408    end Static_Boolean;
12409
12410    --------------------
12411    -- Static_Integer --
12412    --------------------
12413
12414    function Static_Integer (N : Node_Id) return Uint is
12415    begin
12416       Analyze_And_Resolve (N, Any_Integer);
12417
12418       if N = Error
12419         or else Error_Posted (N)
12420         or else Etype (N) = Any_Type
12421       then
12422          return No_Uint;
12423       end if;
12424
12425       if Is_Static_Expression (N) then
12426          if not Raises_Constraint_Error (N) then
12427             return Expr_Value (N);
12428          else
12429             return No_Uint;
12430          end if;
12431
12432       elsif Etype (N) = Any_Type then
12433          return No_Uint;
12434
12435       else
12436          Flag_Non_Static_Expr
12437            ("static integer expression required here", N);
12438          return No_Uint;
12439       end if;
12440    end Static_Integer;
12441
12442    --------------------------
12443    -- Statically_Different --
12444    --------------------------
12445
12446    function Statically_Different (E1, E2 : Node_Id) return Boolean is
12447       R1 : constant Node_Id := Get_Referenced_Object (E1);
12448       R2 : constant Node_Id := Get_Referenced_Object (E2);
12449    begin
12450       return     Is_Entity_Name (R1)
12451         and then Is_Entity_Name (R2)
12452         and then Entity (R1) /= Entity (R2)
12453         and then not Is_Formal (Entity (R1))
12454         and then not Is_Formal (Entity (R2));
12455    end Statically_Different;
12456
12457    -----------------------------
12458    -- Subprogram_Access_Level --
12459    -----------------------------
12460
12461    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
12462    begin
12463       if Present (Alias (Subp)) then
12464          return Subprogram_Access_Level (Alias (Subp));
12465       else
12466          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
12467       end if;
12468    end Subprogram_Access_Level;
12469
12470    -----------------
12471    -- Trace_Scope --
12472    -----------------
12473
12474    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
12475    begin
12476       if Debug_Flag_W then
12477          for J in 0 .. Scope_Stack.Last loop
12478             Write_Str ("  ");
12479          end loop;
12480
12481          Write_Str (Msg);
12482          Write_Name (Chars (E));
12483          Write_Str (" from ");
12484          Write_Location (Sloc (N));
12485          Write_Eol;
12486       end if;
12487    end Trace_Scope;
12488
12489    -----------------------
12490    -- Transfer_Entities --
12491    -----------------------
12492
12493    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
12494       Ent : Entity_Id := First_Entity (From);
12495
12496    begin
12497       if No (Ent) then
12498          return;
12499       end if;
12500
12501       if (Last_Entity (To)) = Empty then
12502          Set_First_Entity (To, Ent);
12503       else
12504          Set_Next_Entity (Last_Entity (To), Ent);
12505       end if;
12506
12507       Set_Last_Entity (To, Last_Entity (From));
12508
12509       while Present (Ent) loop
12510          Set_Scope (Ent, To);
12511
12512          if not Is_Public (Ent) then
12513             Set_Public_Status (Ent);
12514
12515             if Is_Public (Ent)
12516               and then Ekind (Ent) = E_Record_Subtype
12517
12518             then
12519                --  The components of the propagated Itype must be public
12520                --  as well.
12521
12522                declare
12523                   Comp : Entity_Id;
12524                begin
12525                   Comp := First_Entity (Ent);
12526                   while Present (Comp) loop
12527                      Set_Is_Public (Comp);
12528                      Next_Entity (Comp);
12529                   end loop;
12530                end;
12531             end if;
12532          end if;
12533
12534          Next_Entity (Ent);
12535       end loop;
12536
12537       Set_First_Entity (From, Empty);
12538       Set_Last_Entity (From, Empty);
12539    end Transfer_Entities;
12540
12541    -----------------------
12542    -- Type_Access_Level --
12543    -----------------------
12544
12545    function Type_Access_Level (Typ : Entity_Id) return Uint is
12546       Btyp : Entity_Id;
12547
12548    begin
12549       Btyp := Base_Type (Typ);
12550
12551       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
12552       --  simply use the level where the type is declared. This is true for
12553       --  stand-alone object declarations, and for anonymous access types
12554       --  associated with components the level is the same as that of the
12555       --  enclosing composite type. However, special treatment is needed for
12556       --  the cases of access parameters, return objects of an anonymous access
12557       --  type, and, in Ada 95, access discriminants of limited types.
12558
12559       if Ekind (Btyp) in Access_Kind then
12560          if Ekind (Btyp) = E_Anonymous_Access_Type then
12561
12562             --  If the type is a nonlocal anonymous access type (such as for
12563             --  an access parameter) we treat it as being declared at the
12564             --  library level to ensure that names such as X.all'access don't
12565             --  fail static accessibility checks.
12566
12567             if not Is_Local_Anonymous_Access (Typ) then
12568                return Scope_Depth (Standard_Standard);
12569
12570             --  If this is a return object, the accessibility level is that of
12571             --  the result subtype of the enclosing function. The test here is
12572             --  little complicated, because we have to account for extended
12573             --  return statements that have been rewritten as blocks, in which
12574             --  case we have to find and the Is_Return_Object attribute of the
12575             --  itype's associated object. It would be nice to find a way to
12576             --  simplify this test, but it doesn't seem worthwhile to add a new
12577             --  flag just for purposes of this test. ???
12578
12579             elsif Ekind (Scope (Btyp)) = E_Return_Statement
12580               or else
12581                 (Is_Itype (Btyp)
12582                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
12583                              N_Object_Declaration
12584                   and then Is_Return_Object
12585                              (Defining_Identifier
12586                                 (Associated_Node_For_Itype (Btyp))))
12587             then
12588                declare
12589                   Scop : Entity_Id;
12590
12591                begin
12592                   Scop := Scope (Scope (Btyp));
12593                   while Present (Scop) loop
12594                      exit when Ekind (Scop) = E_Function;
12595                      Scop := Scope (Scop);
12596                   end loop;
12597
12598                   --  Treat the return object's type as having the level of the
12599                   --  function's result subtype (as per RM05-6.5(5.3/2)).
12600
12601                   return Type_Access_Level (Etype (Scop));
12602                end;
12603             end if;
12604          end if;
12605
12606          Btyp := Root_Type (Btyp);
12607
12608          --  The accessibility level of anonymous access types associated with
12609          --  discriminants is that of the current instance of the type, and
12610          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
12611
12612          --  AI-402: access discriminants have accessibility based on the
12613          --  object rather than the type in Ada 2005, so the above paragraph
12614          --  doesn't apply.
12615
12616          --  ??? Needs completion with rules from AI-416
12617
12618          if Ada_Version <= Ada_95
12619            and then Ekind (Typ) = E_Anonymous_Access_Type
12620            and then Present (Associated_Node_For_Itype (Typ))
12621            and then Nkind (Associated_Node_For_Itype (Typ)) =
12622                                                  N_Discriminant_Specification
12623          then
12624             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
12625          end if;
12626       end if;
12627
12628       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
12629    end Type_Access_Level;
12630
12631    ------------------------------------
12632    -- Type_Without_Stream_Operation  --
12633    ------------------------------------
12634
12635    function Type_Without_Stream_Operation
12636      (T  : Entity_Id;
12637       Op : TSS_Name_Type := TSS_Null) return Entity_Id
12638    is
12639       BT         : constant Entity_Id := Base_Type (T);
12640       Op_Missing : Boolean;
12641
12642    begin
12643       if not Restriction_Active (No_Default_Stream_Attributes) then
12644          return Empty;
12645       end if;
12646
12647       if Is_Elementary_Type (T) then
12648          if Op = TSS_Null then
12649             Op_Missing :=
12650               No (TSS (BT, TSS_Stream_Read))
12651                 or else No (TSS (BT, TSS_Stream_Write));
12652
12653          else
12654             Op_Missing := No (TSS (BT, Op));
12655          end if;
12656
12657          if Op_Missing then
12658             return T;
12659          else
12660             return Empty;
12661          end if;
12662
12663       elsif Is_Array_Type (T) then
12664          return Type_Without_Stream_Operation (Component_Type (T), Op);
12665
12666       elsif Is_Record_Type (T) then
12667          declare
12668             Comp  : Entity_Id;
12669             C_Typ : Entity_Id;
12670
12671          begin
12672             Comp := First_Component (T);
12673             while Present (Comp) loop
12674                C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
12675
12676                if Present (C_Typ) then
12677                   return C_Typ;
12678                end if;
12679
12680                Next_Component (Comp);
12681             end loop;
12682
12683             return Empty;
12684          end;
12685
12686       elsif Is_Private_Type (T)
12687         and then Present (Full_View (T))
12688       then
12689          return Type_Without_Stream_Operation (Full_View (T), Op);
12690       else
12691          return Empty;
12692       end if;
12693    end Type_Without_Stream_Operation;
12694
12695    ----------------------------
12696    -- Unique_Defining_Entity --
12697    ----------------------------
12698
12699    function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
12700    begin
12701       return Unique_Entity (Defining_Entity (N));
12702    end Unique_Defining_Entity;
12703
12704    -------------------
12705    -- Unique_Entity --
12706    -------------------
12707
12708    function Unique_Entity (E : Entity_Id) return Entity_Id is
12709       U : Entity_Id := E;
12710       P : Node_Id;
12711
12712    begin
12713       case Ekind (E) is
12714          when E_Constant =>
12715             if Present (Full_View (E)) then
12716                U := Full_View (E);
12717             end if;
12718
12719          when Type_Kind =>
12720             if Present (Full_View (E)) then
12721                U := Full_View (E);
12722             end if;
12723
12724          when E_Package_Body =>
12725             P := Parent (E);
12726
12727             if Nkind (P) = N_Defining_Program_Unit_Name then
12728                P := Parent (P);
12729             end if;
12730
12731             U := Corresponding_Spec (P);
12732
12733          when E_Subprogram_Body =>
12734             P := Parent (E);
12735
12736             if Nkind (P) = N_Defining_Program_Unit_Name then
12737                P := Parent (P);
12738             end if;
12739
12740             P := Parent (P);
12741
12742             if Nkind (P) = N_Subprogram_Body_Stub then
12743                if Present (Library_Unit (P)) then
12744                   U := Get_Body_From_Stub (P);
12745                end if;
12746             else
12747                U := Corresponding_Spec (P);
12748             end if;
12749
12750          when others =>
12751             null;
12752       end case;
12753
12754       return U;
12755    end Unique_Entity;
12756
12757    -----------------
12758    -- Unique_Name --
12759    -----------------
12760
12761    function Unique_Name (E : Entity_Id) return String is
12762
12763       function Get_Scoped_Name (E : Entity_Id) return String;
12764       --  Return the name of E prefixed by all the names of the scopes to which
12765       --  E belongs, except for Standard.
12766
12767       ---------------------
12768       -- Get_Scoped_Name --
12769       ---------------------
12770
12771       function Get_Scoped_Name (E : Entity_Id) return String is
12772          Name : constant String := Get_Name_String (Chars (E));
12773       begin
12774          if Has_Fully_Qualified_Name (E)
12775            or else Scope (E) = Standard_Standard
12776          then
12777             return Name;
12778          else
12779             return Get_Scoped_Name (Scope (E)) & "__" & Name;
12780          end if;
12781       end Get_Scoped_Name;
12782
12783    --  Start of processing for Unique_Name
12784
12785    begin
12786       if E = Standard_Standard then
12787          return Get_Name_String (Name_Standard);
12788
12789       elsif Scope (E) = Standard_Standard
12790         and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
12791       then
12792          return Get_Name_String (Name_Standard) & "__" &
12793            Get_Name_String (Chars (E));
12794
12795       elsif Ekind (E) = E_Enumeration_Literal then
12796          return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
12797
12798       else
12799          return Get_Scoped_Name (E);
12800       end if;
12801    end Unique_Name;
12802
12803    --------------------------
12804    -- Unit_Declaration_Node --
12805    --------------------------
12806
12807    function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
12808       N : Node_Id := Parent (Unit_Id);
12809
12810    begin
12811       --  Predefined operators do not have a full function declaration
12812
12813       if Ekind (Unit_Id) = E_Operator then
12814          return N;
12815       end if;
12816
12817       --  Isn't there some better way to express the following ???
12818
12819       while Nkind (N) /= N_Abstract_Subprogram_Declaration
12820         and then Nkind (N) /= N_Formal_Package_Declaration
12821         and then Nkind (N) /= N_Function_Instantiation
12822         and then Nkind (N) /= N_Generic_Package_Declaration
12823         and then Nkind (N) /= N_Generic_Subprogram_Declaration
12824         and then Nkind (N) /= N_Package_Declaration
12825         and then Nkind (N) /= N_Package_Body
12826         and then Nkind (N) /= N_Package_Instantiation
12827         and then Nkind (N) /= N_Package_Renaming_Declaration
12828         and then Nkind (N) /= N_Procedure_Instantiation
12829         and then Nkind (N) /= N_Protected_Body
12830         and then Nkind (N) /= N_Subprogram_Declaration
12831         and then Nkind (N) /= N_Subprogram_Body
12832         and then Nkind (N) /= N_Subprogram_Body_Stub
12833         and then Nkind (N) /= N_Subprogram_Renaming_Declaration
12834         and then Nkind (N) /= N_Task_Body
12835         and then Nkind (N) /= N_Task_Type_Declaration
12836         and then Nkind (N) not in N_Formal_Subprogram_Declaration
12837         and then Nkind (N) not in N_Generic_Renaming_Declaration
12838       loop
12839          N := Parent (N);
12840
12841          --  We don't use Assert here, because that causes an infinite loop
12842          --  when assertions are turned off. Better to crash.
12843
12844          if No (N) then
12845             raise Program_Error;
12846          end if;
12847       end loop;
12848
12849       return N;
12850    end Unit_Declaration_Node;
12851
12852    ---------------------
12853    -- Unit_Is_Visible --
12854    ---------------------
12855
12856    function Unit_Is_Visible (U : Entity_Id) return Boolean is
12857       Curr        : constant Node_Id   := Cunit (Current_Sem_Unit);
12858       Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
12859
12860       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
12861       --  For a child unit, check whether unit appears in a with_clause
12862       --  of a parent.
12863
12864       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
12865       --  Scan the context clause of one compilation unit looking for a
12866       --  with_clause for the unit in question.
12867
12868       ----------------------------
12869       -- Unit_In_Parent_Context --
12870       ----------------------------
12871
12872       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
12873       begin
12874          if Unit_In_Context (Par_Unit) then
12875             return True;
12876
12877          elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
12878             return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
12879
12880          else
12881             return False;
12882          end if;
12883       end Unit_In_Parent_Context;
12884
12885       ---------------------
12886       -- Unit_In_Context --
12887       ---------------------
12888
12889       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
12890          Clause : Node_Id;
12891
12892       begin
12893          Clause := First (Context_Items (Comp_Unit));
12894          while Present (Clause) loop
12895             if Nkind (Clause) = N_With_Clause then
12896                if Library_Unit (Clause) = U then
12897                   return True;
12898
12899                --  The with_clause may denote a renaming of the unit we are
12900                --  looking for, eg. Text_IO which renames Ada.Text_IO.
12901
12902                elsif
12903                  Renamed_Entity (Entity (Name (Clause))) =
12904                                                 Defining_Entity (Unit (U))
12905                then
12906                   return True;
12907                end if;
12908             end if;
12909
12910             Next (Clause);
12911          end loop;
12912
12913          return False;
12914       end Unit_In_Context;
12915
12916    --  Start of processing for Unit_Is_Visible
12917
12918    begin
12919       --  The currrent unit is directly visible
12920
12921       if Curr = U then
12922          return True;
12923
12924       elsif Unit_In_Context (Curr) then
12925          return True;
12926
12927       --  If the current unit is a body, check the context of the spec
12928
12929       elsif Nkind (Unit (Curr)) = N_Package_Body
12930         or else
12931           (Nkind (Unit (Curr)) = N_Subprogram_Body
12932             and then not Acts_As_Spec (Unit (Curr)))
12933       then
12934          if Unit_In_Context (Library_Unit (Curr)) then
12935             return True;
12936          end if;
12937       end if;
12938
12939       --  If the spec is a child unit, examine the parents
12940
12941       if Is_Child_Unit (Curr_Entity) then
12942          if Nkind (Unit (Curr)) in N_Unit_Body then
12943             return
12944               Unit_In_Parent_Context
12945                 (Parent_Spec (Unit (Library_Unit (Curr))));
12946          else
12947             return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
12948          end if;
12949
12950       else
12951          return False;
12952       end if;
12953    end Unit_Is_Visible;
12954
12955    ------------------------------
12956    -- Universal_Interpretation --
12957    ------------------------------
12958
12959    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
12960       Index : Interp_Index;
12961       It    : Interp;
12962
12963    begin
12964       --  The argument may be a formal parameter of an operator or subprogram
12965       --  with multiple interpretations, or else an expression for an actual.
12966
12967       if Nkind (Opnd) = N_Defining_Identifier
12968         or else not Is_Overloaded (Opnd)
12969       then
12970          if Etype (Opnd) = Universal_Integer
12971            or else Etype (Opnd) = Universal_Real
12972          then
12973             return Etype (Opnd);
12974          else
12975             return Empty;
12976          end if;
12977
12978       else
12979          Get_First_Interp (Opnd, Index, It);
12980          while Present (It.Typ) loop
12981             if It.Typ = Universal_Integer
12982               or else It.Typ = Universal_Real
12983             then
12984                return It.Typ;
12985             end if;
12986
12987             Get_Next_Interp (Index, It);
12988          end loop;
12989
12990          return Empty;
12991       end if;
12992    end Universal_Interpretation;
12993
12994    ---------------
12995    -- Unqualify --
12996    ---------------
12997
12998    function Unqualify (Expr : Node_Id) return Node_Id is
12999    begin
13000       --  Recurse to handle unlikely case of multiple levels of qualification
13001
13002       if Nkind (Expr) = N_Qualified_Expression then
13003          return Unqualify (Expression (Expr));
13004
13005       --  Normal case, not a qualified expression
13006
13007       else
13008          return Expr;
13009       end if;
13010    end Unqualify;
13011
13012    -----------------------
13013    -- Visible_Ancestors --
13014    -----------------------
13015
13016    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
13017       List_1 : Elist_Id;
13018       List_2 : Elist_Id;
13019       Elmt   : Elmt_Id;
13020
13021    begin
13022       pragma Assert (Is_Record_Type (Typ)
13023         and then Is_Tagged_Type (Typ));
13024
13025       --  Collect all the parents and progenitors of Typ. If the full-view of
13026       --  private parents and progenitors is available then it is used to
13027       --  generate the list of visible ancestors; otherwise their partial
13028       --  view is added to the resulting list.
13029
13030       Collect_Parents
13031         (T               => Typ,
13032          List            => List_1,
13033          Use_Full_View   => True);
13034
13035       Collect_Interfaces
13036         (T               => Typ,
13037          Ifaces_List     => List_2,
13038          Exclude_Parents => True,
13039          Use_Full_View   => True);
13040
13041       --  Join the two lists. Avoid duplications because an interface may
13042       --  simultaneously be parent and progenitor of a type.
13043
13044       Elmt := First_Elmt (List_2);
13045       while Present (Elmt) loop
13046          Append_Unique_Elmt (Node (Elmt), List_1);
13047          Next_Elmt (Elmt);
13048       end loop;
13049
13050       return List_1;
13051    end Visible_Ancestors;
13052
13053    ----------------------
13054    -- Within_Init_Proc --
13055    ----------------------
13056
13057    function Within_Init_Proc return Boolean is
13058       S : Entity_Id;
13059
13060    begin
13061       S := Current_Scope;
13062       while not Is_Overloadable (S) loop
13063          if S = Standard_Standard then
13064             return False;
13065          else
13066             S := Scope (S);
13067          end if;
13068       end loop;
13069
13070       return Is_Init_Proc (S);
13071    end Within_Init_Proc;
13072
13073    ----------------
13074    -- Wrong_Type --
13075    ----------------
13076
13077    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
13078       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
13079       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
13080
13081       Matching_Field : Entity_Id;
13082       --  Entity to give a more precise suggestion on how to write a one-
13083       --  element positional aggregate.
13084
13085       function Has_One_Matching_Field return Boolean;
13086       --  Determines if Expec_Type is a record type with a single component or
13087       --  discriminant whose type matches the found type or is one dimensional
13088       --  array whose component type matches the found type.
13089
13090       ----------------------------
13091       -- Has_One_Matching_Field --
13092       ----------------------------
13093
13094       function Has_One_Matching_Field return Boolean is
13095          E : Entity_Id;
13096
13097       begin
13098          Matching_Field := Empty;
13099
13100          if Is_Array_Type (Expec_Type)
13101            and then Number_Dimensions (Expec_Type) = 1
13102            and then
13103              Covers (Etype (Component_Type (Expec_Type)), Found_Type)
13104          then
13105             --  Use type name if available. This excludes multidimensional
13106             --  arrays and anonymous arrays.
13107
13108             if Comes_From_Source (Expec_Type) then
13109                Matching_Field := Expec_Type;
13110
13111             --  For an assignment, use name of target
13112
13113             elsif Nkind (Parent (Expr)) = N_Assignment_Statement
13114               and then Is_Entity_Name (Name (Parent (Expr)))
13115             then
13116                Matching_Field := Entity (Name (Parent (Expr)));
13117             end if;
13118
13119             return True;
13120
13121          elsif not Is_Record_Type (Expec_Type) then
13122             return False;
13123
13124          else
13125             E := First_Entity (Expec_Type);
13126             loop
13127                if No (E) then
13128                   return False;
13129
13130                elsif (Ekind (E) /= E_Discriminant
13131                        and then Ekind (E) /= E_Component)
13132                  or else (Chars (E) = Name_uTag
13133                            or else Chars (E) = Name_uParent)
13134                then
13135                   Next_Entity (E);
13136
13137                else
13138                   exit;
13139                end if;
13140             end loop;
13141
13142             if not Covers (Etype (E), Found_Type) then
13143                return False;
13144
13145             elsif Present (Next_Entity (E)) then
13146                return False;
13147
13148             else
13149                Matching_Field := E;
13150                return True;
13151             end if;
13152          end if;
13153       end Has_One_Matching_Field;
13154
13155    --  Start of processing for Wrong_Type
13156
13157    begin
13158       --  Don't output message if either type is Any_Type, or if a message
13159       --  has already been posted for this node. We need to do the latter
13160       --  check explicitly (it is ordinarily done in Errout), because we
13161       --  are using ! to force the output of the error messages.
13162
13163       if Expec_Type = Any_Type
13164         or else Found_Type = Any_Type
13165         or else Error_Posted (Expr)
13166       then
13167          return;
13168
13169       --  If one of the types is a Taft-Amendment type and the other it its
13170       --  completion, it must be an illegal use of a TAT in the spec, for
13171       --  which an error was already emitted. Avoid cascaded errors.
13172
13173       elsif Is_Incomplete_Type (Expec_Type)
13174         and then Has_Completion_In_Body (Expec_Type)
13175         and then Full_View (Expec_Type) = Etype (Expr)
13176       then
13177          return;
13178
13179       elsif Is_Incomplete_Type (Etype (Expr))
13180         and then Has_Completion_In_Body (Etype (Expr))
13181         and then Full_View (Etype (Expr)) = Expec_Type
13182       then
13183          return;
13184
13185       --  In  an instance, there is an ongoing problem with completion of
13186       --  type derived from private types. Their structure is what Gigi
13187       --  expects, but the  Etype is the parent type rather than the
13188       --  derived private type itself. Do not flag error in this case. The
13189       --  private completion is an entity without a parent, like an Itype.
13190       --  Similarly, full and partial views may be incorrect in the instance.
13191       --  There is no simple way to insure that it is consistent ???
13192
13193       elsif In_Instance then
13194          if Etype (Etype (Expr)) = Etype (Expected_Type)
13195            and then
13196              (Has_Private_Declaration (Expected_Type)
13197                or else Has_Private_Declaration (Etype (Expr)))
13198            and then No (Parent (Expected_Type))
13199          then
13200             return;
13201          end if;
13202       end if;
13203
13204       --  An interesting special check. If the expression is parenthesized
13205       --  and its type corresponds to the type of the sole component of the
13206       --  expected record type, or to the component type of the expected one
13207       --  dimensional array type, then assume we have a bad aggregate attempt.
13208
13209       if Nkind (Expr) in N_Subexpr
13210         and then Paren_Count (Expr) /= 0
13211         and then Has_One_Matching_Field
13212       then
13213          Error_Msg_N ("positional aggregate cannot have one component", Expr);
13214          if Present (Matching_Field) then
13215             if Is_Array_Type (Expec_Type) then
13216                Error_Msg_NE
13217                  ("\write instead `&''First ='> ...`", Expr, Matching_Field);
13218
13219             else
13220                Error_Msg_NE
13221                  ("\write instead `& ='> ...`", Expr, Matching_Field);
13222             end if;
13223          end if;
13224
13225       --  Another special check, if we are looking for a pool-specific access
13226       --  type and we found an E_Access_Attribute_Type, then we have the case
13227       --  of an Access attribute being used in a context which needs a pool-
13228       --  specific type, which is never allowed. The one extra check we make
13229       --  is that the expected designated type covers the Found_Type.
13230
13231       elsif Is_Access_Type (Expec_Type)
13232         and then Ekind (Found_Type) = E_Access_Attribute_Type
13233         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
13234         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
13235         and then Covers
13236           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
13237       then
13238          Error_Msg_N -- CODEFIX
13239            ("result must be general access type!", Expr);
13240          Error_Msg_NE -- CODEFIX
13241            ("add ALL to }!", Expr, Expec_Type);
13242
13243       --  Another special check, if the expected type is an integer type,
13244       --  but the expression is of type System.Address, and the parent is
13245       --  an addition or subtraction operation whose left operand is the
13246       --  expression in question and whose right operand is of an integral
13247       --  type, then this is an attempt at address arithmetic, so give
13248       --  appropriate message.
13249
13250       elsif Is_Integer_Type (Expec_Type)
13251         and then Is_RTE (Found_Type, RE_Address)
13252         and then (Nkind (Parent (Expr)) = N_Op_Add
13253                     or else
13254                   Nkind (Parent (Expr)) = N_Op_Subtract)
13255         and then Expr = Left_Opnd (Parent (Expr))
13256         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
13257       then
13258          Error_Msg_N
13259            ("address arithmetic not predefined in package System",
13260             Parent (Expr));
13261          Error_Msg_N
13262            ("\possible missing with/use of System.Storage_Elements",
13263             Parent (Expr));
13264          return;
13265
13266       --  If the expected type is an anonymous access type, as for access
13267       --  parameters and discriminants, the error is on the designated types.
13268
13269       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
13270          if Comes_From_Source (Expec_Type) then
13271             Error_Msg_NE ("expected}!", Expr, Expec_Type);
13272          else
13273             Error_Msg_NE
13274               ("expected an access type with designated}",
13275                  Expr, Designated_Type (Expec_Type));
13276          end if;
13277
13278          if Is_Access_Type (Found_Type)
13279            and then not Comes_From_Source (Found_Type)
13280          then
13281             Error_Msg_NE
13282               ("\\found an access type with designated}!",
13283                 Expr, Designated_Type (Found_Type));
13284          else
13285             if From_With_Type (Found_Type) then
13286                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
13287                Error_Msg_Qual_Level := 99;
13288                Error_Msg_NE -- CODEFIX
13289                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
13290                Error_Msg_Qual_Level := 0;
13291             else
13292                Error_Msg_NE ("found}!", Expr, Found_Type);
13293             end if;
13294          end if;
13295
13296       --  Normal case of one type found, some other type expected
13297
13298       else
13299          --  If the names of the two types are the same, see if some number
13300          --  of levels of qualification will help. Don't try more than three
13301          --  levels, and if we get to standard, it's no use (and probably
13302          --  represents an error in the compiler) Also do not bother with
13303          --  internal scope names.
13304
13305          declare
13306             Expec_Scope : Entity_Id;
13307             Found_Scope : Entity_Id;
13308
13309          begin
13310             Expec_Scope := Expec_Type;
13311             Found_Scope := Found_Type;
13312
13313             for Levels in Int range 0 .. 3 loop
13314                if Chars (Expec_Scope) /= Chars (Found_Scope) then
13315                   Error_Msg_Qual_Level := Levels;
13316                   exit;
13317                end if;
13318
13319                Expec_Scope := Scope (Expec_Scope);
13320                Found_Scope := Scope (Found_Scope);
13321
13322                exit when Expec_Scope = Standard_Standard
13323                  or else Found_Scope = Standard_Standard
13324                  or else not Comes_From_Source (Expec_Scope)
13325                  or else not Comes_From_Source (Found_Scope);
13326             end loop;
13327          end;
13328
13329          if Is_Record_Type (Expec_Type)
13330            and then Present (Corresponding_Remote_Type (Expec_Type))
13331          then
13332             Error_Msg_NE ("expected}!", Expr,
13333                           Corresponding_Remote_Type (Expec_Type));
13334          else
13335             Error_Msg_NE ("expected}!", Expr, Expec_Type);
13336          end if;
13337
13338          if Is_Entity_Name (Expr)
13339            and then Is_Package_Or_Generic_Package (Entity (Expr))
13340          then
13341             Error_Msg_N ("\\found package name!", Expr);
13342
13343          elsif Is_Entity_Name (Expr)
13344            and then
13345              (Ekind (Entity (Expr)) = E_Procedure
13346                 or else
13347               Ekind (Entity (Expr)) = E_Generic_Procedure)
13348          then
13349             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
13350                Error_Msg_N
13351                  ("found procedure name, possibly missing Access attribute!",
13352                    Expr);
13353             else
13354                Error_Msg_N
13355                  ("\\found procedure name instead of function!", Expr);
13356             end if;
13357
13358          elsif Nkind (Expr) = N_Function_Call
13359            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
13360            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
13361            and then No (Parameter_Associations (Expr))
13362          then
13363             Error_Msg_N
13364               ("found function name, possibly missing Access attribute!",
13365                Expr);
13366
13367          --  Catch common error: a prefix or infix operator which is not
13368          --  directly visible because the type isn't.
13369
13370          elsif Nkind (Expr) in N_Op
13371             and then Is_Overloaded (Expr)
13372             and then not Is_Immediately_Visible (Expec_Type)
13373             and then not Is_Potentially_Use_Visible (Expec_Type)
13374             and then not In_Use (Expec_Type)
13375             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
13376          then
13377             Error_Msg_N
13378               ("operator of the type is not directly visible!", Expr);
13379
13380          elsif Ekind (Found_Type) = E_Void
13381            and then Present (Parent (Found_Type))
13382            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
13383          then
13384             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
13385
13386          else
13387             Error_Msg_NE ("\\found}!", Expr, Found_Type);
13388          end if;
13389
13390          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
13391          --  of the same modular type, and (M1 and M2) = 0 was intended.
13392
13393          if Expec_Type = Standard_Boolean
13394            and then Is_Modular_Integer_Type (Found_Type)
13395            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
13396            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
13397          then
13398             declare
13399                Op : constant Node_Id := Right_Opnd (Parent (Expr));
13400                L  : constant Node_Id := Left_Opnd (Op);
13401                R  : constant Node_Id := Right_Opnd (Op);
13402             begin
13403                --  The case for the message is when the left operand of the
13404                --  comparison is the same modular type, or when it is an
13405                --  integer literal (or other universal integer expression),
13406                --  which would have been typed as the modular type if the
13407                --  parens had been there.
13408
13409                if (Etype (L) = Found_Type
13410                      or else
13411                    Etype (L) = Universal_Integer)
13412                  and then Is_Integer_Type (Etype (R))
13413                then
13414                   Error_Msg_N
13415                     ("\\possible missing parens for modular operation", Expr);
13416                end if;
13417             end;
13418          end if;
13419
13420          --  Reset error message qualification indication
13421
13422          Error_Msg_Qual_Level := 0;
13423       end if;
13424    end Wrong_Type;
13425
13426 end Sem_Util;