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