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