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-2015, 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 Treepr; -- ???For debugging code below
  27
  28 with Aspects;  use Aspects;
  29 with Atree;    use Atree;
  30 with Casing;   use Casing;
  31 with Checks;   use Checks;
  32 with Debug;    use Debug;
  33 with Elists;   use Elists;
  34 with Errout;   use Errout;
  35 with Exp_Ch11; use Exp_Ch11;
  36 with Exp_Disp; use Exp_Disp;
  37 with Exp_Util; use Exp_Util;
  38 with Fname;    use Fname;
  39 with Freeze;   use Freeze;
  40 with Ghost;    use Ghost;
  41 with Lib;      use Lib;
  42 with Lib.Xref; use Lib.Xref;
  43 with Namet.Sp; use Namet.Sp;
  44 with Nlists;   use Nlists;
  45 with Nmake;    use Nmake;
  46 with Output;   use Output;
  47 with Restrict; use Restrict;
  48 with Rident;   use Rident;
  49 with Rtsfind;  use Rtsfind;
  50 with Sem;      use Sem;
  51 with Sem_Aux;  use Sem_Aux;
  52 with Sem_Attr; use Sem_Attr;
  53 with Sem_Ch6;  use Sem_Ch6;
  54 with Sem_Ch8;  use Sem_Ch8;
  55 with Sem_Ch13; use Sem_Ch13;
  56 with Sem_Disp; use Sem_Disp;
  57 with Sem_Eval; use Sem_Eval;
  58 with Sem_Prag; use Sem_Prag;
  59 with Sem_Res;  use Sem_Res;
  60 with Sem_Warn; use Sem_Warn;
  61 with Sem_Type; use Sem_Type;
  62 with Sinfo;    use Sinfo;
  63 with Sinput;   use Sinput;
  64 with Stand;    use Stand;
  65 with Style;
  66 with Stringt;  use Stringt;
  67 with Targparm; use Targparm;
  68 with Tbuild;   use Tbuild;
  69 with Ttypes;   use Ttypes;
  70 with Uname;    use Uname;
  71
  72 with GNAT.HTable; use GNAT.HTable;
  73
  74 package body Sem_Util is
  75
  76    ----------------------------------------
  77    -- Global Variables for New_Copy_Tree --
  78    ----------------------------------------
  79
  80    --  These global variables are used by New_Copy_Tree. See description of the
  81    --  body of this subprogram for details. Global variables can be safely used
  82    --  by New_Copy_Tree, since there is no case of a recursive call from the
  83    --  processing inside New_Copy_Tree.
  84
  85    NCT_Hash_Threshold : constant := 20;
  86    --  If there are more than this number of pairs of entries in the map, then
  87    --  Hash_Tables_Used will be set, and the hash tables will be initialized
  88    --  and used for the searches.
  89
  90    NCT_Hash_Tables_Used : Boolean := False;
  91    --  Set to True if hash tables are in use
  92
  93    NCT_Table_Entries : Nat := 0;
  94    --  Count entries in table to see if threshold is reached
  95
  96    NCT_Hash_Table_Setup : Boolean := False;
  97    --  Set to True if hash table contains data. We set this True if we setup
  98    --  the hash table with data, and leave it set permanently from then on,
  99    --  this is a signal that second and subsequent users of the hash table
 100    --  must clear the old entries before reuse.
 101
 102    subtype NCT_Header_Num is Int range 0 .. 511;
 103    --  Defines range of headers in hash tables (512 headers)
 104
 105    -----------------------
 106    -- Local Subprograms --
 107    -----------------------
 108
 109    function Build_Component_Subtype
 110      (C   : List_Id;
 111       Loc : Source_Ptr;
 112       T   : Entity_Id) return Node_Id;
 113    --  This function builds the subtype for Build_Actual_Subtype_Of_Component
 114    --  and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
 115    --  Loc is the source location, T is the original subtype.
 116
 117    function Has_Enabled_Property
 118      (Item_Id  : Entity_Id;
 119       Property : Name_Id) return Boolean;
 120    --  Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
 121    --  Determine whether an abstract state or a variable denoted by entity
 122    --  Item_Id has enabled property Property.
 123
 124    function Has_Null_Extension (T : Entity_Id) return Boolean;
 125    --  T is a derived tagged type. Check whether the type extension is null.
 126    --  If the parent type is fully initialized, T can be treated as such.
 127
 128    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
 129    --  Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
 130    --  with discriminants whose default values are static, examine only the
 131    --  components in the selected variant to determine whether all of them
 132    --  have a default.
 133
 134    ------------------------------
 135    --  Abstract_Interface_List --
 136    ------------------------------
 137
 138    function Abstract_Interface_List (Typ : Entity_Id) return List_Id is
 139       Nod : Node_Id;
 140
 141    begin
 142       if Is_Concurrent_Type (Typ) then
 143
 144          --  If we are dealing with a synchronized subtype, go to the base
 145          --  type, whose declaration has the interface list.
 146
 147          --  Shouldn't this be Declaration_Node???
 148
 149          Nod := Parent (Base_Type (Typ));
 150
 151          if Nkind (Nod) = N_Full_Type_Declaration then
 152             return Empty_List;
 153          end if;
 154
 155       elsif Ekind (Typ) = E_Record_Type_With_Private then
 156          if Nkind (Parent (Typ)) = N_Full_Type_Declaration then
 157             Nod := Type_Definition (Parent (Typ));
 158
 159          elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then
 160             if Present (Full_View (Typ))
 161               and then
 162                 Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration
 163             then
 164                Nod := Type_Definition (Parent (Full_View (Typ)));
 165
 166             --  If the full-view is not available we cannot do anything else
 167             --  here (the source has errors).
 168
 169             else
 170                return Empty_List;
 171             end if;
 172
 173          --  Support for generic formals with interfaces is still missing ???
 174
 175          elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 176             return Empty_List;
 177
 178          else
 179             pragma Assert
 180               (Nkind (Parent (Typ)) = N_Private_Extension_Declaration);
 181             Nod := Parent (Typ);
 182          end if;
 183
 184       elsif Ekind (Typ) = E_Record_Subtype then
 185          Nod := Type_Definition (Parent (Etype (Typ)));
 186
 187       elsif Ekind (Typ) = E_Record_Subtype_With_Private then
 188
 189          --  Recurse, because parent may still be a private extension. Also
 190          --  note that the full view of the subtype or the full view of its
 191          --  base type may (both) be unavailable.
 192
 193          return Abstract_Interface_List (Etype (Typ));
 194
 195       else pragma Assert ((Ekind (Typ)) = E_Record_Type);
 196          if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then
 197             Nod := Formal_Type_Definition (Parent (Typ));
 198          else
 199             Nod := Type_Definition (Parent (Typ));
 200          end if;
 201       end if;
 202
 203       return Interface_List (Nod);
 204    end Abstract_Interface_List;
 205
 206    --------------------------------
 207    -- Add_Access_Type_To_Process --
 208    --------------------------------
 209
 210    procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
 211       L : Elist_Id;
 212
 213    begin
 214       Ensure_Freeze_Node (E);
 215       L := Access_Types_To_Process (Freeze_Node (E));
 216
 217       if No (L) then
 218          L := New_Elmt_List;
 219          Set_Access_Types_To_Process (Freeze_Node (E), L);
 220       end if;
 221
 222       Append_Elmt (A, L);
 223    end Add_Access_Type_To_Process;
 224
 225    --------------------------
 226    -- Add_Block_Identifier --
 227    --------------------------
 228
 229    procedure Add_Block_Identifier (N : Node_Id; Id : out Entity_Id) is
 230       Loc : constant Source_Ptr := Sloc (N);
 231
 232    begin
 233       pragma Assert (Nkind (N) = N_Block_Statement);
 234
 235       --  The block already has a label, return its entity
 236
 237       if Present (Identifier (N)) then
 238          Id := Entity (Identifier (N));
 239
 240       --  Create a new block label and set its attributes
 241
 242       else
 243          Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
 244          Set_Etype  (Id, Standard_Void_Type);
 245          Set_Parent (Id, N);
 246
 247          Set_Identifier (N, New_Occurrence_Of (Id, Loc));
 248          Set_Block_Node (Id, Identifier (N));
 249       end if;
 250    end Add_Block_Identifier;
 251
 252    ----------------------------
 253    -- Add_Global_Declaration --
 254    ----------------------------
 255
 256    procedure Add_Global_Declaration (N : Node_Id) is
 257       Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit));
 258
 259    begin
 260       if No (Declarations (Aux_Node)) then
 261          Set_Declarations (Aux_Node, New_List);
 262       end if;
 263
 264       Append_To (Declarations (Aux_Node), N);
 265       Analyze (N);
 266    end Add_Global_Declaration;
 267
 268    --------------------------------
 269    -- Address_Integer_Convert_OK --
 270    --------------------------------
 271
 272    function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
 273    begin
 274       if Allow_Integer_Address
 275         and then ((Is_Descendent_Of_Address  (T1)
 276                     and then Is_Private_Type (T1)
 277                     and then Is_Integer_Type (T2))
 278                             or else
 279                   (Is_Descendent_Of_Address  (T2)
 280                     and then Is_Private_Type (T2)
 281                     and then Is_Integer_Type (T1)))
 282       then
 283          return True;
 284       else
 285          return False;
 286       end if;
 287    end Address_Integer_Convert_OK;
 288
 289    -----------------
 290    -- Addressable --
 291    -----------------
 292
 293    --  For now, just 8/16/32/64. but analyze later if AAMP is special???
 294
 295    function Addressable (V : Uint) return Boolean is
 296    begin
 297       return V = Uint_8  or else
 298              V = Uint_16 or else
 299              V = Uint_32 or else
 300              V = Uint_64;
 301    end Addressable;
 302
 303    function Addressable (V : Int) return Boolean is
 304    begin
 305       return V = 8  or else
 306              V = 16 or else
 307              V = 32 or else
 308              V = 64;
 309    end Addressable;
 310
 311    ---------------------------------
 312    -- Aggregate_Constraint_Checks --
 313    ---------------------------------
 314
 315    procedure Aggregate_Constraint_Checks
 316      (Exp       : Node_Id;
 317       Check_Typ : Entity_Id)
 318    is
 319       Exp_Typ : constant Entity_Id  := Etype (Exp);
 320
 321    begin
 322       if Raises_Constraint_Error (Exp) then
 323          return;
 324       end if;
 325
 326       --  Ada 2005 (AI-230): Generate a conversion to an anonymous access
 327       --  component's type to force the appropriate accessibility checks.
 328
 329       --  Ada 2005 (AI-231): Generate conversion to the null-excluding
 330       --  type to force the corresponding run-time check
 331
 332       if Is_Access_Type (Check_Typ)
 333         and then ((Is_Local_Anonymous_Access (Check_Typ))
 334                     or else (Can_Never_Be_Null (Check_Typ)
 335                               and then not Can_Never_Be_Null (Exp_Typ)))
 336       then
 337          Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
 338          Analyze_And_Resolve (Exp, Check_Typ);
 339          Check_Unset_Reference (Exp);
 340       end if;
 341
 342       --  This is really expansion activity, so make sure that expansion is
 343       --  on and is allowed. In GNATprove mode, we also want check flags to
 344       --  be added in the tree, so that the formal verification can rely on
 345       --  those to be present. In GNATprove mode for formal verification, some
 346       --  treatment typically only done during expansion needs to be performed
 347       --  on the tree, but it should not be applied inside generics. Otherwise,
 348       --  this breaks the name resolution mechanism for generic instances.
 349
 350       if not Expander_Active
 351         and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
 352       then
 353          return;
 354       end if;
 355
 356       --  First check if we have to insert discriminant checks
 357
 358       if Has_Discriminants (Exp_Typ) then
 359          Apply_Discriminant_Check (Exp, Check_Typ);
 360
 361       --  Next emit length checks for array aggregates
 362
 363       elsif Is_Array_Type (Exp_Typ) then
 364          Apply_Length_Check (Exp, Check_Typ);
 365
 366       --  Finally emit scalar and string checks. If we are dealing with a
 367       --  scalar literal we need to check by hand because the Etype of
 368       --  literals is not necessarily correct.
 369
 370       elsif Is_Scalar_Type (Exp_Typ)
 371         and then Compile_Time_Known_Value (Exp)
 372       then
 373          if Is_Out_Of_Range (Exp, Base_Type (Check_Typ)) then
 374             Apply_Compile_Time_Constraint_Error
 375               (Exp, "value not in range of}??", CE_Range_Check_Failed,
 376                Ent => Base_Type (Check_Typ),
 377                Typ => Base_Type (Check_Typ));
 378
 379          elsif Is_Out_Of_Range (Exp, Check_Typ) then
 380             Apply_Compile_Time_Constraint_Error
 381               (Exp, "value not in range of}??", CE_Range_Check_Failed,
 382                Ent => Check_Typ,
 383                Typ => Check_Typ);
 384
 385          elsif not Range_Checks_Suppressed (Check_Typ) then
 386             Apply_Scalar_Range_Check (Exp, Check_Typ);
 387          end if;
 388
 389       --  Verify that target type is also scalar, to prevent view anomalies
 390       --  in instantiations.
 391
 392       elsif (Is_Scalar_Type (Exp_Typ)
 393               or else Nkind (Exp) = N_String_Literal)
 394         and then Is_Scalar_Type (Check_Typ)
 395         and then Exp_Typ /= Check_Typ
 396       then
 397          if Is_Entity_Name (Exp)
 398            and then Ekind (Entity (Exp)) = E_Constant
 399          then
 400             --  If expression is a constant, it is worthwhile checking whether
 401             --  it is a bound of the type.
 402
 403             if (Is_Entity_Name (Type_Low_Bound (Check_Typ))
 404                  and then Entity (Exp) = Entity (Type_Low_Bound (Check_Typ)))
 405               or else
 406                (Is_Entity_Name (Type_High_Bound (Check_Typ))
 407                  and then Entity (Exp) = Entity (Type_High_Bound (Check_Typ)))
 408             then
 409                return;
 410
 411             else
 412                Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
 413                Analyze_And_Resolve (Exp, Check_Typ);
 414                Check_Unset_Reference (Exp);
 415             end if;
 416
 417          --  Could use a comment on this case ???
 418
 419          else
 420             Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
 421             Analyze_And_Resolve (Exp, Check_Typ);
 422             Check_Unset_Reference (Exp);
 423          end if;
 424
 425       end if;
 426    end Aggregate_Constraint_Checks;
 427
 428    -----------------------
 429    -- Alignment_In_Bits --
 430    -----------------------
 431
 432    function Alignment_In_Bits (E : Entity_Id) return Uint is
 433    begin
 434       return Alignment (E) * System_Storage_Unit;
 435    end Alignment_In_Bits;
 436
 437    ---------------------------------
 438    -- Append_Inherited_Subprogram --
 439    ---------------------------------
 440
 441    procedure Append_Inherited_Subprogram (S : Entity_Id) is
 442       Par : constant Entity_Id := Alias (S);
 443       --  The parent subprogram
 444
 445       Scop : constant Entity_Id := Scope (Par);
 446       --  The scope of definition of the parent subprogram
 447
 448       Typ : constant Entity_Id := Defining_Entity (Parent (S));
 449       --  The derived type of which S is a primitive operation
 450
 451       Decl   : Node_Id;
 452       Next_E : Entity_Id;
 453
 454    begin
 455       if Ekind (Current_Scope) = E_Package
 456         and then In_Private_Part (Current_Scope)
 457         and then Has_Private_Declaration (Typ)
 458         and then Is_Tagged_Type (Typ)
 459         and then Scop = Current_Scope
 460       then
 461          --  The inherited operation is available at the earliest place after
 462          --  the derived type declaration ( RM 7.3.1 (6/1)). This is only
 463          --  relevant for type extensions. If the parent operation appears
 464          --  after the type extension, the operation is not visible.
 465
 466          Decl := First
 467                    (Visible_Declarations
 468                      (Package_Specification (Current_Scope)));
 469          while Present (Decl) loop
 470             if Nkind (Decl) = N_Private_Extension_Declaration
 471               and then Defining_Entity (Decl) = Typ
 472             then
 473                if Sloc (Decl) > Sloc (Par) then
 474                   Next_E := Next_Entity (Par);
 475                   Set_Next_Entity (Par, S);
 476                   Set_Next_Entity (S, Next_E);
 477                   return;
 478
 479                else
 480                   exit;
 481                end if;
 482             end if;
 483
 484             Next (Decl);
 485          end loop;
 486       end if;
 487
 488       --  If partial view is not a type extension, or it appears before the
 489       --  subprogram declaration, insert normally at end of entity list.
 490
 491       Append_Entity (S, Current_Scope);
 492    end Append_Inherited_Subprogram;
 493
 494    -----------------------------------------
 495    -- Apply_Compile_Time_Constraint_Error --
 496    -----------------------------------------
 497
 498    procedure Apply_Compile_Time_Constraint_Error
 499      (N      : Node_Id;
 500       Msg    : String;
 501       Reason : RT_Exception_Code;
 502       Ent    : Entity_Id  := Empty;
 503       Typ    : Entity_Id  := Empty;
 504       Loc    : Source_Ptr := No_Location;
 505       Rep    : Boolean    := True;
 506       Warn   : Boolean    := False)
 507    is
 508       Stat   : constant Boolean := Is_Static_Expression (N);
 509       R_Stat : constant Node_Id :=
 510                  Make_Raise_Constraint_Error (Sloc (N), Reason => Reason);
 511       Rtyp   : Entity_Id;
 512
 513    begin
 514       if No (Typ) then
 515          Rtyp := Etype (N);
 516       else
 517          Rtyp := Typ;
 518       end if;
 519
 520       Discard_Node
 521         (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
 522
 523       if not Rep then
 524          return;
 525       end if;
 526
 527       --  Now we replace the node by an N_Raise_Constraint_Error node
 528       --  This does not need reanalyzing, so set it as analyzed now.
 529
 530       Rewrite (N, R_Stat);
 531       Set_Analyzed (N, True);
 532
 533       Set_Etype (N, Rtyp);
 534       Set_Raises_Constraint_Error (N);
 535
 536       --  Now deal with possible local raise handling
 537
 538       Possible_Local_Raise (N, Standard_Constraint_Error);
 539
 540       --  If the original expression was marked as static, the result is
 541       --  still marked as static, but the Raises_Constraint_Error flag is
 542       --  always set so that further static evaluation is not attempted.
 543
 544       if Stat then
 545          Set_Is_Static_Expression (N);
 546       end if;
 547    end Apply_Compile_Time_Constraint_Error;
 548
 549    ---------------------------
 550    -- Async_Readers_Enabled --
 551    ---------------------------
 552
 553    function Async_Readers_Enabled (Id : Entity_Id) return Boolean is
 554    begin
 555       return Has_Enabled_Property (Id, Name_Async_Readers);
 556    end Async_Readers_Enabled;
 557
 558    ---------------------------
 559    -- Async_Writers_Enabled --
 560    ---------------------------
 561
 562    function Async_Writers_Enabled (Id : Entity_Id) return Boolean is
 563    begin
 564       return Has_Enabled_Property (Id, Name_Async_Writers);
 565    end Async_Writers_Enabled;
 566
 567    --------------------------------------
 568    -- Available_Full_View_Of_Component --
 569    --------------------------------------
 570
 571    function Available_Full_View_Of_Component (T : Entity_Id) return Boolean is
 572       ST  : constant Entity_Id := Scope (T);
 573       SCT : constant Entity_Id := Scope (Component_Type (T));
 574    begin
 575       return In_Open_Scopes (ST)
 576         and then In_Open_Scopes (SCT)
 577         and then Scope_Depth (ST) >= Scope_Depth (SCT);
 578    end Available_Full_View_Of_Component;
 579
 580    -------------------
 581    -- Bad_Attribute --
 582    -------------------
 583
 584    procedure Bad_Attribute
 585      (N    : Node_Id;
 586       Nam  : Name_Id;
 587       Warn : Boolean := False)
 588    is
 589    begin
 590       Error_Msg_Warn := Warn;
 591       Error_Msg_N ("unrecognized attribute&<<", N);
 592
 593       --  Check for possible misspelling
 594
 595       Error_Msg_Name_1 := First_Attribute_Name;
 596       while Error_Msg_Name_1 <= Last_Attribute_Name loop
 597          if Is_Bad_Spelling_Of (Nam, Error_Msg_Name_1) then
 598             Error_Msg_N -- CODEFIX
 599               ("\possible misspelling of %<<", N);
 600             exit;
 601          end if;
 602
 603          Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
 604       end loop;
 605    end Bad_Attribute;
 606
 607    --------------------------------
 608    -- Bad_Predicated_Subtype_Use --
 609    --------------------------------
 610
 611    procedure Bad_Predicated_Subtype_Use
 612      (Msg            : String;
 613       N              : Node_Id;
 614       Typ            : Entity_Id;
 615       Suggest_Static : Boolean := False)
 616    is
 617       Gen            : Entity_Id;
 618
 619    begin
 620       --  Avoid cascaded errors
 621
 622       if Error_Posted (N) then
 623          return;
 624       end if;
 625
 626       if Inside_A_Generic then
 627          Gen := Current_Scope;
 628          while Present (Gen) and then  Ekind (Gen) /= E_Generic_Package loop
 629             Gen := Scope (Gen);
 630          end loop;
 631
 632          if No (Gen) then
 633             return;
 634          end if;
 635
 636          if Is_Generic_Formal (Typ) and then Is_Discrete_Type (Typ) then
 637             Set_No_Predicate_On_Actual (Typ);
 638          end if;
 639
 640       elsif Has_Predicates (Typ) then
 641          if Is_Generic_Actual_Type (Typ) then
 642
 643             --  The restriction on loop parameters is only that the type
 644             --  should have no dynamic predicates.
 645
 646             if Nkind (Parent (N)) = N_Loop_Parameter_Specification
 647               and then not Has_Dynamic_Predicate_Aspect (Typ)
 648               and then Is_OK_Static_Subtype (Typ)
 649             then
 650                return;
 651             end if;
 652
 653             Gen := Current_Scope;
 654             while not Is_Generic_Instance (Gen) loop
 655                Gen := Scope (Gen);
 656             end loop;
 657
 658             pragma Assert (Present (Gen));
 659
 660             if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
 661                Error_Msg_Warn := SPARK_Mode /= On;
 662                Error_Msg_FE (Msg & "<<", N, Typ);
 663                Error_Msg_F ("\Program_Error [<<", N);
 664
 665                Insert_Action (N,
 666                  Make_Raise_Program_Error (Sloc (N),
 667                    Reason => PE_Bad_Predicated_Generic_Type));
 668
 669             else
 670                Error_Msg_FE (Msg & "<<", N, Typ);
 671             end if;
 672
 673          else
 674             Error_Msg_FE (Msg, N, Typ);
 675          end if;
 676
 677          --  Emit an optional suggestion on how to remedy the error if the
 678          --  context warrants it.
 679
 680          if Suggest_Static and then Has_Static_Predicate (Typ) then
 681             Error_Msg_FE ("\predicate of & should be marked static", N, Typ);
 682          end if;
 683       end if;
 684    end Bad_Predicated_Subtype_Use;
 685
 686    -----------------------------------------
 687    -- Bad_Unordered_Enumeration_Reference --
 688    -----------------------------------------
 689
 690    function Bad_Unordered_Enumeration_Reference
 691      (N : Node_Id;
 692       T : Entity_Id) return Boolean
 693    is
 694    begin
 695       return Is_Enumeration_Type (T)
 696         and then Warn_On_Unordered_Enumeration_Type
 697         and then not Is_Generic_Type (T)
 698         and then Comes_From_Source (N)
 699         and then not Has_Pragma_Ordered (T)
 700         and then not In_Same_Extended_Unit (N, T);
 701    end Bad_Unordered_Enumeration_Reference;
 702
 703    --------------------------
 704    -- Build_Actual_Subtype --
 705    --------------------------
 706
 707    function Build_Actual_Subtype
 708      (T : Entity_Id;
 709       N : Node_Or_Entity_Id) return Node_Id
 710    is
 711       Loc : Source_Ptr;
 712       --  Normally Sloc (N), but may point to corresponding body in some cases
 713
 714       Constraints : List_Id;
 715       Decl        : Node_Id;
 716       Discr       : Entity_Id;
 717       Hi          : Node_Id;
 718       Lo          : Node_Id;
 719       Subt        : Entity_Id;
 720       Disc_Type   : Entity_Id;
 721       Obj         : Node_Id;
 722
 723    begin
 724       Loc := Sloc (N);
 725
 726       if Nkind (N) = N_Defining_Identifier then
 727          Obj := New_Occurrence_Of (N, Loc);
 728
 729          --  If this is a formal parameter of a subprogram declaration, and
 730          --  we are compiling the body, we want the declaration for the
 731          --  actual subtype to carry the source position of the body, to
 732          --  prevent anomalies in gdb when stepping through the code.
 733
 734          if Is_Formal (N) then
 735             declare
 736                Decl : constant Node_Id := Unit_Declaration_Node (Scope (N));
 737             begin
 738                if Nkind (Decl) = N_Subprogram_Declaration
 739                  and then Present (Corresponding_Body (Decl))
 740                then
 741                   Loc := Sloc (Corresponding_Body (Decl));
 742                end if;
 743             end;
 744          end if;
 745
 746       else
 747          Obj := N;
 748       end if;
 749
 750       if Is_Array_Type (T) then
 751          Constraints := New_List;
 752          for J in 1 .. Number_Dimensions (T) loop
 753
 754             --  Build an array subtype declaration with the nominal subtype and
 755             --  the bounds of the actual. Add the declaration in front of the
 756             --  local declarations for the subprogram, for analysis before any
 757             --  reference to the formal in the body.
 758
 759             Lo :=
 760               Make_Attribute_Reference (Loc,
 761                 Prefix         =>
 762                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 763                 Attribute_Name => Name_First,
 764                 Expressions    => New_List (
 765                   Make_Integer_Literal (Loc, J)));
 766
 767             Hi :=
 768               Make_Attribute_Reference (Loc,
 769                 Prefix         =>
 770                   Duplicate_Subexpr_No_Checks (Obj, Name_Req => True),
 771                 Attribute_Name => Name_Last,
 772                 Expressions    => New_List (
 773                   Make_Integer_Literal (Loc, J)));
 774
 775             Append (Make_Range (Loc, Lo, Hi), Constraints);
 776          end loop;
 777
 778       --  If the type has unknown discriminants there is no constrained
 779       --  subtype to build. This is never called for a formal or for a
 780       --  lhs, so returning the type is ok ???
 781
 782       elsif Has_Unknown_Discriminants (T) then
 783          return T;
 784
 785       else
 786          Constraints := New_List;
 787
 788          --  Type T is a generic derived type, inherit the discriminants from
 789          --  the parent type.
 790
 791          if Is_Private_Type (T)
 792            and then No (Full_View (T))
 793
 794             --  T was flagged as an error if it was declared as a formal
 795             --  derived type with known discriminants. In this case there
 796             --  is no need to look at the parent type since T already carries
 797             --  its own discriminants.
 798
 799            and then not Error_Posted (T)
 800          then
 801             Disc_Type := Etype (Base_Type (T));
 802          else
 803             Disc_Type := T;
 804          end if;
 805
 806          Discr := First_Discriminant (Disc_Type);
 807          while Present (Discr) loop
 808             Append_To (Constraints,
 809               Make_Selected_Component (Loc,
 810                 Prefix =>
 811                   Duplicate_Subexpr_No_Checks (Obj),
 812                 Selector_Name => New_Occurrence_Of (Discr, Loc)));
 813             Next_Discriminant (Discr);
 814          end loop;
 815       end if;
 816
 817       Subt := Make_Temporary (Loc, 'S', Related_Node => N);
 818       Set_Is_Internal (Subt);
 819
 820       Decl :=
 821         Make_Subtype_Declaration (Loc,
 822           Defining_Identifier => Subt,
 823           Subtype_Indication =>
 824             Make_Subtype_Indication (Loc,
 825               Subtype_Mark => New_Occurrence_Of (T,  Loc),
 826               Constraint  =>
 827                 Make_Index_Or_Discriminant_Constraint (Loc,
 828                   Constraints => Constraints)));
 829
 830       Mark_Rewrite_Insertion (Decl);
 831       return Decl;
 832    end Build_Actual_Subtype;
 833
 834    ---------------------------------------
 835    -- Build_Actual_Subtype_Of_Component --
 836    ---------------------------------------
 837
 838    function Build_Actual_Subtype_Of_Component
 839      (T : Entity_Id;
 840       N : Node_Id) return Node_Id
 841    is
 842       Loc       : constant Source_Ptr := Sloc (N);
 843       P         : constant Node_Id    := Prefix (N);
 844       D         : Elmt_Id;
 845       Id        : Node_Id;
 846       Index_Typ : Entity_Id;
 847
 848       Desig_Typ : Entity_Id;
 849       --  This is either a copy of T, or if T is an access type, then it is
 850       --  the directly designated type of this access type.
 851
 852       function Build_Actual_Array_Constraint return List_Id;
 853       --  If one or more of the bounds of the component depends on
 854       --  discriminants, build  actual constraint using the discriminants
 855       --  of the prefix.
 856
 857       function Build_Actual_Record_Constraint return List_Id;
 858       --  Similar to previous one, for discriminated components constrained
 859       --  by the discriminant of the enclosing object.
 860
 861       -----------------------------------
 862       -- Build_Actual_Array_Constraint --
 863       -----------------------------------
 864
 865       function Build_Actual_Array_Constraint return List_Id is
 866          Constraints : constant List_Id := New_List;
 867          Indx        : Node_Id;
 868          Hi          : Node_Id;
 869          Lo          : Node_Id;
 870          Old_Hi      : Node_Id;
 871          Old_Lo      : Node_Id;
 872
 873       begin
 874          Indx := First_Index (Desig_Typ);
 875          while Present (Indx) loop
 876             Old_Lo := Type_Low_Bound  (Etype (Indx));
 877             Old_Hi := Type_High_Bound (Etype (Indx));
 878
 879             if Denotes_Discriminant (Old_Lo) then
 880                Lo :=
 881                  Make_Selected_Component (Loc,
 882                    Prefix => New_Copy_Tree (P),
 883                    Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
 884
 885             else
 886                Lo := New_Copy_Tree (Old_Lo);
 887
 888                --  The new bound will be reanalyzed in the enclosing
 889                --  declaration. For literal bounds that come from a type
 890                --  declaration, the type of the context must be imposed, so
 891                --  insure that analysis will take place. For non-universal
 892                --  types this is not strictly necessary.
 893
 894                Set_Analyzed (Lo, False);
 895             end if;
 896
 897             if Denotes_Discriminant (Old_Hi) then
 898                Hi :=
 899                  Make_Selected_Component (Loc,
 900                    Prefix => New_Copy_Tree (P),
 901                    Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
 902
 903             else
 904                Hi := New_Copy_Tree (Old_Hi);
 905                Set_Analyzed (Hi, False);
 906             end if;
 907
 908             Append (Make_Range (Loc, Lo, Hi), Constraints);
 909             Next_Index (Indx);
 910          end loop;
 911
 912          return Constraints;
 913       end Build_Actual_Array_Constraint;
 914
 915       ------------------------------------
 916       -- Build_Actual_Record_Constraint --
 917       ------------------------------------
 918
 919       function Build_Actual_Record_Constraint return List_Id is
 920          Constraints : constant List_Id := New_List;
 921          D           : Elmt_Id;
 922          D_Val       : Node_Id;
 923
 924       begin
 925          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
 926          while Present (D) loop
 927             if Denotes_Discriminant (Node (D)) then
 928                D_Val := Make_Selected_Component (Loc,
 929                  Prefix => New_Copy_Tree (P),
 930                 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
 931
 932             else
 933                D_Val := New_Copy_Tree (Node (D));
 934             end if;
 935
 936             Append (D_Val, Constraints);
 937             Next_Elmt (D);
 938          end loop;
 939
 940          return Constraints;
 941       end Build_Actual_Record_Constraint;
 942
 943    --  Start of processing for Build_Actual_Subtype_Of_Component
 944
 945    begin
 946       --  Why the test for Spec_Expression mode here???
 947
 948       if In_Spec_Expression then
 949          return Empty;
 950
 951       --  More comments for the rest of this body would be good ???
 952
 953       elsif Nkind (N) = N_Explicit_Dereference then
 954          if Is_Composite_Type (T)
 955            and then not Is_Constrained (T)
 956            and then not (Is_Class_Wide_Type (T)
 957                           and then Is_Constrained (Root_Type (T)))
 958            and then not Has_Unknown_Discriminants (T)
 959          then
 960             --  If the type of the dereference is already constrained, it is an
 961             --  actual subtype.
 962
 963             if Is_Array_Type (Etype (N))
 964               and then Is_Constrained (Etype (N))
 965             then
 966                return Empty;
 967             else
 968                Remove_Side_Effects (P);
 969                return Build_Actual_Subtype (T, N);
 970             end if;
 971          else
 972             return Empty;
 973          end if;
 974       end if;
 975
 976       if Ekind (T) = E_Access_Subtype then
 977          Desig_Typ := Designated_Type (T);
 978       else
 979          Desig_Typ := T;
 980       end if;
 981
 982       if Ekind (Desig_Typ) = E_Array_Subtype then
 983          Id := First_Index (Desig_Typ);
 984          while Present (Id) loop
 985             Index_Typ := Underlying_Type (Etype (Id));
 986
 987             if Denotes_Discriminant (Type_Low_Bound  (Index_Typ))
 988                  or else
 989                Denotes_Discriminant (Type_High_Bound (Index_Typ))
 990             then
 991                Remove_Side_Effects (P);
 992                return
 993                  Build_Component_Subtype
 994                    (Build_Actual_Array_Constraint, Loc, Base_Type (T));
 995             end if;
 996
 997             Next_Index (Id);
 998          end loop;
 999
1000       elsif Is_Composite_Type (Desig_Typ)
1001         and then Has_Discriminants (Desig_Typ)
1002         and then not Has_Unknown_Discriminants (Desig_Typ)
1003       then
1004          if Is_Private_Type (Desig_Typ)
1005            and then No (Discriminant_Constraint (Desig_Typ))
1006          then
1007             Desig_Typ := Full_View (Desig_Typ);
1008          end if;
1009
1010          D := First_Elmt (Discriminant_Constraint (Desig_Typ));
1011          while Present (D) loop
1012             if Denotes_Discriminant (Node (D)) then
1013                Remove_Side_Effects (P);
1014                return
1015                  Build_Component_Subtype (
1016                    Build_Actual_Record_Constraint, Loc, Base_Type (T));
1017             end if;
1018
1019             Next_Elmt (D);
1020          end loop;
1021       end if;
1022
1023       --  If none of the above, the actual and nominal subtypes are the same
1024
1025       return Empty;
1026    end Build_Actual_Subtype_Of_Component;
1027
1028    -----------------------------
1029    -- Build_Component_Subtype --
1030    -----------------------------
1031
1032    function Build_Component_Subtype
1033      (C   : List_Id;
1034       Loc : Source_Ptr;
1035       T   : Entity_Id) return Node_Id
1036    is
1037       Subt : Entity_Id;
1038       Decl : Node_Id;
1039
1040    begin
1041       --  Unchecked_Union components do not require component subtypes
1042
1043       if Is_Unchecked_Union (T) then
1044          return Empty;
1045       end if;
1046
1047       Subt := Make_Temporary (Loc, 'S');
1048       Set_Is_Internal (Subt);
1049
1050       Decl :=
1051         Make_Subtype_Declaration (Loc,
1052           Defining_Identifier => Subt,
1053           Subtype_Indication =>
1054             Make_Subtype_Indication (Loc,
1055               Subtype_Mark => New_Occurrence_Of (Base_Type (T),  Loc),
1056               Constraint  =>
1057                 Make_Index_Or_Discriminant_Constraint (Loc,
1058                   Constraints => C)));
1059
1060       Mark_Rewrite_Insertion (Decl);
1061       return Decl;
1062    end Build_Component_Subtype;
1063
1064    ----------------------------------
1065    -- Build_Default_Init_Cond_Call --
1066    ----------------------------------
1067
1068    function Build_Default_Init_Cond_Call
1069      (Loc    : Source_Ptr;
1070       Obj_Id : Entity_Id;
1071       Typ    : Entity_Id) return Node_Id
1072    is
1073       Proc_Id    : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
1074       Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1075
1076    begin
1077       return
1078         Make_Procedure_Call_Statement (Loc,
1079           Name                   => New_Occurrence_Of (Proc_Id, Loc),
1080           Parameter_Associations => New_List (
1081             Make_Unchecked_Type_Conversion (Loc,
1082               Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1083               Expression   => New_Occurrence_Of (Obj_Id, Loc))));
1084    end Build_Default_Init_Cond_Call;
1085
1086    ----------------------------------------------
1087    -- Build_Default_Init_Cond_Procedure_Bodies --
1088    ----------------------------------------------
1089
1090    procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
1091       procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
1092       --  If type Typ is subject to pragma Default_Initial_Condition, build the
1093       --  body of the procedure which verifies the assumption of the pragma at
1094       --  run time. The generated body is added after the type declaration.
1095
1096       --------------------------------------------
1097       -- Build_Default_Init_Cond_Procedure_Body --
1098       --------------------------------------------
1099
1100       procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
1101          Param_Id : Entity_Id;
1102          --  The entity of the sole formal parameter of the default initial
1103          --  condition procedure.
1104
1105          procedure Replace_Type_Reference (N : Node_Id);
1106          --  Replace a single reference to type Typ with a reference to formal
1107          --  parameter Param_Id.
1108
1109          ----------------------------
1110          -- Replace_Type_Reference --
1111          ----------------------------
1112
1113          procedure Replace_Type_Reference (N : Node_Id) is
1114          begin
1115             Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
1116          end Replace_Type_Reference;
1117
1118          procedure Replace_Type_References is
1119            new Replace_Type_References_Generic (Replace_Type_Reference);
1120
1121          --  Local variables
1122
1123          Loc       : constant Source_Ptr := Sloc (Typ);
1124          Prag      : constant Node_Id    :=
1125                        Get_Pragma (Typ, Pragma_Default_Initial_Condition);
1126          Proc_Id   : constant Entity_Id  := Default_Init_Cond_Procedure (Typ);
1127          Spec_Decl : constant Node_Id    := Unit_Declaration_Node (Proc_Id);
1128          Body_Decl : Node_Id;
1129          Expr      : Node_Id;
1130          Stmt      : Node_Id;
1131
1132          Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1133
1134       --  Start of processing for Build_Default_Init_Cond_Procedure_Body
1135
1136       begin
1137          --  The procedure should be generated only for [sub]types subject to
1138          --  pragma Default_Initial_Condition. Types that inherit the pragma do
1139          --  not get this specialized procedure.
1140
1141          pragma Assert (Has_Default_Init_Cond (Typ));
1142          pragma Assert (Present (Prag));
1143          pragma Assert (Present (Proc_Id));
1144
1145          --  Nothing to do if the body was already built
1146
1147          if Present (Corresponding_Body (Spec_Decl)) then
1148             return;
1149          end if;
1150
1151          --  The related type may be subject to pragma Ghost. Set the mode now
1152          --  to ensure that the analysis and expansion produce Ghost nodes.
1153
1154          Set_Ghost_Mode_From_Entity (Typ);
1155
1156          Param_Id := First_Formal (Proc_Id);
1157
1158          --  The pragma has an argument. Note that the argument is analyzed
1159          --  after all references to the current instance of the type are
1160          --  replaced.
1161
1162          if Present (Pragma_Argument_Associations (Prag)) then
1163             Expr :=
1164               Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
1165
1166             if Nkind (Expr) = N_Null then
1167                Stmt := Make_Null_Statement (Loc);
1168
1169             --  Preserve the original argument of the pragma by replicating it.
1170             --  Replace all references to the current instance of the type with
1171             --  references to the formal parameter.
1172
1173             else
1174                Expr := New_Copy_Tree (Expr);
1175                Replace_Type_References (Expr, Typ);
1176
1177                --  Generate:
1178                --    pragma Check (Default_Initial_Condition, <Expr>);
1179
1180                Stmt :=
1181                  Make_Pragma (Loc,
1182                    Pragma_Identifier            =>
1183                      Make_Identifier (Loc, Name_Check),
1184
1185                    Pragma_Argument_Associations => New_List (
1186                      Make_Pragma_Argument_Association (Loc,
1187                        Expression =>
1188                          Make_Identifier (Loc,
1189                            Chars => Name_Default_Initial_Condition)),
1190                      Make_Pragma_Argument_Association (Loc,
1191                        Expression => Expr)));
1192             end if;
1193
1194          --  Otherwise the pragma appears without an argument
1195
1196          else
1197             Stmt := Make_Null_Statement (Loc);
1198          end if;
1199
1200          --  Generate:
1201          --    procedure <Typ>Default_Init_Cond (I : <Typ>) is
1202          --    begin
1203          --       <Stmt>;
1204          --    end <Typ>Default_Init_Cond;
1205
1206          Body_Decl :=
1207            Make_Subprogram_Body (Loc,
1208              Specification              =>
1209                Copy_Separate_Tree (Specification (Spec_Decl)),
1210              Declarations               => Empty_List,
1211              Handled_Statement_Sequence =>
1212                Make_Handled_Sequence_Of_Statements (Loc,
1213                  Statements => New_List (Stmt)));
1214
1215          --  Link the spec and body of the default initial condition procedure
1216          --  to prevent the generation of a duplicate body.
1217
1218          Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
1219          Set_Corresponding_Spec (Body_Decl, Proc_Id);
1220
1221          Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
1222          Ghost_Mode := Save_Ghost_Mode;
1223       end Build_Default_Init_Cond_Procedure_Body;
1224
1225       --  Local variables
1226
1227       Decl : Node_Id;
1228       Typ  : Entity_Id;
1229
1230    --  Start of processing for Build_Default_Init_Cond_Procedure_Bodies
1231
1232    begin
1233       --  Inspect the private declarations looking for [sub]type declarations
1234
1235       Decl := First (Priv_Decls);
1236       while Present (Decl) loop
1237          if Nkind_In (Decl, N_Full_Type_Declaration,
1238                             N_Subtype_Declaration)
1239          then
1240             Typ := Defining_Entity (Decl);
1241
1242             --  Guard against partially decorate types due to previous errors
1243
1244             if Is_Type (Typ) then
1245
1246                --  If the type is subject to pragma Default_Initial_Condition,
1247                --  generate the body of the internal procedure which verifies
1248                --  the assertion of the pragma at run time.
1249
1250                if Has_Default_Init_Cond (Typ) then
1251                   Build_Default_Init_Cond_Procedure_Body (Typ);
1252
1253                --  A derived type inherits the default initial condition
1254                --  procedure from its parent type.
1255
1256                elsif Has_Inherited_Default_Init_Cond (Typ) then
1257                   Inherit_Default_Init_Cond_Procedure (Typ);
1258                end if;
1259             end if;
1260          end if;
1261
1262          Next (Decl);
1263       end loop;
1264    end Build_Default_Init_Cond_Procedure_Bodies;
1265
1266    ---------------------------------------------------
1267    -- Build_Default_Init_Cond_Procedure_Declaration --
1268    ---------------------------------------------------
1269
1270    procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is
1271       Loc  : constant Source_Ptr := Sloc (Typ);
1272       Prag : constant Node_Id    :=
1273                   Get_Pragma (Typ, Pragma_Default_Initial_Condition);
1274
1275       Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1276
1277       Proc_Id : Entity_Id;
1278
1279    begin
1280       --  The procedure should be generated only for types subject to pragma
1281       --  Default_Initial_Condition. Types that inherit the pragma do not get
1282       --  this specialized procedure.
1283
1284       pragma Assert (Has_Default_Init_Cond (Typ));
1285       pragma Assert (Present (Prag));
1286
1287       --  Nothing to do if default initial condition procedure already built
1288
1289       if Present (Default_Init_Cond_Procedure (Typ)) then
1290          return;
1291       end if;
1292
1293       --  The related type may be subject to pragma Ghost. Set the mode now to
1294       --  ensure that the analysis and expansion produce Ghost nodes.
1295
1296       Set_Ghost_Mode_From_Entity (Typ);
1297
1298       Proc_Id :=
1299         Make_Defining_Identifier (Loc,
1300           Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));
1301
1302       --  Associate default initial condition procedure with the private type
1303
1304       Set_Ekind (Proc_Id, E_Procedure);
1305       Set_Is_Default_Init_Cond_Procedure (Proc_Id);
1306       Set_Default_Init_Cond_Procedure (Typ, Proc_Id);
1307
1308       --  Mark the default initial condition procedure explicitly as Ghost
1309       --  because it does not come from source.
1310
1311       if Ghost_Mode > None then
1312          Set_Is_Ghost_Entity (Proc_Id);
1313       end if;
1314
1315       --  Generate:
1316       --    procedure <Typ>Default_Init_Cond (Inn : <Typ>);
1317
1318       Insert_After_And_Analyze (Prag,
1319         Make_Subprogram_Declaration (Loc,
1320           Specification =>
1321             Make_Procedure_Specification (Loc,
1322               Defining_Unit_Name       => Proc_Id,
1323               Parameter_Specifications => New_List (
1324                 Make_Parameter_Specification (Loc,
1325                   Defining_Identifier => Make_Temporary (Loc, 'I'),
1326                   Parameter_Type      => New_Occurrence_Of (Typ, Loc))))));
1327
1328       Ghost_Mode := Save_Ghost_Mode;
1329    end Build_Default_Init_Cond_Procedure_Declaration;
1330
1331    ---------------------------
1332    -- Build_Default_Subtype --
1333    ---------------------------
1334
1335    function Build_Default_Subtype
1336      (T : Entity_Id;
1337       N : Node_Id) return Entity_Id
1338    is
1339       Loc  : constant Source_Ptr := Sloc (N);
1340       Disc : Entity_Id;
1341
1342       Bas : Entity_Id;
1343       --  The base type that is to be constrained by the defaults
1344
1345    begin
1346       if not Has_Discriminants (T) or else Is_Constrained (T) then
1347          return T;
1348       end if;
1349
1350       Bas := Base_Type (T);
1351
1352       --  If T is non-private but its base type is private, this is the
1353       --  completion of a subtype declaration whose parent type is private
1354       --  (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1355       --  are to be found in the full view of the base. Check that the private
1356       --  status of T and its base differ.
1357
1358       if Is_Private_Type (Bas)
1359         and then not Is_Private_Type (T)
1360         and then Present (Full_View (Bas))
1361       then
1362          Bas := Full_View (Bas);
1363       end if;
1364
1365       Disc := First_Discriminant (T);
1366
1367       if No (Discriminant_Default_Value (Disc)) then
1368          return T;
1369       end if;
1370
1371       declare
1372          Act         : constant Entity_Id := Make_Temporary (Loc, 'S');
1373          Constraints : constant List_Id := New_List;
1374          Decl        : Node_Id;
1375
1376       begin
1377          while Present (Disc) loop
1378             Append_To (Constraints,
1379               New_Copy_Tree (Discriminant_Default_Value (Disc)));
1380             Next_Discriminant (Disc);
1381          end loop;
1382
1383          Decl :=
1384            Make_Subtype_Declaration (Loc,
1385              Defining_Identifier => Act,
1386              Subtype_Indication  =>
1387                Make_Subtype_Indication (Loc,
1388                  Subtype_Mark => New_Occurrence_Of (Bas, Loc),
1389                  Constraint   =>
1390                    Make_Index_Or_Discriminant_Constraint (Loc,
1391                      Constraints => Constraints)));
1392
1393          Insert_Action (N, Decl);
1394
1395          --  If the context is a component declaration the subtype declaration
1396          --  will be analyzed when the enclosing type is frozen, otherwise do
1397          --  it now.
1398
1399          if Ekind (Current_Scope) /= E_Record_Type then
1400             Analyze (Decl);
1401          end if;
1402
1403          return Act;
1404       end;
1405    end Build_Default_Subtype;
1406
1407    --------------------------------------------
1408    -- Build_Discriminal_Subtype_Of_Component --
1409    --------------------------------------------
1410
1411    function Build_Discriminal_Subtype_Of_Component
1412      (T : Entity_Id) return Node_Id
1413    is
1414       Loc : constant Source_Ptr := Sloc (T);
1415       D   : Elmt_Id;
1416       Id  : Node_Id;
1417
1418       function Build_Discriminal_Array_Constraint return List_Id;
1419       --  If one or more of the bounds of the component depends on
1420       --  discriminants, build  actual constraint using the discriminants
1421       --  of the prefix.
1422
1423       function Build_Discriminal_Record_Constraint return List_Id;
1424       --  Similar to previous one, for discriminated components constrained by
1425       --  the discriminant of the enclosing object.
1426
1427       ----------------------------------------
1428       -- Build_Discriminal_Array_Constraint --
1429       ----------------------------------------
1430
1431       function Build_Discriminal_Array_Constraint return List_Id is
1432          Constraints : constant List_Id := New_List;
1433          Indx        : Node_Id;
1434          Hi          : Node_Id;
1435          Lo          : Node_Id;
1436          Old_Hi      : Node_Id;
1437          Old_Lo      : Node_Id;
1438
1439       begin
1440          Indx := First_Index (T);
1441          while Present (Indx) loop
1442             Old_Lo := Type_Low_Bound  (Etype (Indx));
1443             Old_Hi := Type_High_Bound (Etype (Indx));
1444
1445             if Denotes_Discriminant (Old_Lo) then
1446                Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
1447
1448             else
1449                Lo := New_Copy_Tree (Old_Lo);
1450             end if;
1451
1452             if Denotes_Discriminant (Old_Hi) then
1453                Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
1454
1455             else
1456                Hi := New_Copy_Tree (Old_Hi);
1457             end if;
1458
1459             Append (Make_Range (Loc, Lo, Hi), Constraints);
1460             Next_Index (Indx);
1461          end loop;
1462
1463          return Constraints;
1464       end Build_Discriminal_Array_Constraint;
1465
1466       -----------------------------------------
1467       -- Build_Discriminal_Record_Constraint --
1468       -----------------------------------------
1469
1470       function Build_Discriminal_Record_Constraint return List_Id is
1471          Constraints : constant List_Id := New_List;
1472          D           : Elmt_Id;
1473          D_Val       : Node_Id;
1474
1475       begin
1476          D := First_Elmt (Discriminant_Constraint (T));
1477          while Present (D) loop
1478             if Denotes_Discriminant (Node (D)) then
1479                D_Val :=
1480                  New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
1481             else
1482                D_Val := New_Copy_Tree (Node (D));
1483             end if;
1484
1485             Append (D_Val, Constraints);
1486             Next_Elmt (D);
1487          end loop;
1488
1489          return Constraints;
1490       end Build_Discriminal_Record_Constraint;
1491
1492    --  Start of processing for Build_Discriminal_Subtype_Of_Component
1493
1494    begin
1495       if Ekind (T) = E_Array_Subtype then
1496          Id := First_Index (T);
1497          while Present (Id) loop
1498             if Denotes_Discriminant (Type_Low_Bound  (Etype (Id)))
1499                  or else
1500                Denotes_Discriminant (Type_High_Bound (Etype (Id)))
1501             then
1502                return Build_Component_Subtype
1503                  (Build_Discriminal_Array_Constraint, Loc, T);
1504             end if;
1505
1506             Next_Index (Id);
1507          end loop;
1508
1509       elsif Ekind (T) = E_Record_Subtype
1510         and then Has_Discriminants (T)
1511         and then not Has_Unknown_Discriminants (T)
1512       then
1513          D := First_Elmt (Discriminant_Constraint (T));
1514          while Present (D) loop
1515             if Denotes_Discriminant (Node (D)) then
1516                return Build_Component_Subtype
1517                  (Build_Discriminal_Record_Constraint, Loc, T);
1518             end if;
1519
1520             Next_Elmt (D);
1521          end loop;
1522       end if;
1523
1524       --  If none of the above, the actual and nominal subtypes are the same
1525
1526       return Empty;
1527    end Build_Discriminal_Subtype_Of_Component;
1528
1529    ------------------------------
1530    -- Build_Elaboration_Entity --
1531    ------------------------------
1532
1533    procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
1534       Loc      : constant Source_Ptr := Sloc (N);
1535       Decl     : Node_Id;
1536       Elab_Ent : Entity_Id;
1537
1538       procedure Set_Package_Name (Ent : Entity_Id);
1539       --  Given an entity, sets the fully qualified name of the entity in
1540       --  Name_Buffer, with components separated by double underscores. This
1541       --  is a recursive routine that climbs the scope chain to Standard.
1542
1543       ----------------------
1544       -- Set_Package_Name --
1545       ----------------------
1546
1547       procedure Set_Package_Name (Ent : Entity_Id) is
1548       begin
1549          if Scope (Ent) /= Standard_Standard then
1550             Set_Package_Name (Scope (Ent));
1551
1552             declare
1553                Nam : constant String := Get_Name_String (Chars (Ent));
1554             begin
1555                Name_Buffer (Name_Len + 1) := '_';
1556                Name_Buffer (Name_Len + 2) := '_';
1557                Name_Buffer (Name_Len + 3 .. Name_Len + Nam'Length + 2) := Nam;
1558                Name_Len := Name_Len + Nam'Length + 2;
1559             end;
1560
1561          else
1562             Get_Name_String (Chars (Ent));
1563          end if;
1564       end Set_Package_Name;
1565
1566    --  Start of processing for Build_Elaboration_Entity
1567
1568    begin
1569       --  Ignore call if already constructed
1570
1571       if Present (Elaboration_Entity (Spec_Id)) then
1572          return;
1573
1574       --  Ignore in ASIS mode, elaboration entity is not in source and plays
1575       --  no role in analysis.
1576
1577       elsif ASIS_Mode then
1578          return;
1579
1580       --  See if we need elaboration entity. We always need it for the dynamic
1581       --  elaboration model, since it is needed to properly generate the PE
1582       --  exception for access before elaboration.
1583
1584       elsif Dynamic_Elaboration_Checks then
1585          null;
1586
1587       --  For the static model, we don't need the elaboration counter if this
1588       --  unit is sure to have no elaboration code, since that means there
1589       --  is no elaboration unit to be called. Note that we can't just decide
1590       --  after the fact by looking to see whether there was elaboration code,
1591       --  because that's too late to make this decision.
1592
1593       elsif Restriction_Active (No_Elaboration_Code) then
1594          return;
1595
1596       --  Similarly, for the static model, we can skip the elaboration counter
1597       --  if we have the No_Multiple_Elaboration restriction, since for the
1598       --  static model, that's the only purpose of the counter (to avoid
1599       --  multiple elaboration).
1600
1601       elsif Restriction_Active (No_Multiple_Elaboration) then
1602          return;
1603       end if;
1604
1605       --  Here we need the elaboration entity
1606
1607       --  Construct name of elaboration entity as xxx_E, where xxx is the unit
1608       --  name with dots replaced by double underscore. We have to manually
1609       --  construct this name, since it will be elaborated in the outer scope,
1610       --  and thus will not have the unit name automatically prepended.
1611
1612       Set_Package_Name (Spec_Id);
1613       Add_Str_To_Name_Buffer ("_E");
1614
1615       --  Create elaboration counter
1616
1617       Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find);
1618       Set_Elaboration_Entity (Spec_Id, Elab_Ent);
1619
1620       Decl :=
1621         Make_Object_Declaration (Loc,
1622           Defining_Identifier => Elab_Ent,
1623           Object_Definition   =>
1624             New_Occurrence_Of (Standard_Short_Integer, Loc),
1625           Expression          => Make_Integer_Literal (Loc, Uint_0));
1626
1627       Push_Scope (Standard_Standard);
1628       Add_Global_Declaration (Decl);
1629       Pop_Scope;
1630
1631       --  Reset True_Constant indication, since we will indeed assign a value
1632       --  to the variable in the binder main. We also kill the Current_Value
1633       --  and Last_Assignment fields for the same reason.
1634
1635       Set_Is_True_Constant (Elab_Ent, False);
1636       Set_Current_Value    (Elab_Ent, Empty);
1637       Set_Last_Assignment  (Elab_Ent, Empty);
1638
1639       --  We do not want any further qualification of the name (if we did not
1640       --  do this, we would pick up the name of the generic package in the case
1641       --  of a library level generic instantiation).
1642
1643       Set_Has_Qualified_Name       (Elab_Ent);
1644       Set_Has_Fully_Qualified_Name (Elab_Ent);
1645    end Build_Elaboration_Entity;
1646
1647    --------------------------------
1648    -- Build_Explicit_Dereference --
1649    --------------------------------
1650
1651    procedure Build_Explicit_Dereference
1652      (Expr : Node_Id;
1653       Disc : Entity_Id)
1654    is
1655       Loc : constant Source_Ptr := Sloc (Expr);
1656
1657    begin
1658       --  An entity of a type with a reference aspect is overloaded with
1659       --  both interpretations: with and without the dereference. Now that
1660       --  the dereference is made explicit, set the type of the node properly,
1661       --  to prevent anomalies in the backend. Same if the expression is an
1662       --  overloaded function call whose return type has a reference aspect.
1663
1664       if Is_Entity_Name (Expr) then
1665          Set_Etype (Expr, Etype (Entity (Expr)));
1666
1667       elsif Nkind (Expr) = N_Function_Call then
1668          Set_Etype (Expr, Etype (Name (Expr)));
1669       end if;
1670
1671       Set_Is_Overloaded (Expr, False);
1672
1673       --  The expression will often be a generalized indexing that yields a
1674       --  container element that is then dereferenced, in which case the
1675       --  generalized indexing call is also non-overloaded.
1676
1677       if Nkind (Expr) = N_Indexed_Component
1678         and then Present (Generalized_Indexing (Expr))
1679       then
1680          Set_Is_Overloaded (Generalized_Indexing (Expr), False);
1681       end if;
1682
1683       Rewrite (Expr,
1684         Make_Explicit_Dereference (Loc,
1685           Prefix =>
1686             Make_Selected_Component (Loc,
1687               Prefix        => Relocate_Node (Expr),
1688               Selector_Name => New_Occurrence_Of (Disc, Loc))));
1689       Set_Etype (Prefix (Expr), Etype (Disc));
1690       Set_Etype (Expr, Designated_Type (Etype (Disc)));
1691    end Build_Explicit_Dereference;
1692
1693    -----------------------------------
1694    -- Cannot_Raise_Constraint_Error --
1695    -----------------------------------
1696
1697    function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is
1698    begin
1699       if Compile_Time_Known_Value (Expr) then
1700          return True;
1701
1702       elsif Do_Range_Check (Expr) then
1703          return False;
1704
1705       elsif Raises_Constraint_Error (Expr) then
1706          return False;
1707
1708       else
1709          case Nkind (Expr) is
1710             when N_Identifier =>
1711                return True;
1712
1713             when N_Expanded_Name =>
1714                return True;
1715
1716             when N_Selected_Component =>
1717                return not Do_Discriminant_Check (Expr);
1718
1719             when N_Attribute_Reference =>
1720                if Do_Overflow_Check (Expr) then
1721                   return False;
1722
1723                elsif No (Expressions (Expr)) then
1724                   return True;
1725
1726                else
1727                   declare
1728                      N : Node_Id;
1729
1730                   begin
1731                      N := First (Expressions (Expr));
1732                      while Present (N) loop
1733                         if Cannot_Raise_Constraint_Error (N) then
1734                            Next (N);
1735                         else
1736                            return False;
1737                         end if;
1738                      end loop;
1739
1740                      return True;
1741                   end;
1742                end if;
1743
1744             when N_Type_Conversion =>
1745                if Do_Overflow_Check (Expr)
1746                  or else Do_Length_Check (Expr)
1747                  or else Do_Tag_Check (Expr)
1748                then
1749                   return False;
1750                else
1751                   return Cannot_Raise_Constraint_Error (Expression (Expr));
1752                end if;
1753
1754             when N_Unchecked_Type_Conversion =>
1755                return Cannot_Raise_Constraint_Error (Expression (Expr));
1756
1757             when N_Unary_Op =>
1758                if Do_Overflow_Check (Expr) then
1759                   return False;
1760                else
1761                   return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1762                end if;
1763
1764             when N_Op_Divide |
1765                  N_Op_Mod    |
1766                  N_Op_Rem
1767             =>
1768                if Do_Division_Check (Expr)
1769                     or else
1770                   Do_Overflow_Check (Expr)
1771                then
1772                   return False;
1773                else
1774                   return
1775                     Cannot_Raise_Constraint_Error (Left_Opnd  (Expr))
1776                       and then
1777                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1778                end if;
1779
1780             when N_Op_Add                    |
1781                  N_Op_And                    |
1782                  N_Op_Concat                 |
1783                  N_Op_Eq                     |
1784                  N_Op_Expon                  |
1785                  N_Op_Ge                     |
1786                  N_Op_Gt                     |
1787                  N_Op_Le                     |
1788                  N_Op_Lt                     |
1789                  N_Op_Multiply               |
1790                  N_Op_Ne                     |
1791                  N_Op_Or                     |
1792                  N_Op_Rotate_Left            |
1793                  N_Op_Rotate_Right           |
1794                  N_Op_Shift_Left             |
1795                  N_Op_Shift_Right            |
1796                  N_Op_Shift_Right_Arithmetic |
1797                  N_Op_Subtract               |
1798                  N_Op_Xor
1799             =>
1800                if Do_Overflow_Check (Expr) then
1801                   return False;
1802                else
1803                   return
1804                     Cannot_Raise_Constraint_Error (Left_Opnd  (Expr))
1805                       and then
1806                     Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
1807                end if;
1808
1809             when others =>
1810                return False;
1811          end case;
1812       end if;
1813    end Cannot_Raise_Constraint_Error;
1814
1815    -----------------------------------------
1816    -- Check_Dynamically_Tagged_Expression --
1817    -----------------------------------------
1818
1819    procedure Check_Dynamically_Tagged_Expression
1820      (Expr        : Node_Id;
1821       Typ         : Entity_Id;
1822       Related_Nod : Node_Id)
1823    is
1824    begin
1825       pragma Assert (Is_Tagged_Type (Typ));
1826
1827       --  In order to avoid spurious errors when analyzing the expanded code,
1828       --  this check is done only for nodes that come from source and for
1829       --  actuals of generic instantiations.
1830
1831       if (Comes_From_Source (Related_Nod)
1832            or else In_Generic_Actual (Expr))
1833         and then (Is_Class_Wide_Type (Etype (Expr))
1834                    or else Is_Dynamically_Tagged (Expr))
1835         and then Is_Tagged_Type (Typ)
1836         and then not Is_Class_Wide_Type (Typ)
1837       then
1838          Error_Msg_N ("dynamically tagged expression not allowed!", Expr);
1839       end if;
1840    end Check_Dynamically_Tagged_Expression;
1841
1842    --------------------------
1843    -- Check_Fully_Declared --
1844    --------------------------
1845
1846    procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
1847    begin
1848       if Ekind (T) = E_Incomplete_Type then
1849
1850          --  Ada 2005 (AI-50217): If the type is available through a limited
1851          --  with_clause, verify that its full view has been analyzed.
1852
1853          if From_Limited_With (T)
1854            and then Present (Non_Limited_View (T))
1855            and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
1856          then
1857             --  The non-limited view is fully declared
1858
1859             null;
1860
1861          else
1862             Error_Msg_NE
1863               ("premature usage of incomplete}", N, First_Subtype (T));
1864          end if;
1865
1866       --  Need comments for these tests ???
1867
1868       elsif Has_Private_Component (T)
1869         and then not Is_Generic_Type (Root_Type (T))
1870         and then not In_Spec_Expression
1871       then
1872          --  Special case: if T is the anonymous type created for a single
1873          --  task or protected object, use the name of the source object.
1874
1875          if Is_Concurrent_Type (T)
1876            and then not Comes_From_Source (T)
1877            and then Nkind (N) = N_Object_Declaration
1878          then
1879             Error_Msg_NE
1880               ("type of& has incomplete component",
1881                N, Defining_Identifier (N));
1882          else
1883             Error_Msg_NE
1884               ("premature usage of incomplete}",
1885                N, First_Subtype (T));
1886          end if;
1887       end if;
1888    end Check_Fully_Declared;
1889
1890    -------------------------------------------
1891    -- Check_Function_With_Address_Parameter --
1892    -------------------------------------------
1893
1894    procedure Check_Function_With_Address_Parameter (Subp_Id : Entity_Id) is
1895       F : Entity_Id;
1896       T : Entity_Id;
1897
1898    begin
1899       F := First_Formal (Subp_Id);
1900       while Present (F) loop
1901          T := Etype (F);
1902
1903          if Is_Private_Type (T) and then Present (Full_View (T)) then
1904             T := Full_View (T);
1905          end if;
1906
1907          if Is_Descendent_Of_Address (T) or else Is_Limited_Type (T) then
1908             Set_Is_Pure (Subp_Id, False);
1909             exit;
1910          end if;
1911
1912          Next_Formal (F);
1913       end loop;
1914    end Check_Function_With_Address_Parameter;
1915
1916    -------------------------------------
1917    -- Check_Function_Writable_Actuals --
1918    -------------------------------------
1919
1920    procedure Check_Function_Writable_Actuals (N : Node_Id) is
1921       Writable_Actuals_List : Elist_Id := No_Elist;
1922       Identifiers_List      : Elist_Id := No_Elist;
1923       Aggr_Error_Node       : Node_Id  := Empty;
1924       Error_Node            : Node_Id  := Empty;
1925
1926       procedure Collect_Identifiers (N : Node_Id);
1927       --  In a single traversal of subtree N collect in Writable_Actuals_List
1928       --  all the actuals of functions with writable actuals, and in the list
1929       --  Identifiers_List collect all the identifiers that are not actuals of
1930       --  functions with writable actuals. If a writable actual is referenced
1931       --  twice as writable actual then Error_Node is set to reference its
1932       --  second occurrence, the error is reported, and the tree traversal
1933       --  is abandoned.
1934
1935       function Get_Function_Id (Call : Node_Id) return Entity_Id;
1936       --  Return the entity associated with the function call
1937
1938       procedure Preanalyze_Without_Errors (N : Node_Id);
1939       --  Preanalyze N without reporting errors. Very dubious, you can't just
1940       --  go analyzing things more than once???
1941
1942       -------------------------
1943       -- Collect_Identifiers --
1944       -------------------------
1945
1946       procedure Collect_Identifiers (N : Node_Id) is
1947
1948          function Check_Node (N : Node_Id) return Traverse_Result;
1949          --  Process a single node during the tree traversal to collect the
1950          --  writable actuals of functions and all the identifiers which are
1951          --  not writable actuals of functions.
1952
1953          function Contains (List : Elist_Id; N : Node_Id) return Boolean;
1954          --  Returns True if List has a node whose Entity is Entity (N)
1955
1956          -------------------------
1957          -- Check_Function_Call --
1958          -------------------------
1959
1960          function Check_Node (N : Node_Id) return Traverse_Result is
1961             Is_Writable_Actual : Boolean := False;
1962             Id                 : Entity_Id;
1963
1964          begin
1965             if Nkind (N) = N_Identifier then
1966
1967                --  No analysis possible if the entity is not decorated
1968
1969                if No (Entity (N)) then
1970                   return Skip;
1971
1972                --  Don't collect identifiers of packages, called functions, etc
1973
1974                elsif Ekind_In (Entity (N), E_Package,
1975                                            E_Function,
1976                                            E_Procedure,
1977                                            E_Entry)
1978                then
1979                   return Skip;
1980
1981                --  For rewritten nodes, continue the traversal in the original
1982                --  subtree. Needed to handle aggregates in original expressions
1983                --  extracted from the tree by Remove_Side_Effects.
1984
1985                elsif Is_Rewrite_Substitution (N) then
1986                   Collect_Identifiers (Original_Node (N));
1987                   return Skip;
1988
1989                --  For now we skip aggregate discriminants, since they require
1990                --  performing the analysis in two phases to identify conflicts:
1991                --  first one analyzing discriminants and second one analyzing
1992                --  the rest of components (since at run time, discriminants are
1993                --  evaluated prior to components): too much computation cost
1994                --  to identify a corner case???
1995
1996                elsif Nkind (Parent (N)) = N_Component_Association
1997                   and then Nkind_In (Parent (Parent (N)),
1998                                      N_Aggregate,
1999                                      N_Extension_Aggregate)
2000                then
2001                   declare
2002                      Choice : constant Node_Id := First (Choices (Parent (N)));
2003
2004                   begin
2005                      if Ekind (Entity (N)) = E_Discriminant then
2006                         return Skip;
2007
2008                      elsif Expression (Parent (N)) = N
2009                        and then Nkind (Choice) = N_Identifier
2010                        and then Ekind (Entity (Choice)) = E_Discriminant
2011                      then
2012                         return Skip;
2013                      end if;
2014                   end;
2015
2016                --  Analyze if N is a writable actual of a function
2017
2018                elsif Nkind (Parent (N)) = N_Function_Call then
2019                   declare
2020                      Call   : constant Node_Id := Parent (N);
2021                      Actual : Node_Id;
2022                      Formal : Node_Id;
2023
2024                   begin
2025                      Id := Get_Function_Id (Call);
2026
2027                      --  In case of previous error, no check is possible
2028
2029                      if No (Id) then
2030                         return Abandon;
2031                      end if;
2032
2033                      if Ekind_In (Id, E_Function, E_Generic_Function)
2034                        and then Has_Out_Or_In_Out_Parameter (Id)
2035                      then
2036                         Formal := First_Formal (Id);
2037                         Actual := First_Actual (Call);
2038                         while Present (Actual) and then Present (Formal) loop
2039                            if Actual = N then
2040                               if Ekind_In (Formal, E_Out_Parameter,
2041                                                    E_In_Out_Parameter)
2042                               then
2043                                  Is_Writable_Actual := True;
2044                               end if;
2045
2046                               exit;
2047                            end if;
2048
2049                            Next_Formal (Formal);
2050                            Next_Actual (Actual);
2051                         end loop;
2052                      end if;
2053                   end;
2054                end if;
2055
2056                if Is_Writable_Actual then
2057
2058                   --  Skip checking the error in non-elementary types since
2059                   --  RM 6.4.1(6.15/3) is restricted to elementary types, but
2060                   --  store this actual in Writable_Actuals_List since it is
2061                   --  needed to perform checks on other constructs that have
2062                   --  arbitrary order of evaluation (for example, aggregates).
2063
2064                   if not Is_Elementary_Type (Etype (N)) then
2065                      if not Contains (Writable_Actuals_List, N) then
2066                         Append_New_Elmt (N, To => Writable_Actuals_List);
2067                      end if;
2068
2069                   --  Second occurrence of an elementary type writable actual
2070
2071                   elsif Contains (Writable_Actuals_List, N) then
2072
2073                      --  Report the error on the second occurrence of the
2074                      --  identifier. We cannot assume that N is the second
2075                      --  occurrence (according to their location in the
2076                      --  sources), since Traverse_Func walks through Field2
2077                      --  last (see comment in the body of Traverse_Func).
2078
2079                      declare
2080                         Elmt : Elmt_Id;
2081
2082                      begin
2083                         Elmt := First_Elmt (Writable_Actuals_List);
2084                         while Present (Elmt)
2085                            and then Entity (Node (Elmt)) /= Entity (N)
2086                         loop
2087                            Next_Elmt (Elmt);
2088                         end loop;
2089
2090                         if Sloc (N) > Sloc (Node (Elmt)) then
2091                            Error_Node := N;
2092                         else
2093                            Error_Node := Node (Elmt);
2094                         end if;
2095
2096                         Error_Msg_NE
2097                           ("value may be affected by call to & "
2098                            & "because order of evaluation is arbitrary",
2099                            Error_Node, Id);
2100                         return Abandon;
2101                      end;
2102
2103                   --  First occurrence of a elementary type writable actual
2104
2105                   else
2106                      Append_New_Elmt (N, To => Writable_Actuals_List);
2107                   end if;
2108
2109                else
2110                   if Identifiers_List = No_Elist then
2111                      Identifiers_List := New_Elmt_List;
2112                   end if;
2113
2114                   Append_Unique_Elmt (N, Identifiers_List);
2115                end if;
2116             end if;
2117
2118             return OK;
2119          end Check_Node;
2120
2121          --------------
2122          -- Contains --
2123          --------------
2124
2125          function Contains
2126            (List : Elist_Id;
2127             N    : Node_Id) return Boolean
2128          is
2129             pragma Assert (Nkind (N) in N_Has_Entity);
2130
2131             Elmt : Elmt_Id;
2132
2133          begin
2134             if List = No_Elist then
2135                return False;
2136             end if;
2137
2138             Elmt := First_Elmt (List);
2139             while Present (Elmt) loop
2140                if Entity (Node (Elmt)) = Entity (N) then
2141                   return True;
2142                else
2143                   Next_Elmt (Elmt);
2144                end if;
2145             end loop;
2146
2147             return False;
2148          end Contains;
2149
2150          ------------------
2151          -- Do_Traversal --
2152          ------------------
2153
2154          procedure Do_Traversal is new Traverse_Proc (Check_Node);
2155          --  The traversal procedure
2156
2157       --  Start of processing for Collect_Identifiers
2158
2159       begin
2160          if Present (Error_Node) then
2161             return;
2162          end if;
2163
2164          if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
2165             return;
2166          end if;
2167
2168          Do_Traversal (N);
2169       end Collect_Identifiers;
2170
2171       ---------------------
2172       -- Get_Function_Id --
2173       ---------------------
2174
2175       function Get_Function_Id (Call : Node_Id) return Entity_Id is
2176          Nam : constant Node_Id := Name (Call);
2177          Id  : Entity_Id;
2178
2179       begin
2180          if Nkind (Nam) = N_Explicit_Dereference then
2181             Id := Etype (Nam);
2182             pragma Assert (Ekind (Id) = E_Subprogram_Type);
2183
2184          elsif Nkind (Nam) = N_Selected_Component then
2185             Id := Entity (Selector_Name (Nam));
2186
2187          elsif Nkind (Nam) = N_Indexed_Component then
2188             Id := Entity (Selector_Name (Prefix (Nam)));
2189
2190          else
2191             Id := Entity (Nam);
2192          end if;
2193
2194          return Id;
2195       end Get_Function_Id;
2196
2197       -------------------------------
2198       -- Preanalyze_Without_Errors --
2199       -------------------------------
2200
2201       procedure Preanalyze_Without_Errors (N : Node_Id) is
2202          Status : constant Boolean := Get_Ignore_Errors;
2203       begin
2204          Set_Ignore_Errors (True);
2205          Preanalyze (N);
2206          Set_Ignore_Errors (Status);
2207       end Preanalyze_Without_Errors;
2208
2209    --  Start of processing for Check_Function_Writable_Actuals
2210
2211    begin
2212       --  The check only applies to Ada 2012 code on which Check_Actuals has
2213       --  been set, and only to constructs that have multiple constituents
2214       --  whose order of evaluation is not specified by the language.
2215
2216       if Ada_Version < Ada_2012
2217         or else not Check_Actuals (N)
2218         or else (not (Nkind (N) in N_Op)
2219                   and then not (Nkind (N) in N_Membership_Test)
2220                   and then not Nkind_In (N, N_Range,
2221                                             N_Aggregate,
2222                                             N_Extension_Aggregate,
2223                                             N_Full_Type_Declaration,
2224                                             N_Function_Call,
2225                                             N_Procedure_Call_Statement,
2226                                             N_Entry_Call_Statement))
2227         or else (Nkind (N) = N_Full_Type_Declaration
2228                   and then not Is_Record_Type (Defining_Identifier (N)))
2229
2230         --  In addition, this check only applies to source code, not to code
2231         --  generated by constraint checks.
2232
2233         or else not Comes_From_Source (N)
2234       then
2235          return;
2236       end if;
2237
2238       --  If a construct C has two or more direct constituents that are names
2239       --  or expressions whose evaluation may occur in an arbitrary order, at
2240       --  least one of which contains a function call with an in out or out
2241       --  parameter, then the construct is legal only if: for each name N that
2242       --  is passed as a parameter of mode in out or out to some inner function
2243       --  call C2 (not including the construct C itself), there is no other
2244       --  name anywhere within a direct constituent of the construct C other
2245       --  than the one containing C2, that is known to refer to the same
2246       --  object (RM 6.4.1(6.17/3)).
2247
2248       case Nkind (N) is
2249          when N_Range =>
2250             Collect_Identifiers (Low_Bound (N));
2251             Collect_Identifiers (High_Bound (N));
2252
2253          when N_Op | N_Membership_Test =>
2254             declare
2255                Expr : Node_Id;
2256
2257             begin
2258                Collect_Identifiers (Left_Opnd (N));
2259
2260                if Present (Right_Opnd (N)) then
2261                   Collect_Identifiers (Right_Opnd (N));
2262                end if;
2263
2264                if Nkind_In (N, N_In, N_Not_In)
2265                  and then Present (Alternatives (N))
2266                then
2267                   Expr := First (Alternatives (N));
2268                   while Present (Expr) loop
2269                      Collect_Identifiers (Expr);
2270
2271                      Next (Expr);
2272                   end loop;
2273                end if;
2274             end;
2275
2276          when N_Full_Type_Declaration =>
2277             declare
2278                function Get_Record_Part (N : Node_Id) return Node_Id;
2279                --  Return the record part of this record type definition
2280
2281                function Get_Record_Part (N : Node_Id) return Node_Id is
2282                   Type_Def : constant Node_Id := Type_Definition (N);
2283                begin
2284                   if Nkind (Type_Def) = N_Derived_Type_Definition then
2285                      return Record_Extension_Part (Type_Def);
2286                   else
2287                      return Type_Def;
2288                   end if;
2289                end Get_Record_Part;
2290
2291                Comp   : Node_Id;
2292                Def_Id : Entity_Id := Defining_Identifier (N);
2293                Rec    : Node_Id   := Get_Record_Part (N);
2294
2295             begin
2296                --  No need to perform any analysis if the record has no
2297                --  components
2298
2299                if No (Rec) or else No (Component_List (Rec)) then
2300                   return;
2301                end if;
2302
2303                --  Collect the identifiers starting from the deepest
2304                --  derivation. Done to report the error in the deepest
2305                --  derivation.
2306
2307                loop
2308                   if Present (Component_List (Rec)) then
2309                      Comp := First (Component_Items (Component_List (Rec)));
2310                      while Present (Comp) loop
2311                         if Nkind (Comp) = N_Component_Declaration
2312                           and then Present (Expression (Comp))
2313                         then
2314                            Collect_Identifiers (Expression (Comp));
2315                         end if;
2316
2317                         Next (Comp);
2318                      end loop;
2319                   end if;
2320
2321                   exit when No (Underlying_Type (Etype (Def_Id)))
2322                     or else Base_Type (Underlying_Type (Etype (Def_Id)))
2323                               = Def_Id;
2324
2325                   Def_Id := Base_Type (Underlying_Type (Etype (Def_Id)));
2326                   Rec := Get_Record_Part (Parent (Def_Id));
2327                end loop;
2328             end;
2329
2330          when N_Subprogram_Call      |
2331               N_Entry_Call_Statement =>
2332             declare
2333                Id     : constant Entity_Id := Get_Function_Id (N);
2334                Formal : Node_Id;
2335                Actual : Node_Id;
2336
2337             begin
2338                Formal := First_Formal (Id);
2339                Actual := First_Actual (N);
2340                while Present (Actual) and then Present (Formal) loop
2341                   if Ekind_In (Formal, E_Out_Parameter,
2342                                        E_In_Out_Parameter)
2343                   then
2344                      Collect_Identifiers (Actual);
2345                   end if;
2346
2347                   Next_Formal (Formal);
2348                   Next_Actual (Actual);
2349                end loop;
2350             end;
2351
2352          when N_Aggregate           |
2353               N_Extension_Aggregate =>
2354             declare
2355                Assoc     : Node_Id;
2356                Choice    : Node_Id;
2357                Comp_Expr : Node_Id;
2358
2359             begin
2360                --  Handle the N_Others_Choice of array aggregates with static
2361                --  bounds. There is no need to perform this analysis in
2362                --  aggregates without static bounds since we cannot evaluate
2363                --  if the N_Others_Choice covers several elements. There is
2364                --  no need to handle the N_Others choice of record aggregates
2365                --  since at this stage it has been already expanded by
2366                --  Resolve_Record_Aggregate.
2367
2368                if Is_Array_Type (Etype (N))
2369                  and then Nkind (N) = N_Aggregate
2370                  and then Present (Aggregate_Bounds (N))
2371                  and then Compile_Time_Known_Bounds (Etype (N))
2372                  and then Expr_Value (High_Bound (Aggregate_Bounds (N)))
2373                             >
2374                           Expr_Value (Low_Bound (Aggregate_Bounds (N)))
2375                then
2376                   declare
2377                      Count_Components   : Uint := Uint_0;
2378                      Num_Components     : Uint;
2379                      Others_Assoc       : Node_Id;
2380                      Others_Choice      : Node_Id := Empty;
2381                      Others_Box_Present : Boolean := False;
2382
2383                   begin
2384                      --  Count positional associations
2385
2386                      if Present (Expressions (N)) then
2387                         Comp_Expr := First (Expressions (N));
2388                         while Present (Comp_Expr) loop
2389                            Count_Components := Count_Components + 1;
2390                            Next (Comp_Expr);
2391                         end loop;
2392                      end if;
2393
2394                      --  Count the rest of elements and locate the N_Others
2395                      --  choice (if any)
2396
2397                      Assoc := First (Component_Associations (N));
2398                      while Present (Assoc) loop
2399                         Choice := First (Choices (Assoc));
2400                         while Present (Choice) loop
2401                            if Nkind (Choice) = N_Others_Choice then
2402                               Others_Assoc       := Assoc;
2403                               Others_Choice      := Choice;
2404                               Others_Box_Present := Box_Present (Assoc);
2405
2406                            --  Count several components
2407
2408                            elsif Nkind_In (Choice, N_Range,
2409                                                    N_Subtype_Indication)
2410                              or else (Is_Entity_Name (Choice)
2411                                        and then Is_Type (Entity (Choice)))
2412                            then
2413                               declare
2414                                  L, H : Node_Id;
2415                               begin
2416                                  Get_Index_Bounds (Choice, L, H);
2417                                  pragma Assert
2418                                    (Compile_Time_Known_Value (L)
2419                                      and then Compile_Time_Known_Value (H));
2420                                  Count_Components :=
2421                                    Count_Components
2422                                      + Expr_Value (H) - Expr_Value (L) + 1;
2423                               end;
2424
2425                            --  Count single component. No other case available
2426                            --  since we are handling an aggregate with static
2427                            --  bounds.
2428
2429                            else
2430                               pragma Assert (Is_OK_Static_Expression (Choice)
2431                                 or else Nkind (Choice) = N_Identifier
2432                                 or else Nkind (Choice) = N_Integer_Literal);
2433
2434                               Count_Components := Count_Components + 1;
2435                            end if;
2436
2437                            Next (Choice);
2438                         end loop;
2439
2440                         Next (Assoc);
2441                      end loop;
2442
2443                      Num_Components :=
2444                        Expr_Value (High_Bound (Aggregate_Bounds (N))) -
2445                          Expr_Value (Low_Bound (Aggregate_Bounds (N))) + 1;
2446
2447                      pragma Assert (Count_Components <= Num_Components);
2448
2449                      --  Handle the N_Others choice if it covers several
2450                      --  components
2451
2452                      if Present (Others_Choice)
2453                        and then (Num_Components - Count_Components) > 1
2454                      then
2455                         if not Others_Box_Present then
2456
2457                            --  At this stage, if expansion is active, the
2458                            --  expression of the others choice has not been
2459                            --  analyzed. Hence we generate a duplicate and
2460                            --  we analyze it silently to have available the
2461                            --  minimum decoration required to collect the
2462                            --  identifiers.
2463
2464                            if not Expander_Active then
2465                               Comp_Expr := Expression (Others_Assoc);
2466                            else
2467                               Comp_Expr :=
2468                                 New_Copy_Tree (Expression (Others_Assoc));
2469                               Preanalyze_Without_Errors (Comp_Expr);
2470                            end if;
2471
2472                            Collect_Identifiers (Comp_Expr);
2473
2474                            if Writable_Actuals_List /= No_Elist then
2475
2476                               --  As suggested by Robert, at current stage we
2477                               --  report occurrences of this case as warnings.
2478
2479                               Error_Msg_N
2480                                 ("writable function parameter may affect "
2481                                  & "value in other component because order "
2482                                  & "of evaluation is unspecified??",
2483                                  Node (First_Elmt (Writable_Actuals_List)));
2484                            end if;
2485                         end if;
2486                      end if;
2487                   end;
2488
2489                --  For an array aggregate, a discrete_choice_list that has
2490                --  a nonstatic range is considered as two or more separate
2491                --  occurrences of the expression (RM 6.4.1(20/3)).
2492
2493                elsif Is_Array_Type (Etype (N))
2494                  and then Nkind (N) = N_Aggregate
2495                  and then Present (Aggregate_Bounds (N))
2496                  and then not Compile_Time_Known_Bounds (Etype (N))
2497                then
2498                   --  Collect identifiers found in the dynamic bounds
2499
2500                   declare
2501                      Count_Components : Natural := 0;
2502                      Low, High        : Node_Id;
2503
2504                   begin
2505                      Assoc := First (Component_Associations (N));
2506                      while Present (Assoc) loop
2507                         Choice := First (Choices (Assoc));
2508                         while Present (Choice) loop
2509                            if Nkind_In (Choice, N_Range,
2510                                                    N_Subtype_Indication)
2511                              or else (Is_Entity_Name (Choice)
2512                                        and then Is_Type (Entity (Choice)))
2513                            then
2514                               Get_Index_Bounds (Choice, Low, High);
2515
2516                               if not Compile_Time_Known_Value (Low) then
2517                                  Collect_Identifiers (Low);
2518
2519                                  if No (Aggr_Error_Node) then
2520                                     Aggr_Error_Node := Low;
2521                                  end if;
2522                               end if;
2523
2524                               if not Compile_Time_Known_Value (High) then
2525                                  Collect_Identifiers (High);
2526
2527                                  if No (Aggr_Error_Node) then
2528                                     Aggr_Error_Node := High;
2529                                  end if;
2530                               end if;
2531
2532                            --  The RM rule is violated if there is more than
2533                            --  a single choice in a component association.
2534
2535                            else
2536                               Count_Components := Count_Components + 1;
2537
2538                               if No (Aggr_Error_Node)
2539                                 and then Count_Components > 1
2540                               then
2541                                  Aggr_Error_Node := Choice;
2542                               end if;
2543
2544                               if not Compile_Time_Known_Value (Choice) then
2545                                  Collect_Identifiers (Choice);
2546                               end if;
2547                            end if;
2548
2549                            Next (Choice);
2550                         end loop;
2551
2552                         Next (Assoc);
2553                      end loop;
2554                   end;
2555                end if;
2556
2557                --  Handle ancestor part of extension aggregates
2558
2559                if Nkind (N) = N_Extension_Aggregate then
2560                   Collect_Identifiers (Ancestor_Part (N));
2561                end if;
2562
2563                --  Handle positional associations
2564
2565                if Present (Expressions (N)) then
2566                   Comp_Expr := First (Expressions (N));
2567                   while Present (Comp_Expr) loop
2568                      if not Is_OK_Static_Expression (Comp_Expr) then
2569                         Collect_Identifiers (Comp_Expr);
2570                      end if;
2571
2572                      Next (Comp_Expr);
2573                   end loop;
2574                end if;
2575
2576                --  Handle discrete associations
2577
2578                if Present (Component_Associations (N)) then
2579                   Assoc := First (Component_Associations (N));
2580                   while Present (Assoc) loop
2581
2582                      if not Box_Present (Assoc) then
2583                         Choice := First (Choices (Assoc));
2584                         while Present (Choice) loop
2585
2586                            --  For now we skip discriminants since it requires
2587                            --  performing the analysis in two phases: first one
2588                            --  analyzing discriminants and second one analyzing
2589                            --  the rest of components since discriminants are
2590                            --  evaluated prior to components: too much extra
2591                            --  work to detect a corner case???
2592
2593                            if Nkind (Choice) in N_Has_Entity
2594                              and then Present (Entity (Choice))
2595                              and then Ekind (Entity (Choice)) = E_Discriminant
2596                            then
2597                               null;
2598
2599                            elsif Box_Present (Assoc) then
2600                               null;
2601
2602                            else
2603                               if not Analyzed (Expression (Assoc)) then
2604                                  Comp_Expr :=
2605                                    New_Copy_Tree (Expression (Assoc));
2606                                  Set_Parent (Comp_Expr, Parent (N));
2607                                  Preanalyze_Without_Errors (Comp_Expr);
2608                               else
2609                                  Comp_Expr := Expression (Assoc);
2610                               end if;
2611
2612                               Collect_Identifiers (Comp_Expr);
2613                            end if;
2614
2615                            Next (Choice);
2616                         end loop;
2617                      end if;
2618
2619                      Next (Assoc);
2620                   end loop;
2621                end if;
2622             end;
2623
2624          when others =>
2625             return;
2626       end case;
2627
2628       --  No further action needed if we already reported an error
2629
2630       if Present (Error_Node) then
2631          return;
2632       end if;
2633
2634       --  Check violation of RM 6.20/3 in aggregates
2635
2636       if Present (Aggr_Error_Node)
2637         and then Writable_Actuals_List /= No_Elist
2638       then
2639          Error_Msg_N
2640            ("value may be affected by call in other component because they "
2641             & "are evaluated in unspecified order",
2642             Node (First_Elmt (Writable_Actuals_List)));
2643          return;
2644       end if;
2645
2646       --  Check if some writable argument of a function is referenced
2647
2648       if Writable_Actuals_List /= No_Elist
2649         and then Identifiers_List /= No_Elist
2650       then
2651          declare
2652             Elmt_1 : Elmt_Id;
2653             Elmt_2 : Elmt_Id;
2654
2655          begin
2656             Elmt_1 := First_Elmt (Writable_Actuals_List);
2657             while Present (Elmt_1) loop
2658                Elmt_2 := First_Elmt (Identifiers_List);
2659                while Present (Elmt_2) loop
2660                   if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
2661                      case Nkind (Parent (Node (Elmt_2))) is
2662                         when N_Aggregate             |
2663                              N_Component_Association |
2664                              N_Component_Declaration =>
2665                            Error_Msg_N
2666                              ("value may be affected by call in other "
2667                               & "component because they are evaluated "
2668                               & "in unspecified order",
2669                               Node (Elmt_2));
2670
2671                         when N_In | N_Not_In =>
2672                            Error_Msg_N
2673                              ("value may be affected by call in other "
2674                               & "alternative because they are evaluated "
2675                               & "in unspecified order",
2676                               Node (Elmt_2));
2677
2678                         when others =>
2679                            Error_Msg_N
2680                              ("value of actual may be affected by call in "
2681                               & "other actual because they are evaluated "
2682                               & "in unspecified order",
2683                            Node (Elmt_2));
2684                      end case;
2685                   end if;
2686
2687                   Next_Elmt (Elmt_2);
2688                end loop;
2689
2690                Next_Elmt (Elmt_1);
2691             end loop;
2692          end;
2693       end if;
2694    end Check_Function_Writable_Actuals;
2695
2696    --------------------------------
2697    -- Check_Implicit_Dereference --
2698    --------------------------------
2699
2700    procedure Check_Implicit_Dereference (N : Node_Id;  Typ : Entity_Id) is
2701       Disc  : Entity_Id;
2702       Desig : Entity_Id;
2703       Nam   : Node_Id;
2704
2705    begin
2706       if Nkind (N) = N_Indexed_Component
2707         and then Present (Generalized_Indexing (N))
2708       then
2709          Nam := Generalized_Indexing (N);
2710       else
2711          Nam := N;
2712       end if;
2713
2714       if Ada_Version < Ada_2012
2715         or else not Has_Implicit_Dereference (Base_Type (Typ))
2716       then
2717          return;
2718
2719       elsif not Comes_From_Source (N)
2720         and then Nkind (N) /= N_Indexed_Component
2721       then
2722          return;
2723
2724       elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then
2725          null;
2726
2727       else
2728          Disc := First_Discriminant (Typ);
2729          while Present (Disc) loop
2730             if Has_Implicit_Dereference (Disc) then
2731                Desig := Designated_Type (Etype (Disc));
2732                Add_One_Interp (Nam, Disc, Desig);
2733
2734                --  If the node is a generalized indexing, add interpretation
2735                --  to that node as well, for subsequent resolution.
2736
2737                if Nkind (N) = N_Indexed_Component then
2738                   Add_One_Interp (N, Disc, Desig);
2739                end if;
2740
2741                --  If the operation comes from a generic unit and the context
2742                --  is a selected component, the selector name may be global
2743                --  and set in the instance already. Remove the entity to
2744                --  force resolution of the selected component, and the
2745                --  generation of an explicit dereference if needed.
2746
2747                if In_Instance
2748                  and then Nkind (Parent (Nam)) = N_Selected_Component
2749                then
2750                   Set_Entity (Selector_Name (Parent (Nam)), Empty);
2751                end if;
2752
2753                exit;
2754             end if;
2755
2756             Next_Discriminant (Disc);
2757          end loop;
2758       end if;
2759    end Check_Implicit_Dereference;
2760
2761    ----------------------------------
2762    -- Check_Internal_Protected_Use --
2763    ----------------------------------
2764
2765    procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id) is
2766       S    : Entity_Id;
2767       Prot : Entity_Id;
2768
2769    begin
2770       S := Current_Scope;
2771       while Present (S) loop
2772          if S = Standard_Standard then
2773             return;
2774
2775          elsif Ekind (S) = E_Function
2776            and then Ekind (Scope (S)) = E_Protected_Type
2777          then
2778             Prot := Scope (S);
2779             exit;
2780          end if;
2781
2782          S := Scope (S);
2783       end loop;
2784
2785       if Scope (Nam) = Prot and then Ekind (Nam) /= E_Function then
2786
2787          --  An indirect function call (e.g. a callback within a protected
2788          --  function body) is not statically illegal. If the access type is
2789          --  anonymous and is the type of an access parameter, the scope of Nam
2790          --  will be the protected type, but it is not a protected operation.
2791
2792          if Ekind (Nam) = E_Subprogram_Type
2793            and then
2794              Nkind (Associated_Node_For_Itype (Nam)) = N_Function_Specification
2795          then
2796             null;
2797
2798          elsif Nkind (N) = N_Subprogram_Renaming_Declaration then
2799             Error_Msg_N
2800               ("within protected function cannot use protected "
2801                & "procedure in renaming or as generic actual", N);
2802
2803          elsif Nkind (N) = N_Attribute_Reference then
2804             Error_Msg_N
2805               ("within protected function cannot take access of "
2806                & " protected procedure", N);
2807
2808          else
2809             Error_Msg_N
2810               ("within protected function, protected object is constant", N);
2811             Error_Msg_N
2812               ("\cannot call operation that may modify it", N);
2813          end if;
2814       end if;
2815    end Check_Internal_Protected_Use;
2816
2817    ---------------------------------------
2818    -- Check_Later_Vs_Basic_Declarations --
2819    ---------------------------------------
2820
2821    procedure Check_Later_Vs_Basic_Declarations
2822      (Decls          : List_Id;
2823       During_Parsing : Boolean)
2824    is
2825       Body_Sloc : Source_Ptr;
2826       Decl      : Node_Id;
2827
2828       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean;
2829       --  Return whether Decl is considered as a declarative item.
2830       --  When During_Parsing is True, the semantics of Ada 83 is followed.
2831       --  When During_Parsing is False, the semantics of SPARK is followed.
2832
2833       -------------------------------
2834       -- Is_Later_Declarative_Item --
2835       -------------------------------
2836
2837       function Is_Later_Declarative_Item (Decl : Node_Id) return Boolean is
2838       begin
2839          if Nkind (Decl) in N_Later_Decl_Item then
2840             return True;
2841
2842          elsif Nkind (Decl) = N_Pragma then
2843             return True;
2844
2845          elsif During_Parsing then
2846             return False;
2847
2848          --  In SPARK, a package declaration is not considered as a later
2849          --  declarative item.
2850
2851          elsif Nkind (Decl) = N_Package_Declaration then
2852             return False;
2853
2854          --  In SPARK, a renaming is considered as a later declarative item
2855
2856          elsif Nkind (Decl) in N_Renaming_Declaration then
2857             return True;
2858
2859          else
2860             return False;
2861          end if;
2862       end Is_Later_Declarative_Item;
2863
2864    --  Start of processing for Check_Later_Vs_Basic_Declarations
2865
2866    begin
2867       Decl := First (Decls);
2868
2869       --  Loop through sequence of basic declarative items
2870
2871       Outer : while Present (Decl) loop
2872          if not Nkind_In (Decl, N_Subprogram_Body, N_Package_Body, N_Task_Body)
2873            and then Nkind (Decl) not in N_Body_Stub
2874          then
2875             Next (Decl);
2876
2877             --  Once a body is encountered, we only allow later declarative
2878             --  items. The inner loop checks the rest of the list.
2879
2880          else
2881             Body_Sloc := Sloc (Decl);
2882
2883             Inner : while Present (Decl) loop
2884                if not Is_Later_Declarative_Item (Decl) then
2885                   if During_Parsing then
2886                      if Ada_Version = Ada_83 then
2887                         Error_Msg_Sloc := Body_Sloc;
2888                         Error_Msg_N
2889                           ("(Ada 83) decl cannot appear after body#", Decl);
2890                      end if;
2891                   else
2892                      Error_Msg_Sloc := Body_Sloc;
2893                      Check_SPARK_05_Restriction
2894                        ("decl cannot appear after body#", Decl);
2895                   end if;
2896                end if;
2897
2898                Next (Decl);
2899             end loop Inner;
2900          end if;
2901       end loop Outer;
2902    end Check_Later_Vs_Basic_Declarations;
2903
2904    ---------------------------
2905    -- Check_No_Hidden_State --
2906    ---------------------------
2907
2908    procedure Check_No_Hidden_State (Id : Entity_Id) is
2909       function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean;
2910       --  Determine whether the entity of a package denoted by Pkg has a null
2911       --  abstract state.
2912
2913       -----------------------------
2914       -- Has_Null_Abstract_State --
2915       -----------------------------
2916
2917       function Has_Null_Abstract_State (Pkg : Entity_Id) return Boolean is
2918          States : constant Elist_Id := Abstract_States (Pkg);
2919
2920       begin
2921          --  Check first available state of related package. A null abstract
2922          --  state always appears as the sole element of the state list.
2923
2924          return
2925            Present (States)
2926              and then Is_Null_State (Node (First_Elmt (States)));
2927       end Has_Null_Abstract_State;
2928
2929       --  Local variables
2930
2931       Context     : Entity_Id := Empty;
2932       Not_Visible : Boolean   := False;
2933       Scop        : Entity_Id;
2934
2935    --  Start of processing for Check_No_Hidden_State
2936
2937    begin
2938       pragma Assert (Ekind_In (Id, E_Abstract_State, E_Variable));
2939
2940       --  Find the proper context where the object or state appears
2941
2942       Scop := Scope (Id);
2943       while Present (Scop) loop
2944          Context := Scop;
2945
2946          --  Keep track of the context's visibility
2947
2948          Not_Visible := Not_Visible or else In_Private_Part (Context);
2949
2950          --  Prevent the search from going too far
2951
2952          if Context = Standard_Standard then
2953             return;
2954
2955          --  Objects and states that appear immediately within a subprogram or
2956          --  inside a construct nested within a subprogram do not introduce a
2957          --  hidden state. They behave as local variable declarations.
2958
2959          elsif Is_Subprogram (Context) then
2960             return;
2961
2962          --  When examining a package body, use the entity of the spec as it
2963          --  carries the abstract state declarations.
2964
2965          elsif Ekind (Context) = E_Package_Body then
2966             Context := Spec_Entity (Context);
2967          end if;
2968
2969          --  Stop the traversal when a package subject to a null abstract state
2970          --  has been found.
2971
2972          if Ekind_In (Context, E_Generic_Package, E_Package)
2973            and then Has_Null_Abstract_State (Context)
2974          then
2975             exit;
2976          end if;
2977
2978          Scop := Scope (Scop);
2979       end loop;
2980
2981       --  At this point we know that there is at least one package with a null
2982       --  abstract state in visibility. Emit an error message unconditionally
2983       --  if the entity being processed is a state because the placement of the
2984       --  related package is irrelevant. This is not the case for objects as
2985       --  the intermediate context matters.
2986
2987       if Present (Context)
2988         and then (Ekind (Id) = E_Abstract_State or else Not_Visible)
2989       then
2990          Error_Msg_N ("cannot introduce hidden state &", Id);
2991          Error_Msg_NE ("\package & has null abstract state", Id, Context);
2992       end if;
2993    end Check_No_Hidden_State;
2994
2995    ----------------------------------------
2996    -- Check_Nonvolatile_Function_Profile --
2997    ----------------------------------------
2998
2999    procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id) is
3000       Formal : Entity_Id;
3001
3002    begin
3003       --  Inspect all formal parameters
3004
3005       Formal := First_Formal (Func_Id);
3006       while Present (Formal) loop
3007          if Is_Effectively_Volatile (Etype (Formal)) then
3008             Error_Msg_NE
3009               ("nonvolatile function & cannot have a volatile parameter",
3010                Formal, Func_Id);
3011          end if;
3012
3013          Next_Formal (Formal);
3014       end loop;
3015
3016       --  Inspect the return type
3017
3018       if Is_Effectively_Volatile (Etype (Func_Id)) then
3019          Error_Msg_N
3020            ("nonvolatile function & cannot have a volatile return type",
3021             Func_Id);
3022       end if;
3023    end Check_Nonvolatile_Function_Profile;
3024
3025    ------------------------------------------
3026    -- Check_Potentially_Blocking_Operation --
3027    ------------------------------------------
3028
3029    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
3030       S : Entity_Id;
3031
3032    begin
3033       --  N is one of the potentially blocking operations listed in 9.5.1(8).
3034       --  When pragma Detect_Blocking is active, the run time will raise
3035       --  Program_Error. Here we only issue a warning, since we generally
3036       --  support the use of potentially blocking operations in the absence
3037       --  of the pragma.
3038
3039       --  Indirect blocking through a subprogram call cannot be diagnosed
3040       --  statically without interprocedural analysis, so we do not attempt
3041       --  to do it here.
3042
3043       S := Scope (Current_Scope);
3044       while Present (S) and then S /= Standard_Standard loop
3045          if Is_Protected_Type (S) then
3046             Error_Msg_N
3047               ("potentially blocking operation in protected operation??", N);
3048             return;
3049          end if;
3050
3051          S := Scope (S);
3052       end loop;
3053    end Check_Potentially_Blocking_Operation;
3054
3055    ---------------------------------
3056    -- Check_Result_And_Post_State --
3057    ---------------------------------
3058
3059    procedure Check_Result_And_Post_State (Subp_Id : Entity_Id) is
3060       procedure Check_Result_And_Post_State_In_Pragma
3061         (Prag        : Node_Id;
3062          Result_Seen : in out Boolean);
3063       --  Determine whether pragma Prag mentions attribute 'Result and whether
3064       --  the pragma contains an expression that evaluates differently in pre-
3065       --  and post-state. Prag is a [refined] postcondition or a contract-cases
3066       --  pragma. Result_Seen is set when the pragma mentions attribute 'Result
3067
3068       function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean;
3069       --  Determine whether subprogram Subp_Id contains at least one IN OUT
3070       --  formal parameter.
3071
3072       -------------------------------------------
3073       -- Check_Result_And_Post_State_In_Pragma --
3074       -------------------------------------------
3075
3076       procedure Check_Result_And_Post_State_In_Pragma
3077         (Prag        : Node_Id;
3078          Result_Seen : in out Boolean)
3079       is
3080          procedure Check_Expression (Expr : Node_Id);
3081          --  Perform the 'Result and post-state checks on a given expression
3082
3083          function Is_Function_Result (N : Node_Id) return Traverse_Result;
3084          --  Attempt to find attribute 'Result in a subtree denoted by N
3085
3086          function Is_Trivial_Boolean (N : Node_Id) return Boolean;
3087          --  Determine whether source node N denotes "True" or "False"
3088
3089          function Mentions_Post_State (N : Node_Id) return Boolean;
3090          --  Determine whether a subtree denoted by N mentions any construct
3091          --  that denotes a post-state.
3092
3093          procedure Check_Function_Result is
3094            new Traverse_Proc (Is_Function_Result);
3095
3096          ----------------------
3097          -- Check_Expression --
3098          ----------------------
3099
3100          procedure Check_Expression (Expr : Node_Id) is
3101          begin
3102             if not Is_Trivial_Boolean (Expr) then
3103                Check_Function_Result (Expr);
3104
3105                if not Mentions_Post_State (Expr) then
3106                   if Pragma_Name (Prag) = Name_Contract_Cases then
3107                      Error_Msg_NE
3108                        ("contract case does not check the outcome of calling "
3109                         & "&?T?", Expr, Subp_Id);
3110
3111                   elsif Pragma_Name (Prag) = Name_Refined_Post then
3112                      Error_Msg_NE
3113                        ("refined postcondition does not check the outcome of "
3114                         & "calling &?T?", Prag, Subp_Id);
3115
3116                   else
3117                      Error_Msg_NE
3118                        ("postcondition does not check the outcome of calling "
3119                         & "&?T?", Prag, Subp_Id);
3120                   end if;
3121                end if;
3122             end if;
3123          end Check_Expression;
3124
3125          ------------------------
3126          -- Is_Function_Result --
3127          ------------------------
3128
3129          function Is_Function_Result (N : Node_Id) return Traverse_Result is
3130          begin
3131             if Is_Attribute_Result (N) then
3132                Result_Seen := True;
3133                return Abandon;
3134
3135             --  Continue the traversal
3136
3137             else
3138                return OK;
3139             end if;
3140          end Is_Function_Result;
3141
3142          ------------------------
3143          -- Is_Trivial_Boolean --
3144          ------------------------
3145
3146          function Is_Trivial_Boolean (N : Node_Id) return Boolean is
3147          begin
3148             return
3149               Comes_From_Source (N)
3150                 and then Is_Entity_Name (N)
3151                 and then (Entity (N) = Standard_True
3152                             or else
3153                           Entity (N) = Standard_False);
3154          end Is_Trivial_Boolean;
3155
3156          -------------------------
3157          -- Mentions_Post_State --
3158          -------------------------
3159
3160          function Mentions_Post_State (N : Node_Id) return Boolean is
3161             Post_State_Seen : Boolean := False;
3162
3163             function Is_Post_State (N : Node_Id) return Traverse_Result;
3164             --  Attempt to find a construct that denotes a post-state. If this
3165             --  is the case, set flag Post_State_Seen.
3166
3167             -------------------
3168             -- Is_Post_State --
3169             -------------------
3170
3171             function Is_Post_State (N : Node_Id) return Traverse_Result is
3172                Ent : Entity_Id;
3173
3174             begin
3175                if Nkind_In (N, N_Explicit_Dereference, N_Function_Call) then
3176                   Post_State_Seen := True;
3177                   return Abandon;
3178
3179                elsif Nkind_In (N, N_Expanded_Name, N_Identifier) then
3180                   Ent := Entity (N);
3181
3182                   --  The entity may be modifiable through an implicit
3183                   --  dereference.
3184
3185                   if No (Ent)
3186                     or else Ekind (Ent) in Assignable_Kind
3187                     or else (Is_Access_Type (Etype (Ent))
3188                               and then Nkind (Parent (N)) =
3189                                          N_Selected_Component)
3190                   then
3191                      Post_State_Seen := True;
3192                      return Abandon;
3193                   end if;
3194
3195                elsif Nkind (N) = N_Attribute_Reference then
3196                   if Attribute_Name (N) = Name_Old then
3197                      return Skip;
3198
3199                   elsif Attribute_Name (N) = Name_Result then
3200                      Post_State_Seen := True;
3201                      return Abandon;
3202                   end if;
3203                end if;
3204
3205                return OK;
3206             end Is_Post_State;
3207
3208             procedure Find_Post_State is new Traverse_Proc (Is_Post_State);
3209
3210          --  Start of processing for Mentions_Post_State
3211
3212          begin
3213             Find_Post_State (N);
3214
3215             return Post_State_Seen;
3216          end Mentions_Post_State;
3217
3218          --  Local variables
3219
3220          Expr  : constant Node_Id :=
3221                    Get_Pragma_Arg
3222                      (First (Pragma_Argument_Associations (Prag)));
3223          Nam   : constant Name_Id := Pragma_Name (Prag);
3224          CCase : Node_Id;
3225
3226       --  Start of processing for Check_Result_And_Post_State_In_Pragma
3227
3228       begin
3229          --  Examine all consequences
3230
3231          if Nam = Name_Contract_Cases then
3232             CCase := First (Component_Associations (Expr));
3233             while Present (CCase) loop
3234                Check_Expression (Expression (CCase));
3235
3236                Next (CCase);
3237             end loop;
3238
3239          --  Examine the expression of a postcondition
3240
3241          else pragma Assert (Nam_In (Nam, Name_Postcondition,
3242                                           Name_Refined_Post));
3243             Check_Expression (Expr);
3244          end if;
3245       end Check_Result_And_Post_State_In_Pragma;
3246
3247       --------------------------
3248       -- Has_In_Out_Parameter --
3249       --------------------------
3250
3251       function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is
3252          Formal : Entity_Id;
3253
3254       begin
3255          --  Traverse the formals looking for an IN OUT parameter
3256
3257          Formal := First_Formal (Subp_Id);
3258          while Present (Formal) loop
3259             if Ekind (Formal) = E_In_Out_Parameter then
3260                return True;
3261             end if;
3262
3263             Next_Formal (Formal);
3264          end loop;
3265
3266          return False;
3267       end Has_In_Out_Parameter;
3268
3269       --  Local variables
3270
3271       Items        : constant Node_Id := Contract (Subp_Id);
3272       Subp_Decl    : constant Node_Id := Unit_Declaration_Node (Subp_Id);
3273       Case_Prag    : Node_Id := Empty;
3274       Post_Prag    : Node_Id := Empty;
3275       Prag         : Node_Id;
3276       Seen_In_Case : Boolean := False;
3277       Seen_In_Post : Boolean := False;
3278       Spec_Id      : Entity_Id;
3279
3280    --  Start of processing for Check_Result_And_Post_State
3281
3282    begin
3283       --  The lack of attribute 'Result or a post-state is classified as a
3284       --  suspicious contract. Do not perform the check if the corresponding
3285       --  swich is not set.
3286
3287       if not Warn_On_Suspicious_Contract then
3288          return;
3289
3290       --  Nothing to do if there is no contract
3291
3292       elsif No (Items) then
3293          return;
3294       end if;
3295
3296       --  Retrieve the entity of the subprogram spec (if any)
3297
3298       if Nkind (Subp_Decl) = N_Subprogram_Body
3299         and then Present (Corresponding_Spec (Subp_Decl))
3300       then
3301          Spec_Id := Corresponding_Spec (Subp_Decl);
3302
3303       elsif Nkind (Subp_Decl) = N_Subprogram_Body_Stub
3304         and then Present (Corresponding_Spec_Of_Stub (Subp_Decl))
3305       then
3306          Spec_Id := Corresponding_Spec_Of_Stub (Subp_Decl);
3307
3308       else
3309          Spec_Id := Subp_Id;
3310       end if;
3311
3312       --  Examine all postconditions for attribute 'Result and a post-state
3313
3314       Prag := Pre_Post_Conditions (Items);
3315       while Present (Prag) loop
3316          if Nam_In (Pragma_Name (Prag), Name_Postcondition,
3317                                         Name_Refined_Post)
3318            and then not Error_Posted (Prag)
3319          then
3320             Post_Prag := Prag;
3321             Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Post);
3322          end if;
3323
3324          Prag := Next_Pragma (Prag);
3325       end loop;
3326
3327       --  Examine the contract cases of the subprogram for attribute 'Result
3328       --  and a post-state.
3329
3330       Prag := Contract_Test_Cases (Items);
3331       while Present (Prag) loop
3332          if Pragma_Name (Prag) = Name_Contract_Cases
3333            and then not Error_Posted (Prag)
3334          then
3335             Case_Prag := Prag;
3336             Check_Result_And_Post_State_In_Pragma (Prag, Seen_In_Case);
3337          end if;
3338
3339          Prag := Next_Pragma (Prag);
3340       end loop;
3341
3342       --  Do not emit any errors if the subprogram is not a function
3343
3344       if not Ekind_In (Spec_Id, E_Function, E_Generic_Function) then
3345          null;
3346
3347       --  Regardless of whether the function has postconditions or contract
3348       --  cases, or whether they mention attribute 'Result, an IN OUT formal
3349       --  parameter is always treated as a result.
3350
3351       elsif Has_In_Out_Parameter (Spec_Id) then
3352          null;
3353
3354       --  The function has both a postcondition and contract cases and they do
3355       --  not mention attribute 'Result.
3356
3357       elsif Present (Case_Prag)
3358         and then not Seen_In_Case
3359         and then Present (Post_Prag)
3360         and then not Seen_In_Post
3361       then
3362          Error_Msg_N
3363            ("neither postcondition nor contract cases mention function "
3364             & "result?T?", Post_Prag);
3365
3366       --  The function has contract cases only and they do not mention
3367       --  attribute 'Result.
3368
3369       elsif Present (Case_Prag) and then not Seen_In_Case then
3370          Error_Msg_N ("contract cases do not mention result?T?", Case_Prag);
3371
3372       --  The function has postconditions only and they do not mention
3373       --  attribute 'Result.
3374
3375       elsif Present (Post_Prag) and then not Seen_In_Post then
3376          Error_Msg_N
3377            ("postcondition does not mention function result?T?", Post_Prag);
3378       end if;
3379    end Check_Result_And_Post_State;
3380
3381    ------------------------------
3382    -- Check_Unprotected_Access --
3383    ------------------------------
3384
3385    procedure Check_Unprotected_Access
3386      (Context : Node_Id;
3387       Expr    : Node_Id)
3388    is
3389       Cont_Encl_Typ : Entity_Id;
3390       Pref_Encl_Typ : Entity_Id;
3391
3392       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id;
3393       --  Check whether Obj is a private component of a protected object.
3394       --  Return the protected type where the component resides, Empty
3395       --  otherwise.
3396
3397       function Is_Public_Operation return Boolean;
3398       --  Verify that the enclosing operation is callable from outside the
3399       --  protected object, to minimize false positives.
3400
3401       ------------------------------
3402       -- Enclosing_Protected_Type --
3403       ------------------------------
3404
3405       function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is
3406       begin
3407          if Is_Entity_Name (Obj) then
3408             declare
3409                Ent : Entity_Id := Entity (Obj);
3410
3411             begin
3412                --  The object can be a renaming of a private component, use
3413                --  the original record component.
3414
3415                if Is_Prival (Ent) then
3416                   Ent := Prival_Link (Ent);
3417                end if;
3418
3419                if Is_Protected_Type (Scope (Ent)) then
3420                   return Scope (Ent);
3421                end if;
3422             end;
3423          end if;
3424
3425          --  For indexed and selected components, recursively check the prefix
3426
3427          if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then
3428             return Enclosing_Protected_Type (Prefix (Obj));
3429
3430          --  The object does not denote a protected component
3431
3432          else
3433             return Empty;
3434          end if;
3435       end Enclosing_Protected_Type;
3436
3437       -------------------------
3438       -- Is_Public_Operation --
3439       -------------------------
3440
3441       function Is_Public_Operation return Boolean is
3442          S : Entity_Id;
3443          E : Entity_Id;
3444
3445       begin
3446          S := Current_Scope;
3447          while Present (S) and then S /= Pref_Encl_Typ loop
3448             if Scope (S) = Pref_Encl_Typ then
3449                E := First_Entity (Pref_Encl_Typ);
3450                while Present (E)
3451                  and then E /= First_Private_Entity (Pref_Encl_Typ)
3452                loop
3453                   if E = S then
3454                      return True;
3455                   end if;
3456
3457                   Next_Entity (E);
3458                end loop;
3459             end if;
3460
3461             S := Scope (S);
3462          end loop;
3463
3464          return False;
3465       end Is_Public_Operation;
3466
3467    --  Start of processing for Check_Unprotected_Access
3468
3469    begin
3470       if Nkind (Expr) = N_Attribute_Reference
3471         and then Attribute_Name (Expr) = Name_Unchecked_Access
3472       then
3473          Cont_Encl_Typ := Enclosing_Protected_Type (Context);
3474          Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr));
3475
3476          --  Check whether we are trying to export a protected component to a
3477          --  context with an equal or lower access level.
3478
3479          if Present (Pref_Encl_Typ)
3480            and then No (Cont_Encl_Typ)
3481            and then Is_Public_Operation
3482            and then Scope_Depth (Pref_Encl_Typ) >=
3483                                        Object_Access_Level (Context)
3484          then
3485             Error_Msg_N
3486               ("??possible unprotected access to protected data", Expr);
3487          end if;
3488       end if;
3489    end Check_Unprotected_Access;
3490
3491    ------------------------------
3492    -- Check_Unused_Body_States --
3493    ------------------------------
3494
3495    procedure Check_Unused_Body_States (Body_Id : Entity_Id) is
3496       Legal_Constits : Boolean := True;
3497       --  This flag designates whether all constituents of pragma Refined_State
3498       --  are legal. The flag is used to suppress the generation of potentially
3499       --  misleading error messages due to a malformed pragma.
3500
3501       procedure Process_Refinement_Clause
3502         (Clause : Node_Id;
3503          States : Elist_Id);
3504       --  Inspect all constituents of refinement clause Clause and remove any
3505       --  matches from body state list States.
3506
3507       -------------------------------
3508       -- Process_Refinement_Clause --
3509       -------------------------------
3510
3511       procedure Process_Refinement_Clause
3512         (Clause : Node_Id;
3513          States : Elist_Id)
3514       is
3515          procedure Process_Constituent (Constit : Node_Id);
3516          --  Remove constituent Constit from body state list States
3517
3518          -------------------------
3519          -- Process_Constituent --
3520          -------------------------
3521
3522          procedure Process_Constituent (Constit : Node_Id) is
3523             Constit_Id : Entity_Id;
3524
3525          begin
3526             if Error_Posted (Constit) then
3527                Legal_Constits := False;
3528             end if;
3529
3530             --  Guard against illegal constituents. Only abstract states and
3531             --  objects can appear on the right hand side of a refinement.
3532
3533             if Is_Entity_Name (Constit) then
3534                Constit_Id := Entity_Of (Constit);
3535
3536                if Present (Constit_Id)
3537                  and then Ekind_In (Constit_Id, E_Abstract_State,
3538                                                 E_Constant,
3539                                                 E_Variable)
3540                then
3541                   Remove (States, Constit_Id);
3542                end if;
3543             end if;
3544          end Process_Constituent;
3545
3546          --  Local variables
3547
3548          Constit : Node_Id;
3549
3550       --  Start of processing for Process_Refinement_Clause
3551
3552       begin
3553          if Nkind (Clause) = N_Component_Association then
3554             Constit := Expression (Clause);
3555
3556             --  Multiple constituents appear as an aggregate
3557
3558             if Nkind (Constit) = N_Aggregate then
3559                Constit := First (Expressions (Constit));
3560                while Present (Constit) loop
3561                   Process_Constituent (Constit);
3562                   Next (Constit);
3563                end loop;
3564
3565             --  Various forms of a single constituent
3566
3567             else
3568                Process_Constituent (Constit);
3569             end if;
3570          end if;
3571       end Process_Refinement_Clause;
3572
3573       --  Local variables
3574
3575       Prag    : constant Node_Id   :=
3576                   Get_Pragma (Body_Id, Pragma_Refined_State);
3577       Spec_Id : constant Entity_Id := Spec_Entity (Body_Id);
3578       Clause  : Node_Id;
3579       States  : Elist_Id;
3580
3581    --  Start of processing for Check_Unused_Body_States
3582
3583    begin
3584       --  Inspect the clauses of pragma Refined_State and determine whether all
3585       --  visible states declared within the body of the package participate in
3586       --  the refinement.
3587
3588       if Present (Prag) then
3589          Clause := Expression (Get_Argument (Prag, Spec_Id));
3590          States := Collect_Body_States (Body_Id);
3591
3592          --  Multiple non-null state refinements appear as an aggregate
3593
3594          if Nkind (Clause) = N_Aggregate then
3595             Clause := First (Component_Associations (Clause));
3596             while Present (Clause) loop
3597                Process_Refinement_Clause (Clause, States);
3598                Next (Clause);
3599             end loop;
3600
3601          --  Various forms of a single state refinement
3602
3603          else
3604             Process_Refinement_Clause (Clause, States);
3605          end if;
3606
3607          --  Ensure that all abstract states and objects declared in the body
3608          --  state space of the related package are utilized as constituents.
3609
3610          if Legal_Constits then
3611             Report_Unused_Body_States (Body_Id, States);
3612          end if;
3613       end if;
3614    end Check_Unused_Body_States;
3615
3616    -------------------------
3617    -- Collect_Body_States --
3618    -------------------------
3619
3620    function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id is
3621       procedure Collect_Visible_States
3622         (Pack_Id : Entity_Id;
3623          States  : in out Elist_Id);
3624       --  Gather the entities of all abstract states and objects declared in
3625       --  the visible state space of package Pack_Id.
3626
3627       ----------------------------
3628       -- Collect_Visible_States --
3629       ----------------------------
3630
3631       procedure Collect_Visible_States
3632         (Pack_Id : Entity_Id;
3633          States  : in out Elist_Id)
3634       is
3635          Item_Id : Entity_Id;
3636
3637       begin
3638          --  Traverse the entity chain of the package and inspect all visible
3639          --  items.
3640
3641          Item_Id := First_Entity (Pack_Id);
3642          while Present (Item_Id) and then not In_Private_Part (Item_Id) loop
3643
3644             --  Do not consider internally generated items as those cannot be
3645             --  named and participate in refinement.
3646
3647             if not Comes_From_Source (Item_Id) then
3648                null;
3649
3650             elsif Ekind (Item_Id) = E_Abstract_State then
3651                Append_New_Elmt (Item_Id, States);
3652
3653             --  Do not consider objects that map generic formals to their
3654             --  actuals, as the formals cannot be named from the outside and
3655             --  participate in refinement.
3656
3657             elsif Ekind_In (Item_Id, E_Constant, E_Variable)
3658               and then No (Corresponding_Generic_Association
3659                              (Declaration_Node (Item_Id)))
3660             then
3661                Append_New_Elmt (Item_Id, States);
3662
3663             --  Recursively gather the visible states of a nested package
3664
3665             elsif Ekind (Item_Id) = E_Package then
3666                Collect_Visible_States (Item_Id, States);
3667             end if;
3668
3669             Next_Entity (Item_Id);
3670          end loop;
3671       end Collect_Visible_States;
3672
3673       --  Local variables
3674
3675       Body_Decl : constant Node_Id := Unit_Declaration_Node (Body_Id);
3676       Decl      : Node_Id;
3677       Item_Id   : Entity_Id;
3678       States    : Elist_Id := No_Elist;
3679
3680    --  Start of processing for Collect_Body_States
3681
3682    begin
3683       --  Inspect the declarations of the body looking for source objects,
3684       --  packages and package instantiations.
3685
3686       Decl := First (Declarations (Body_Decl));
3687       while Present (Decl) loop
3688
3689          --  Capture source objects as internally generated temporaries cannot
3690          --  be named and participate in refinement.
3691
3692          if Nkind (Decl) = N_Object_Declaration then
3693             Item_Id := Defining_Entity (Decl);
3694
3695             if Comes_From_Source (Item_Id) then
3696                Append_New_Elmt (Item_Id, States);
3697             end if;
3698
3699          --  Capture the visible abstract states and objects of a source
3700          --  package [instantiation].
3701
3702          elsif Nkind (Decl) = N_Package_Declaration then
3703             Item_Id := Defining_Entity (Decl);
3704
3705             if Comes_From_Source (Item_Id) then
3706                Collect_Visible_States (Item_Id, States);
3707             end if;
3708          end if;
3709
3710          Next (Decl);
3711       end loop;
3712
3713       return States;
3714    end Collect_Body_States;
3715
3716    ------------------------
3717    -- Collect_Interfaces --
3718    ------------------------
3719
3720    procedure Collect_Interfaces
3721      (T               : Entity_Id;
3722       Ifaces_List     : out Elist_Id;
3723       Exclude_Parents : Boolean := False;
3724       Use_Full_View   : Boolean := True)
3725    is
3726       procedure Collect (Typ : Entity_Id);
3727       --  Subsidiary subprogram used to traverse the whole list
3728       --  of directly and indirectly implemented interfaces
3729
3730       -------------
3731       -- Collect --
3732       -------------
3733
3734       procedure Collect (Typ : Entity_Id) is
3735          Ancestor   : Entity_Id;
3736          Full_T     : Entity_Id;
3737          Id         : Node_Id;
3738          Iface      : Entity_Id;
3739
3740       begin
3741          Full_T := Typ;
3742
3743          --  Handle private types and subtypes
3744
3745          if Use_Full_View
3746            and then Is_Private_Type (Typ)
3747            and then Present (Full_View (Typ))
3748          then
3749             Full_T := Full_View (Typ);
3750
3751             if Ekind (Full_T) = E_Record_Subtype then
3752                Full_T := Full_View (Etype (Typ));
3753             end if;
3754          end if;
3755
3756          --  Include the ancestor if we are generating the whole list of
3757          --  abstract interfaces.
3758
3759          if Etype (Full_T) /= Typ
3760
3761             --  Protect the frontend against wrong sources. For example:
3762
3763             --    package P is
3764             --      type A is tagged null record;
3765             --      type B is new A with private;
3766             --      type C is new A with private;
3767             --    private
3768             --      type B is new C with null record;
3769             --      type C is new B with null record;
3770             --    end P;
3771
3772            and then Etype (Full_T) /= T
3773          then
3774             Ancestor := Etype (Full_T);
3775             Collect (Ancestor);
3776
3777             if Is_Interface (Ancestor) and then not Exclude_Parents then
3778                Append_Unique_Elmt (Ancestor, Ifaces_List);
3779             end if;
3780          end if;
3781
3782          --  Traverse the graph of ancestor interfaces
3783
3784          if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
3785             Id := First (Abstract_Interface_List (Full_T));
3786             while Present (Id) loop
3787                Iface := Etype (Id);
3788
3789                --  Protect against wrong uses. For example:
3790                --    type I is interface;
3791                --    type O is tagged null record;
3792                --    type Wrong is new I and O with null record; -- ERROR
3793
3794                if Is_Interface (Iface) then
3795                   if Exclude_Parents
3796                     and then Etype (T) /= T
3797                     and then Interface_Present_In_Ancestor (Etype (T), Iface)
3798                   then
3799                      null;
3800                   else
3801                      Collect (Iface);
3802                      Append_Unique_Elmt (Iface, Ifaces_List);
3803                   end if;
3804                end if;
3805
3806                Next (Id);
3807             end loop;
3808          end if;
3809       end Collect;
3810
3811    --  Start of processing for Collect_Interfaces
3812
3813    begin
3814       pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
3815       Ifaces_List := New_Elmt_List;
3816       Collect (T);
3817    end Collect_Interfaces;
3818
3819    ----------------------------------
3820    -- Collect_Interface_Components --
3821    ----------------------------------
3822
3823    procedure Collect_Interface_Components
3824      (Tagged_Type     : Entity_Id;
3825       Components_List : out Elist_Id)
3826    is
3827       procedure Collect (Typ : Entity_Id);
3828       --  Subsidiary subprogram used to climb to the parents
3829
3830       -------------
3831       -- Collect --
3832       -------------
3833
3834       procedure Collect (Typ : Entity_Id) is
3835          Tag_Comp   : Entity_Id;
3836          Parent_Typ : Entity_Id;
3837
3838       begin
3839          --  Handle private types
3840
3841          if Present (Full_View (Etype (Typ))) then
3842             Parent_Typ := Full_View (Etype (Typ));
3843          else
3844             Parent_Typ := Etype (Typ);
3845          end if;
3846
3847          if Parent_Typ /= Typ
3848
3849             --  Protect the frontend against wrong sources. For example:
3850
3851             --    package P is
3852             --      type A is tagged null record;
3853             --      type B is new A with private;
3854             --      type C is new A with private;
3855             --    private
3856             --      type B is new C with null record;
3857             --      type C is new B with null record;
3858             --    end P;
3859
3860            and then Parent_Typ /= Tagged_Type
3861          then
3862             Collect (Parent_Typ);
3863          end if;
3864
3865          --  Collect the components containing tags of secondary dispatch
3866          --  tables.
3867
3868          Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ));
3869          while Present (Tag_Comp) loop
3870             pragma Assert (Present (Related_Type (Tag_Comp)));
3871             Append_Elmt (Tag_Comp, Components_List);
3872
3873             Tag_Comp := Next_Tag_Component (Tag_Comp);
3874          end loop;
3875       end Collect;
3876
3877    --  Start of processing for Collect_Interface_Components
3878
3879    begin
3880       pragma Assert (Ekind (Tagged_Type) = E_Record_Type
3881         and then Is_Tagged_Type (Tagged_Type));
3882
3883       Components_List := New_Elmt_List;
3884       Collect (Tagged_Type);
3885    end Collect_Interface_Components;
3886
3887    -----------------------------
3888    -- Collect_Interfaces_Info --
3889    -----------------------------
3890
3891    procedure Collect_Interfaces_Info
3892      (T               : Entity_Id;
3893       Ifaces_List     : out Elist_Id;
3894       Components_List : out Elist_Id;
3895       Tags_List       : out Elist_Id)
3896    is
3897       Comps_List : Elist_Id;
3898       Comp_Elmt  : Elmt_Id;
3899       Comp_Iface : Entity_Id;
3900       Iface_Elmt : Elmt_Id;
3901       Iface      : Entity_Id;
3902
3903       function Search_Tag (Iface : Entity_Id) return Entity_Id;
3904       --  Search for the secondary tag associated with the interface type
3905       --  Iface that is implemented by T.
3906
3907       ----------------
3908       -- Search_Tag --
3909       ----------------
3910
3911       function Search_Tag (Iface : Entity_Id) return Entity_Id is
3912          ADT : Elmt_Id;
3913       begin
3914          if not Is_CPP_Class (T) then
3915             ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T))));
3916          else
3917             ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T)));
3918          end if;
3919
3920          while Present (ADT)
3921            and then Is_Tag (Node (ADT))
3922            and then Related_Type (Node (ADT)) /= Iface
3923          loop
3924             --  Skip secondary dispatch table referencing thunks to user
3925             --  defined primitives covered by this interface.
3926
3927             pragma Assert (Has_Suffix (Node (ADT), 'P'));
3928             Next_Elmt (ADT);
3929
3930             --  Skip secondary dispatch tables of Ada types
3931
3932             if not Is_CPP_Class (T) then
3933
3934                --  Skip secondary dispatch table referencing thunks to
3935                --  predefined primitives.
3936
3937                pragma Assert (Has_Suffix (Node (ADT), 'Y'));
3938                Next_Elmt (ADT);
3939
3940                --  Skip secondary dispatch table referencing user-defined
3941                --  primitives covered by this interface.
3942
3943                pragma Assert (Has_Suffix (Node (ADT), 'D'));
3944                Next_Elmt (ADT);
3945
3946                --  Skip secondary dispatch table referencing predefined
3947                --  primitives.
3948
3949                pragma Assert (Has_Suffix (Node (ADT), 'Z'));
3950                Next_Elmt (ADT);
3951             end if;
3952          end loop;
3953
3954          pragma Assert (Is_Tag (Node (ADT)));
3955          return Node (ADT);
3956       end Search_Tag;
3957
3958    --  Start of processing for Collect_Interfaces_Info
3959
3960    begin
3961       Collect_Interfaces (T, Ifaces_List);
3962       Collect_Interface_Components (T, Comps_List);
3963
3964       --  Search for the record component and tag associated with each
3965       --  interface type of T.
3966
3967       Components_List := New_Elmt_List;
3968       Tags_List       := New_Elmt_List;
3969
3970       Iface_Elmt := First_Elmt (Ifaces_List);
3971       while Present (Iface_Elmt) loop
3972          Iface := Node (Iface_Elmt);
3973
3974          --  Associate the primary tag component and the primary dispatch table
3975          --  with all the interfaces that are parents of T
3976
3977          if Is_Ancestor (Iface, T, Use_Full_View => True) then
3978             Append_Elmt (First_Tag_Component (T), Components_List);
3979             Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
3980
3981          --  Otherwise search for the tag component and secondary dispatch
3982          --  table of Iface
3983
3984          else
3985             Comp_Elmt := First_Elmt (Comps_List);
3986             while Present (Comp_Elmt) loop
3987                Comp_Iface := Related_Type (Node (Comp_Elmt));
3988
3989                if Comp_Iface = Iface
3990                  or else Is_Ancestor (Iface, Comp_Iface, Use_Full_View => True)
3991                then
3992                   Append_Elmt (Node (Comp_Elmt), Components_List);
3993                   Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
3994                   exit;
3995                end if;
3996
3997                Next_Elmt (Comp_Elmt);
3998             end loop;
3999             pragma Assert (Present (Comp_Elmt));
4000          end if;
4001
4002          Next_Elmt (Iface_Elmt);
4003       end loop;
4004    end Collect_Interfaces_Info;
4005
4006    ---------------------
4007    -- Collect_Parents --
4008    ---------------------
4009
4010    procedure Collect_Parents
4011      (T             : Entity_Id;
4012       List          : out Elist_Id;
4013       Use_Full_View : Boolean := True)
4014    is
4015       Current_Typ : Entity_Id := T;
4016       Parent_Typ  : Entity_Id;
4017
4018    begin
4019       List := New_Elmt_List;
4020
4021       --  No action if the if the type has no parents
4022
4023       if T = Etype (T) then
4024          return;
4025       end if;
4026
4027       loop
4028          Parent_Typ := Etype (Current_Typ);
4029
4030          if Is_Private_Type (Parent_Typ)
4031            and then Present (Full_View (Parent_Typ))
4032            and then Use_Full_View
4033          then
4034             Parent_Typ := Full_View (Base_Type (Parent_Typ));
4035          end if;
4036
4037          Append_Elmt (Parent_Typ, List);
4038
4039          exit when Parent_Typ = Current_Typ;
4040          Current_Typ := Parent_Typ;
4041       end loop;
4042    end Collect_Parents;
4043
4044    ----------------------------------
4045    -- Collect_Primitive_Operations --
4046    ----------------------------------
4047
4048    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
4049       B_Type         : constant Entity_Id := Base_Type (T);
4050       B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
4051       B_Scope        : Entity_Id          := Scope (B_Type);
4052       Op_List        : Elist_Id;
4053       Formal         : Entity_Id;
4054       Is_Prim        : Boolean;
4055       Is_Type_In_Pkg : Boolean;
4056       Formal_Derived : Boolean := False;
4057       Id             : Entity_Id;
4058
4059       function Match (E : Entity_Id) return Boolean;
4060       --  True if E's base type is B_Type, or E is of an anonymous access type
4061       --  and the base type of its designated type is B_Type.
4062
4063       -----------
4064       -- Match --
4065       -----------
4066
4067       function Match (E : Entity_Id) return Boolean is
4068          Etyp : Entity_Id := Etype (E);
4069
4070       begin
4071          if Ekind (Etyp) = E_Anonymous_Access_Type then
4072             Etyp := Designated_Type (Etyp);
4073          end if;
4074
4075          --  In Ada 2012 a primitive operation may have a formal of an
4076          --  incomplete view of the parent type.
4077
4078          return Base_Type (Etyp) = B_Type
4079            or else
4080              (Ada_Version >= Ada_2012
4081                and then Ekind (Etyp) = E_Incomplete_Type
4082                and then Full_View (Etyp) = B_Type);
4083       end Match;
4084
4085    --  Start of processing for Collect_Primitive_Operations
4086
4087    begin
4088       --  For tagged types, the primitive operations are collected as they
4089       --  are declared, and held in an explicit list which is simply returned.
4090
4091       if Is_Tagged_Type (B_Type) then
4092          return Primitive_Operations (B_Type);
4093
4094       --  An untagged generic type that is a derived type inherits the
4095       --  primitive operations of its parent type. Other formal types only
4096       --  have predefined operators, which are not explicitly represented.
4097
4098       elsif Is_Generic_Type (B_Type) then
4099          if Nkind (B_Decl) = N_Formal_Type_Declaration
4100            and then Nkind (Formal_Type_Definition (B_Decl)) =
4101                                            N_Formal_Derived_Type_Definition
4102          then
4103             Formal_Derived := True;
4104          else
4105             return New_Elmt_List;
4106          end if;
4107       end if;
4108
4109       Op_List := New_Elmt_List;
4110
4111       if B_Scope = Standard_Standard then
4112          if B_Type = Standard_String then
4113             Append_Elmt (Standard_Op_Concat, Op_List);
4114
4115          elsif B_Type = Standard_Wide_String then
4116             Append_Elmt (Standard_Op_Concatw, Op_List);
4117
4118          else
4119             null;
4120          end if;
4121
4122       --  Locate the primitive subprograms of the type
4123
4124       else
4125          --  The primitive operations appear after the base type, except
4126          --  if the derivation happens within the private part of B_Scope
4127          --  and the type is a private type, in which case both the type
4128          --  and some primitive operations may appear before the base
4129          --  type, and the list of candidates starts after the type.
4130
4131          if In_Open_Scopes (B_Scope)
4132            and then Scope (T) = B_Scope
4133            and then In_Private_Part (B_Scope)
4134          then
4135             Id := Next_Entity (T);
4136
4137          --  In Ada 2012, If the type has an incomplete partial view, there
4138          --  may be primitive operations declared before the full view, so
4139          --  we need to start scanning from the incomplete view, which is
4140          --  earlier on the entity chain.
4141
4142          elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration
4143            and then Present (Incomplete_View (Parent (B_Type)))
4144          then
4145             Id := Defining_Entity (Incomplete_View (Parent (B_Type)));
4146
4147          else
4148             Id := Next_Entity (B_Type);
4149          end if;
4150
4151          --  Set flag if this is a type in a package spec
4152
4153          Is_Type_In_Pkg :=
4154            Is_Package_Or_Generic_Package (B_Scope)
4155              and then
4156                Nkind (Parent (Declaration_Node (First_Subtype (T)))) /=
4157                                                            N_Package_Body;
4158
4159          while Present (Id) loop
4160
4161             --  Test whether the result type or any of the parameter types of
4162             --  each subprogram following the type match that type when the
4163             --  type is declared in a package spec, is a derived type, or the
4164             --  subprogram is marked as primitive. (The Is_Primitive test is
4165             --  needed to find primitives of nonderived types in declarative
4166             --  parts that happen to override the predefined "=" operator.)
4167
4168             --  Note that generic formal subprograms are not considered to be
4169             --  primitive operations and thus are never inherited.
4170
4171             if Is_Overloadable (Id)
4172               and then (Is_Type_In_Pkg
4173                          or else Is_Derived_Type (B_Type)
4174                          or else Is_Primitive (Id))
4175               and then Nkind (Parent (Parent (Id)))
4176                          not in N_Formal_Subprogram_Declaration
4177             then
4178                Is_Prim := False;
4179
4180                if Match (Id) then
4181                   Is_Prim := True;
4182
4183                else
4184                   Formal := First_Formal (Id);
4185                   while Present (Formal) loop
4186                      if Match (Formal) then
4187                         Is_Prim := True;
4188                         exit;
4189                      end if;
4190
4191                      Next_Formal (Formal);
4192                   end loop;
4193                end if;
4194
4195                --  For a formal derived type, the only primitives are the ones
4196                --  inherited from the parent type. Operations appearing in the
4197                --  package declaration are not primitive for it.
4198
4199                if Is_Prim
4200                  and then (not Formal_Derived or else Present (Alias (Id)))
4201                then
4202                   --  In the special case of an equality operator aliased to
4203                   --  an overriding dispatching equality belonging to the same
4204                   --  type, we don't include it in the list of primitives.
4205                   --  This avoids inheriting multiple equality operators when
4206                   --  deriving from untagged private types whose full type is
4207                   --  tagged, which can otherwise cause ambiguities. Note that
4208                   --  this should only happen for this kind of untagged parent
4209                   --  type, since normally dispatching operations are inherited
4210                   --  using the type's Primitive_Operations list.
4211
4212                   if Chars (Id) = Name_Op_Eq
4213                     and then Is_Dispatching_Operation (Id)
4214                     and then Present (Alias (Id))
4215                     and then Present (Overridden_Operation (Alias (Id)))
4216                     and then Base_Type (Etype (First_Entity (Id))) =
4217                                Base_Type (Etype (First_Entity (Alias (Id))))
4218                   then
4219                      null;
4220
4221                   --  Include the subprogram in the list of primitives
4222
4223                   else
4224                      Append_Elmt (Id, Op_List);
4225                   end if;
4226                end if;
4227             end if;
4228
4229             Next_Entity (Id);
4230
4231             --  For a type declared in System, some of its operations may
4232             --  appear in the target-specific extension to System.
4233
4234             if No (Id)
4235               and then B_Scope = RTU_Entity (System)
4236               and then Present_System_Aux
4237             then
4238                B_Scope := System_Aux_Id;
4239                Id := First_Entity (System_Aux_Id);
4240             end if;
4241          end loop;
4242       end if;
4243
4244       return Op_List;
4245    end Collect_Primitive_Operations;
4246
4247    -----------------------------------
4248    -- Compile_Time_Constraint_Error --
4249    -----------------------------------
4250
4251    function Compile_Time_Constraint_Error
4252      (N    : Node_Id;
4253       Msg  : String;
4254       Ent  : Entity_Id  := Empty;
4255       Loc  : Source_Ptr := No_Location;
4256       Warn : Boolean    := False) return Node_Id
4257    is
4258       Msgc : String (1 .. Msg'Length + 3);
4259       --  Copy of message, with room for possible ?? or << and ! at end
4260
4261       Msgl : Natural;
4262       Wmsg : Boolean;
4263       Eloc : Source_Ptr;
4264
4265    --  Start of processing for Compile_Time_Constraint_Error
4266
4267    begin
4268       --  If this is a warning, convert it into an error if we are in code
4269       --  subject to SPARK_Mode being set ON.
4270
4271       Error_Msg_Warn := SPARK_Mode /= On;
4272
4273       --  A static constraint error in an instance body is not a fatal error.
4274       --  we choose to inhibit the message altogether, because there is no
4275       --  obvious node (for now) on which to post it. On the other hand the
4276       --  offending node must be replaced with a constraint_error in any case.
4277
4278       --  No messages are generated if we already posted an error on this node
4279
4280       if not Error_Posted (N) then
4281          if Loc /= No_Location then
4282             Eloc := Loc;
4283          else
4284             Eloc := Sloc (N);
4285          end if;
4286
4287          --  Copy message to Msgc, converting any ? in the message into
4288          --  < instead, so that we have an error in GNATprove mode.
4289
4290          Msgl := Msg'Length;
4291
4292          for J in 1 .. Msgl loop
4293             if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
4294                Msgc (J) := '<';
4295             else
4296                Msgc (J) := Msg (J);
4297             end if;
4298          end loop;
4299
4300          --  Message is a warning, even in Ada 95 case
4301
4302          if Msg (Msg'Last) = '?' or else Msg (Msg'Last) = '<' then
4303             Wmsg := True;
4304
4305          --  In Ada 83, all messages are warnings. In the private part and
4306          --  the body of an instance, constraint_checks are only warnings.
4307          --  We also make this a warning if the Warn parameter is set.
4308
4309          elsif Warn
4310            or else (Ada_Version = Ada_83 and then Comes_From_Source (N))
4311          then
4312             Msgl := Msgl + 1;
4313             Msgc (Msgl) := '<';
4314             Msgl := Msgl + 1;
4315             Msgc (Msgl) := '<';
4316             Wmsg := True;
4317
4318          elsif In_Instance_Not_Visible then
4319             Msgl := Msgl + 1;
4320             Msgc (Msgl) := '<';
4321             Msgl := Msgl + 1;
4322             Msgc (Msgl) := '<';
4323             Wmsg := True;
4324
4325          --  Otherwise we have a real error message (Ada 95 static case)
4326          --  and we make this an unconditional message. Note that in the
4327          --  warning case we do not make the message unconditional, it seems
4328          --  quite reasonable to delete messages like this (about exceptions
4329          --  that will be raised) in dead code.
4330
4331          else
4332             Wmsg := False;
4333             Msgl := Msgl + 1;
4334             Msgc (Msgl) := '!';
4335          end if;
4336
4337          --  One more test, skip the warning if the related expression is
4338          --  statically unevaluated, since we don't want to warn about what
4339          --  will happen when something is evaluated if it never will be
4340          --  evaluated.
4341
4342          if not Is_Statically_Unevaluated (N) then
4343             Error_Msg_Warn := SPARK_Mode /= On;
4344
4345             if Present (Ent) then
4346                Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
4347             else
4348                Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
4349             end if;
4350
4351             if Wmsg then
4352
4353                --  Check whether the context is an Init_Proc
4354
4355                if Inside_Init_Proc then
4356                   declare
4357                      Conc_Typ : constant Entity_Id :=
4358                                   Corresponding_Concurrent_Type
4359                                     (Entity (Parameter_Type (First
4360                                       (Parameter_Specifications
4361                                         (Parent (Current_Scope))))));
4362
4363                   begin
4364                      --  Don't complain if the corresponding concurrent type
4365                      --  doesn't come from source (i.e. a single task/protected
4366                      --  object).
4367
4368                      if Present (Conc_Typ)
4369                        and then not Comes_From_Source (Conc_Typ)
4370                      then
4371                         Error_Msg_NEL
4372                           ("\& [<<", N, Standard_Constraint_Error, Eloc);
4373
4374                      else
4375                         if GNATprove_Mode then
4376                            Error_Msg_NEL
4377                              ("\& would have been raised for objects of this "
4378                               & "type", N, Standard_Constraint_Error, Eloc);
4379                         else
4380                            Error_Msg_NEL
4381                              ("\& will be raised for objects of this type??",
4382                               N, Standard_Constraint_Error, Eloc);
4383                         end if;
4384                      end if;
4385                   end;
4386
4387                else
4388                   Error_Msg_NEL ("\& [<<", N, Standard_Constraint_Error, Eloc);
4389                end if;
4390
4391             else
4392                Error_Msg ("\static expression fails Constraint_Check", Eloc);
4393                Set_Error_Posted (N);
4394             end if;
4395          end if;
4396       end if;
4397
4398       return N;
4399    end Compile_Time_Constraint_Error;
4400
4401    -----------------------
4402    -- Conditional_Delay --
4403    -----------------------
4404
4405    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
4406    begin
4407       if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
4408          Set_Has_Delayed_Freeze (New_Ent);
4409       end if;
4410    end Conditional_Delay;
4411
4412    ----------------------------
4413    -- Contains_Refined_State --
4414    ----------------------------
4415
4416    function Contains_Refined_State (Prag : Node_Id) return Boolean is
4417       function Has_State_In_Dependency (List : Node_Id) return Boolean;
4418       --  Determine whether a dependency list mentions a state with a visible
4419       --  refinement.
4420
4421       function Has_State_In_Global (List : Node_Id) return Boolean;
4422       --  Determine whether a global list mentions a state with a visible
4423       --  refinement.
4424
4425       function Is_Refined_State (Item : Node_Id) return Boolean;
4426       --  Determine whether Item is a reference to an abstract state with a
4427       --  visible refinement.
4428
4429       -----------------------------
4430       -- Has_State_In_Dependency --
4431       -----------------------------
4432
4433       function Has_State_In_Dependency (List : Node_Id) return Boolean is
4434          Clause : Node_Id;
4435          Output : Node_Id;
4436
4437       begin
4438          --  A null dependency list does not mention any states
4439
4440          if Nkind (List) = N_Null then
4441             return False;
4442
4443          --  Dependency clauses appear as component associations of an
4444          --  aggregate.
4445
4446          elsif Nkind (List) = N_Aggregate
4447            and then Present (Component_Associations (List))
4448          then
4449             Clause := First (Component_Associations (List));
4450             while Present (Clause) loop
4451
4452                --  Inspect the outputs of a dependency clause
4453
4454                Output := First (Choices (Clause));
4455                while Present (Output) loop
4456                   if Is_Refined_State (Output) then
4457                      return True;
4458                   end if;
4459
4460                   Next (Output);
4461                end loop;
4462
4463                --  Inspect the outputs of a dependency clause
4464
4465                if Is_Refined_State (Expression (Clause)) then
4466                   return True;
4467                end if;
4468
4469                Next (Clause);
4470             end loop;
4471
4472             --  If we get here, then none of the dependency clauses mention a
4473             --  state with visible refinement.
4474
4475             return False;
4476
4477          --  An illegal pragma managed to sneak in
4478
4479          else
4480             raise Program_Error;
4481          end if;
4482       end Has_State_In_Dependency;
4483
4484       -------------------------
4485       -- Has_State_In_Global --
4486       -------------------------
4487
4488       function Has_State_In_Global (List : Node_Id) return Boolean is
4489          Item : Node_Id;
4490
4491       begin
4492          --  A null global list does not mention any states
4493
4494          if Nkind (List) = N_Null then
4495             return False;
4496
4497          --  Simple global list or moded global list declaration
4498
4499          elsif Nkind (List) = N_Aggregate then
4500
4501             --  The declaration of a simple global list appear as a collection
4502             --  of expressions.
4503
4504             if Present (Expressions (List)) then
4505                Item := First (Expressions (List));
4506                while Present (Item) loop
4507                   if Is_Refined_State (Item) then
4508                      return True;
4509                   end if;
4510
4511                   Next (Item);
4512                end loop;
4513
4514             --  The declaration of a moded global list appears as a collection
4515             --  of component associations where individual choices denote
4516             --  modes.
4517
4518             else
4519                Item := First (Component_Associations (List));
4520                while Present (Item) loop
4521                   if Has_State_In_Global (Expression (Item)) then
4522                      return True;
4523                   end if;
4524
4525                   Next (Item);
4526                end loop;
4527             end if;
4528
4529             --  If we get here, then the simple/moded global list did not
4530             --  mention any states with a visible refinement.
4531
4532             return False;
4533
4534          --  Single global item declaration
4535
4536          elsif Is_Entity_Name (List) then
4537             return Is_Refined_State (List);
4538
4539          --  An illegal pragma managed to sneak in
4540
4541          else
4542             raise Program_Error;
4543          end if;
4544       end Has_State_In_Global;
4545
4546       ----------------------
4547       -- Is_Refined_State --
4548       ----------------------
4549
4550       function Is_Refined_State (Item : Node_Id) return Boolean is
4551          Elmt    : Node_Id;
4552          Item_Id : Entity_Id;
4553
4554       begin
4555          if Nkind (Item) = N_Null then
4556             return False;
4557
4558          --  States cannot be subject to attribute 'Result. This case arises
4559          --  in dependency relations.
4560
4561          elsif Nkind (Item) = N_Attribute_Reference
4562            and then Attribute_Name (Item) = Name_Result
4563          then
4564             return False;
4565
4566          --  Multiple items appear as an aggregate. This case arises in
4567          --  dependency relations.
4568
4569          elsif Nkind (Item) = N_Aggregate
4570            and then Present (Expressions (Item))
4571          then
4572             Elmt := First (Expressions (Item));
4573             while Present (Elmt) loop
4574                if Is_Refined_State (Elmt) then
4575                   return True;
4576                end if;
4577
4578                Next (Elmt);
4579             end loop;
4580
4581             --  If we get here, then none of the inputs or outputs reference a
4582             --  state with visible refinement.
4583
4584             return False;
4585
4586          --  Single item
4587
4588          else
4589             Item_Id := Entity_Of (Item);
4590
4591             return
4592               Present (Item_Id)
4593                 and then Ekind (Item_Id) = E_Abstract_State
4594                 and then Has_Visible_Refinement (Item_Id);
4595          end if;
4596       end Is_Refined_State;
4597
4598       --  Local variables
4599
4600       Arg : constant Node_Id :=
4601               Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
4602       Nam : constant Name_Id := Pragma_Name (Prag);
4603
4604    --  Start of processing for Contains_Refined_State
4605
4606    begin
4607       if Nam = Name_Depends then
4608          return Has_State_In_Dependency (Arg);
4609
4610       else pragma Assert (Nam = Name_Global);
4611          return Has_State_In_Global (Arg);
4612       end if;
4613    end Contains_Refined_State;
4614
4615    -------------------------
4616    -- Copy_Component_List --
4617    -------------------------
4618
4619    function Copy_Component_List
4620      (R_Typ : Entity_Id;
4621       Loc   : Source_Ptr) return List_Id
4622    is
4623       Comp  : Node_Id;
4624       Comps : constant List_Id := New_List;
4625
4626    begin
4627       Comp := First_Component (Underlying_Type (R_Typ));
4628       while Present (Comp) loop
4629          if Comes_From_Source (Comp) then
4630             declare
4631                Comp_Decl : constant Node_Id := Declaration_Node (Comp);
4632             begin
4633                Append_To (Comps,
4634                  Make_Component_Declaration (Loc,
4635                    Defining_Identifier =>
4636                      Make_Defining_Identifier (Loc, Chars (Comp)),
4637                    Component_Definition =>
4638                      New_Copy_Tree
4639                        (Component_Definition (Comp_Decl), New_Sloc => Loc)));
4640             end;
4641          end if;
4642
4643          Next_Component (Comp);
4644       end loop;
4645
4646       return Comps;
4647    end Copy_Component_List;
4648
4649    -------------------------
4650    -- Copy_Parameter_List --
4651    -------------------------
4652
4653    function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is
4654       Loc    : constant Source_Ptr := Sloc (Subp_Id);
4655       Plist  : List_Id;
4656       Formal : Entity_Id;
4657
4658    begin
4659       if No (First_Formal (Subp_Id)) then
4660          return No_List;
4661       else
4662          Plist  := New_List;
4663          Formal := First_Formal (Subp_Id);
4664          while Present (Formal) loop
4665             Append_To (Plist,
4666               Make_Parameter_Specification (Loc,
4667                 Defining_Identifier =>
4668                   Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
4669                 In_Present          => In_Present (Parent (Formal)),
4670                 Out_Present         => Out_Present (Parent (Formal)),
4671                 Parameter_Type      =>
4672                   New_Occurrence_Of (Etype (Formal), Loc),
4673                 Expression          =>
4674                   New_Copy_Tree (Expression (Parent (Formal)))));
4675
4676             Next_Formal (Formal);
4677          end loop;
4678       end if;
4679
4680       return Plist;
4681    end Copy_Parameter_List;
4682
4683    --------------------------
4684    -- Copy_Subprogram_Spec --
4685    --------------------------
4686
4687    function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
4688       Def_Id      : Node_Id;
4689       Formal_Spec : Node_Id;
4690       Result      : Node_Id;
4691
4692    begin
4693       --  The structure of the original tree must be replicated without any
4694       --  alterations. Use New_Copy_Tree for this purpose.
4695
4696       Result := New_Copy_Tree (Spec);
4697
4698       --  Create a new entity for the defining unit name
4699
4700       Def_Id := Defining_Unit_Name (Result);
4701       Set_Defining_Unit_Name (Result,
4702         Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
4703
4704       --  Create new entities for the formal parameters
4705
4706       if Present (Parameter_Specifications (Result)) then
4707          Formal_Spec := First (Parameter_Specifications (Result));
4708          while Present (Formal_Spec) loop
4709             Def_Id := Defining_Identifier (Formal_Spec);
4710             Set_Defining_Identifier (Formal_Spec,
4711               Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
4712
4713             Next (Formal_Spec);
4714          end loop;
4715       end if;
4716
4717       return Result;
4718    end Copy_Subprogram_Spec;
4719
4720    --------------------------------
4721    -- Corresponding_Generic_Type --
4722    --------------------------------
4723
4724    function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id is
4725       Inst : Entity_Id;
4726       Gen  : Entity_Id;
4727       Typ  : Entity_Id;
4728
4729    begin
4730       if not Is_Generic_Actual_Type (T) then
4731          return Any_Type;
4732
4733       --  If the actual is the actual of an enclosing instance, resolution
4734       --  was correct in the generic.
4735
4736       elsif Nkind (Parent (T)) = N_Subtype_Declaration
4737         and then Is_Entity_Name (Subtype_Indication (Parent (T)))
4738         and then
4739           Is_Generic_Actual_Type (Entity (Subtype_Indication (Parent (T))))
4740       then
4741          return Any_Type;
4742
4743       else
4744          Inst := Scope (T);
4745
4746          if Is_Wrapper_Package (Inst) then
4747             Inst := Related_Instance (Inst);
4748          end if;
4749
4750          Gen  :=
4751            Generic_Parent
4752              (Specification (Unit_Declaration_Node (Inst)));
4753
4754          --  Generic actual has the same name as the corresponding formal
4755
4756          Typ := First_Entity (Gen);
4757          while Present (Typ) loop
4758             if Chars (Typ) = Chars (T) then
4759                return Typ;
4760             end if;
4761
4762             Next_Entity (Typ);
4763          end loop;
4764
4765          return Any_Type;
4766       end if;
4767    end Corresponding_Generic_Type;
4768
4769    --------------------
4770    -- Current_Entity --
4771    --------------------
4772
4773    --  The currently visible definition for a given identifier is the
4774    --  one most chained at the start of the visibility chain, i.e. the
4775    --  one that is referenced by the Node_Id value of the name of the
4776    --  given identifier.
4777
4778    function Current_Entity (N : Node_Id) return Entity_Id is
4779    begin
4780       return Get_Name_Entity_Id (Chars (N));
4781    end Current_Entity;
4782
4783    -----------------------------
4784    -- Current_Entity_In_Scope --
4785    -----------------------------
4786
4787    function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
4788       E  : Entity_Id;
4789       CS : constant Entity_Id := Current_Scope;
4790
4791       Transient_Case : constant Boolean := Scope_Is_Transient;
4792
4793    begin
4794       E := Get_Name_Entity_Id (Chars (N));
4795       while Present (E)
4796         and then Scope (E) /= CS
4797         and then (not Transient_Case or else Scope (E) /= Scope (CS))
4798       loop
4799          E := Homonym (E);
4800       end loop;
4801
4802       return E;
4803    end Current_Entity_In_Scope;
4804
4805    -------------------
4806    -- Current_Scope --
4807    -------------------
4808
4809    function Current_Scope return Entity_Id is
4810    begin
4811       if Scope_Stack.Last = -1 then
4812          return Standard_Standard;
4813       else
4814          declare
4815             C : constant Entity_Id :=
4816                   Scope_Stack.Table (Scope_Stack.Last).Entity;
4817          begin
4818             if Present (C) then
4819                return C;
4820             else
4821                return Standard_Standard;
4822             end if;
4823          end;
4824       end if;
4825    end Current_Scope;
4826
4827    ------------------------
4828    -- Current_Subprogram --
4829    ------------------------
4830
4831    function Current_Subprogram return Entity_Id is
4832       Scop : constant Entity_Id := Current_Scope;
4833    begin
4834       if Is_Subprogram_Or_Generic_Subprogram (Scop) then
4835          return Scop;
4836       else
4837          return Enclosing_Subprogram (Scop);
4838       end if;
4839    end Current_Subprogram;
4840
4841    ----------------------------------
4842    -- Deepest_Type_Access_Level --
4843    ----------------------------------
4844
4845    function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint is
4846    begin
4847       if Ekind (Typ) = E_Anonymous_Access_Type
4848         and then not Is_Local_Anonymous_Access (Typ)
4849         and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
4850       then
4851          --  Typ is the type of an Ada 2012 stand-alone object of an anonymous
4852          --  access type.
4853
4854          return
4855            Scope_Depth (Enclosing_Dynamic_Scope
4856                          (Defining_Identifier
4857                            (Associated_Node_For_Itype (Typ))));
4858
4859       --  For generic formal type, return Int'Last (infinite).
4860       --  See comment preceding Is_Generic_Type call in Type_Access_Level.
4861
4862       elsif Is_Generic_Type (Root_Type (Typ)) then
4863          return UI_From_Int (Int'Last);
4864
4865       else
4866          return Type_Access_Level (Typ);
4867       end if;
4868    end Deepest_Type_Access_Level;
4869
4870    ---------------------
4871    -- Defining_Entity --
4872    ---------------------
4873
4874    function Defining_Entity (N : Node_Id) return Entity_Id is
4875       K   : constant Node_Kind := Nkind (N);
4876       Err : Entity_Id := Empty;
4877
4878    begin
4879       case K is
4880          when
4881            N_Subprogram_Declaration                 |
4882            N_Abstract_Subprogram_Declaration        |
4883            N_Subprogram_Body                        |
4884            N_Package_Declaration                    |
4885            N_Subprogram_Renaming_Declaration        |
4886            N_Subprogram_Body_Stub                   |
4887            N_Generic_Subprogram_Declaration         |
4888            N_Generic_Package_Declaration            |
4889            N_Formal_Subprogram_Declaration          |
4890            N_Expression_Function
4891          =>
4892             return Defining_Entity (Specification (N));
4893
4894          when
4895            N_Component_Declaration                  |
4896            N_Defining_Program_Unit_Name             |
4897            N_Discriminant_Specification             |
4898            N_Entry_Body                             |
4899            N_Entry_Declaration                      |
4900            N_Entry_Index_Specification              |
4901            N_Exception_Declaration                  |
4902            N_Exception_Renaming_Declaration         |
4903            N_Formal_Object_Declaration              |
4904            N_Formal_Package_Declaration             |
4905            N_Formal_Type_Declaration                |
4906            N_Full_Type_Declaration                  |
4907            N_Implicit_Label_Declaration             |
4908            N_Incomplete_Type_Declaration            |
4909            N_Loop_Parameter_Specification           |
4910            N_Number_Declaration                     |
4911            N_Object_Declaration                     |
4912            N_Object_Renaming_Declaration            |
4913            N_Package_Body_Stub                      |
4914            N_Parameter_Specification                |
4915            N_Private_Extension_Declaration          |
4916            N_Private_Type_Declaration               |
4917            N_Protected_Body                         |
4918            N_Protected_Body_Stub                    |
4919            N_Protected_Type_Declaration             |
4920            N_Single_Protected_Declaration           |
4921            N_Single_Task_Declaration                |
4922            N_Subtype_Declaration                    |
4923            N_Task_Body                              |
4924            N_Task_Body_Stub                         |
4925            N_Task_Type_Declaration
4926          =>
4927             return Defining_Identifier (N);
4928
4929          when N_Subunit =>
4930             return Defining_Entity (Proper_Body (N));
4931
4932          when
4933            N_Function_Instantiation                 |
4934            N_Function_Specification                 |
4935            N_Generic_Function_Renaming_Declaration  |
4936            N_Generic_Package_Renaming_Declaration   |
4937            N_Generic_Procedure_Renaming_Declaration |
4938            N_Package_Body                           |
4939            N_Package_Instantiation                  |
4940            N_Package_Renaming_Declaration           |
4941            N_Package_Specification                  |
4942            N_Procedure_Instantiation                |
4943            N_Procedure_Specification
4944          =>
4945             declare
4946                Nam : constant Node_Id := Defining_Unit_Name (N);
4947
4948             begin
4949                if Nkind (Nam) in N_Entity then
4950                   return Nam;
4951
4952                --  For Error, make up a name and attach to declaration
4953                --  so we can continue semantic analysis
4954
4955                elsif Nam = Error then
4956                   Err := Make_Temporary (Sloc (N), 'T');
4957                   Set_Defining_Unit_Name (N, Err);
4958
4959                   return Err;
4960
4961                --  If not an entity, get defining identifier
4962
4963                else
4964                   return Defining_Identifier (Nam);
4965                end if;
4966             end;
4967
4968          when
4969            N_Block_Statement                        |
4970            N_Loop_Statement
4971          =>
4972             return Entity (Identifier (N));
4973
4974          when others =>
4975             raise Program_Error;
4976
4977       end case;
4978    end Defining_Entity;
4979
4980    --------------------------
4981    -- Denotes_Discriminant --
4982    --------------------------
4983
4984    function Denotes_Discriminant
4985      (N                : Node_Id;
4986       Check_Concurrent : Boolean := False) return Boolean
4987    is
4988       E : Entity_Id;
4989
4990    begin
4991       if not Is_Entity_Name (N) or else No (Entity (N)) then
4992          return False;
4993       else
4994          E := Entity (N);
4995       end if;
4996
4997       --  If we are checking for a protected type, the discriminant may have
4998       --  been rewritten as the corresponding discriminal of the original type
4999       --  or of the corresponding concurrent record, depending on whether we
5000       --  are in the spec or body of the protected type.
5001
5002       return Ekind (E) = E_Discriminant
5003         or else
5004           (Check_Concurrent
5005             and then Ekind (E) = E_In_Parameter
5006             and then Present (Discriminal_Link (E))
5007             and then
5008               (Is_Concurrent_Type (Scope (Discriminal_Link (E)))
5009                 or else
5010                   Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
5011
5012    end Denotes_Discriminant;
5013
5014    -------------------------
5015    -- Denotes_Same_Object --
5016    -------------------------
5017
5018    function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
5019       Obj1 : Node_Id := A1;
5020       Obj2 : Node_Id := A2;
5021
5022       function Has_Prefix (N : Node_Id) return Boolean;
5023       --  Return True if N has attribute Prefix
5024
5025       function Is_Renaming (N : Node_Id) return Boolean;
5026       --  Return true if N names a renaming entity
5027
5028       function Is_Valid_Renaming (N : Node_Id) return Boolean;
5029       --  For renamings, return False if the prefix of any dereference within
5030       --  the renamed object_name is a variable, or any expression within the
5031       --  renamed object_name contains references to variables or calls on
5032       --  nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
5033
5034       ----------------
5035       -- Has_Prefix --
5036       ----------------
5037
5038       function Has_Prefix (N : Node_Id) return Boolean is
5039       begin
5040          return
5041            Nkind_In (N,
5042              N_Attribute_Reference,
5043              N_Expanded_Name,
5044              N_Explicit_Dereference,
5045              N_Indexed_Component,
5046              N_Reference,
5047              N_Selected_Component,
5048              N_Slice);
5049       end Has_Prefix;
5050
5051       -----------------
5052       -- Is_Renaming --
5053       -----------------
5054
5055       function Is_Renaming (N : Node_Id) return Boolean is
5056       begin
5057          return Is_Entity_Name (N)
5058            and then Present (Renamed_Entity (Entity (N)));
5059       end Is_Renaming;
5060
5061       -----------------------
5062       -- Is_Valid_Renaming --
5063       -----------------------
5064
5065       function Is_Valid_Renaming (N : Node_Id) return Boolean is
5066
5067          function Check_Renaming (N : Node_Id) return Boolean;
5068          --  Recursive function used to traverse all the prefixes of N
5069
5070          function Check_Renaming (N : Node_Id) return Boolean is
5071          begin
5072             if Is_Renaming (N)
5073               and then not Check_Renaming (Renamed_Entity (Entity (N)))
5074             then
5075                return False;
5076             end if;
5077
5078             if Nkind (N) = N_Indexed_Component then
5079                declare
5080                   Indx : Node_Id;
5081
5082                begin
5083                   Indx := First (Expressions (N));
5084                   while Present (Indx) loop
5085                      if not Is_OK_Static_Expression (Indx) then
5086                         return False;
5087                      end if;
5088
5089                      Next_Index (Indx);
5090                   end loop;
5091                end;
5092             end if;
5093
5094             if Has_Prefix (N) then
5095                declare
5096                   P : constant Node_Id := Prefix (N);
5097
5098                begin
5099                   if Nkind (N) = N_Explicit_Dereference
5100                     and then Is_Variable (P)
5101                   then
5102                      return False;
5103
5104                   elsif Is_Entity_Name (P)
5105                     and then Ekind (Entity (P)) = E_Function
5106                   then
5107                      return False;
5108
5109                   elsif Nkind (P) = N_Function_Call then
5110                      return False;
5111                   end if;
5112
5113                   --  Recursion to continue traversing the prefix of the
5114                   --  renaming expression
5115
5116                   return Check_Renaming (P);
5117                end;
5118             end if;
5119
5120             return True;
5121          end Check_Renaming;
5122
5123       --  Start of processing for Is_Valid_Renaming
5124
5125       begin
5126          return Check_Renaming (N);
5127       end Is_Valid_Renaming;
5128
5129    --  Start of processing for Denotes_Same_Object
5130
5131    begin
5132       --  Both names statically denote the same stand-alone object or parameter
5133       --  (RM 6.4.1(6.5/3))
5134
5135       if Is_Entity_Name (Obj1)
5136         and then Is_Entity_Name (Obj2)
5137         and then Entity (Obj1) = Entity (Obj2)
5138       then
5139          return True;
5140       end if;
5141
5142       --  For renamings, the prefix of any dereference within the renamed
5143       --  object_name is not a variable, and any expression within the
5144       --  renamed object_name contains no references to variables nor
5145       --  calls on nonstatic functions (RM 6.4.1(6.10/3)).
5146
5147       if Is_Renaming (Obj1) then
5148          if Is_Valid_Renaming (Obj1) then
5149             Obj1 := Renamed_Entity (Entity (Obj1));
5150          else
5151             return False;
5152          end if;
5153       end if;
5154
5155       if Is_Renaming (Obj2) then
5156          if Is_Valid_Renaming (Obj2) then
5157             Obj2 := Renamed_Entity (Entity (Obj2));
5158          else
5159             return False;
5160          end if;
5161       end if;
5162
5163       --  No match if not same node kind (such cases are handled by
5164       --  Denotes_Same_Prefix)
5165
5166       if Nkind (Obj1) /= Nkind (Obj2) then
5167          return False;
5168
5169       --  After handling valid renamings, one of the two names statically
5170       --  denoted a renaming declaration whose renamed object_name is known
5171       --  to denote the same object as the other (RM 6.4.1(6.10/3))
5172
5173       elsif Is_Entity_Name (Obj1) then
5174          if Is_Entity_Name (Obj2) then
5175             return Entity (Obj1) = Entity (Obj2);
5176          else
5177             return False;
5178          end if;
5179
5180       --  Both names are selected_components, their prefixes are known to
5181       --  denote the same object, and their selector_names denote the same
5182       --  component (RM 6.4.1(6.6/3)).
5183
5184       elsif Nkind (Obj1) = N_Selected_Component then
5185          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
5186            and then
5187              Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
5188
5189       --  Both names are dereferences and the dereferenced names are known to
5190       --  denote the same object (RM 6.4.1(6.7/3))
5191
5192       elsif Nkind (Obj1) = N_Explicit_Dereference then
5193          return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
5194
5195       --  Both names are indexed_components, their prefixes are known to denote
5196       --  the same object, and each of the pairs of corresponding index values
5197       --  are either both static expressions with the same static value or both
5198       --  names that are known to denote the same object (RM 6.4.1(6.8/3))
5199
5200       elsif Nkind (Obj1) = N_Indexed_Component then
5201          if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
5202             return False;
5203          else
5204             declare
5205                Indx1 : Node_Id;
5206                Indx2 : Node_Id;
5207
5208             begin
5209                Indx1 := First (Expressions (Obj1));
5210                Indx2 := First (Expressions (Obj2));
5211                while Present (Indx1) loop
5212
5213                   --  Indexes must denote the same static value or same object
5214
5215                   if Is_OK_Static_Expression (Indx1) then
5216                      if not Is_OK_Static_Expression (Indx2) then
5217                         return False;
5218
5219                      elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
5220                         return False;
5221                      end if;
5222
5223                   elsif not Denotes_Same_Object (Indx1, Indx2) then
5224                      return False;
5225                   end if;
5226
5227                   Next (Indx1);
5228                   Next (Indx2);
5229                end loop;
5230
5231                return True;
5232             end;
5233          end if;
5234
5235       --  Both names are slices, their prefixes are known to denote the same
5236       --  object, and the two slices have statically matching index constraints
5237       --  (RM 6.4.1(6.9/3))
5238
5239       elsif Nkind (Obj1) = N_Slice
5240         and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
5241       then
5242          declare
5243             Lo1, Lo2, Hi1, Hi2 : Node_Id;
5244
5245          begin
5246             Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
5247             Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
5248
5249             --  Check whether bounds are statically identical. There is no
5250             --  attempt to detect partial overlap of slices.
5251
5252             return Denotes_Same_Object (Lo1, Lo2)
5253                      and then
5254                    Denotes_Same_Object (Hi1, Hi2);
5255          end;
5256
5257       --  In the recursion, literals appear as indexes
5258
5259       elsif Nkind (Obj1) = N_Integer_Literal
5260               and then
5261             Nkind (Obj2) = N_Integer_Literal
5262       then
5263          return Intval (Obj1) = Intval (Obj2);
5264
5265       else
5266          return False;
5267       end if;
5268    end Denotes_Same_Object;
5269
5270    -------------------------
5271    -- Denotes_Same_Prefix --
5272    -------------------------
5273
5274    function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean is
5275
5276    begin
5277       if Is_Entity_Name (A1) then
5278          if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
5279            and then not Is_Access_Type (Etype (A1))
5280          then
5281             return Denotes_Same_Object (A1, Prefix (A2))
5282               or else Denotes_Same_Prefix (A1, Prefix (A2));
5283          else
5284             return False;
5285          end if;
5286
5287       elsif Is_Entity_Name (A2) then
5288          return Denotes_Same_Prefix (A1 => A2, A2 => A1);
5289
5290       elsif Nkind_In (A1, N_Selected_Component, N_Indexed_Component, N_Slice)
5291               and then
5292             Nkind_In (A2, N_Selected_Component, N_Indexed_Component, N_Slice)
5293       then
5294          declare
5295             Root1, Root2   : Node_Id;
5296             Depth1, Depth2 : Int := 0;
5297
5298          begin
5299             Root1 := Prefix (A1);
5300             while not Is_Entity_Name (Root1) loop
5301                if not Nkind_In
5302                  (Root1, N_Selected_Component, N_Indexed_Component)
5303                then
5304                   return False;
5305                else
5306                   Root1 := Prefix (Root1);
5307                end if;
5308
5309                Depth1 := Depth1 + 1;
5310             end loop;
5311
5312             Root2 := Prefix (A2);
5313             while not Is_Entity_Name (Root2) loop
5314                if not Nkind_In (Root2, N_Selected_Component,
5315                                        N_Indexed_Component)
5316                then
5317                   return False;
5318                else
5319                   Root2 := Prefix (Root2);
5320                end if;
5321
5322                Depth2 := Depth2 + 1;
5323             end loop;
5324
5325             --  If both have the same depth and they do not denote the same
5326             --  object, they are disjoint and no warning is needed.
5327
5328             if Depth1 = Depth2 then
5329                return False;
5330
5331             elsif Depth1 > Depth2 then
5332                Root1 := Prefix (A1);
5333                for J in 1 .. Depth1 - Depth2 - 1 loop
5334                   Root1 := Prefix (Root1);
5335                end loop;
5336
5337                return Denotes_Same_Object (Root1, A2);
5338
5339             else
5340                Root2 := Prefix (A2);
5341                for J in 1 .. Depth2 - Depth1 - 1 loop
5342                   Root2 := Prefix (Root2);
5343                end loop;
5344
5345                return Denotes_Same_Object (A1, Root2);
5346             end if;
5347          end;
5348
5349       else
5350          return False;
5351       end if;
5352    end Denotes_Same_Prefix;
5353
5354    ----------------------
5355    -- Denotes_Variable --
5356    ----------------------
5357
5358    function Denotes_Variable (N : Node_Id) return Boolean is
5359    begin
5360       return Is_Variable (N) and then Paren_Count (N) = 0;
5361    end Denotes_Variable;
5362
5363    -----------------------------
5364    -- Depends_On_Discriminant --
5365    -----------------------------
5366
5367    function Depends_On_Discriminant (N : Node_Id) return Boolean is
5368       L : Node_Id;
5369       H : Node_Id;
5370
5371    begin
5372       Get_Index_Bounds (N, L, H);
5373       return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
5374    end Depends_On_Discriminant;
5375
5376    -------------------------
5377    -- Designate_Same_Unit --
5378    -------------------------
5379
5380    function Designate_Same_Unit
5381      (Name1 : Node_Id;
5382       Name2 : Node_Id) return Boolean
5383    is
5384       K1 : constant Node_Kind := Nkind (Name1);
5385       K2 : constant Node_Kind := Nkind (Name2);
5386
5387       function Prefix_Node (N : Node_Id) return Node_Id;
5388       --  Returns the parent unit name node of a defining program unit name
5389       --  or the prefix if N is a selected component or an expanded name.
5390
5391       function Select_Node (N : Node_Id) return Node_Id;
5392       --  Returns the defining identifier node of a defining program unit
5393       --  name or  the selector node if N is a selected component or an
5394       --  expanded name.
5395
5396       -----------------
5397       -- Prefix_Node --
5398       -----------------
5399
5400       function Prefix_Node (N : Node_Id) return Node_Id is
5401       begin
5402          if Nkind (N) = N_Defining_Program_Unit_Name then
5403             return Name (N);
5404          else
5405             return Prefix (N);
5406          end if;
5407       end Prefix_Node;
5408
5409       -----------------
5410       -- Select_Node --
5411       -----------------
5412
5413       function Select_Node (N : Node_Id) return Node_Id is
5414       begin
5415          if Nkind (N) = N_Defining_Program_Unit_Name then
5416             return Defining_Identifier (N);
5417          else
5418             return Selector_Name (N);
5419          end if;
5420       end Select_Node;
5421
5422    --  Start of processing for Designate_Same_Unit
5423
5424    begin
5425       if Nkind_In (K1, N_Identifier, N_Defining_Identifier)
5426            and then
5427          Nkind_In (K2, N_Identifier, N_Defining_Identifier)
5428       then
5429          return Chars (Name1) = Chars (Name2);
5430
5431       elsif Nkind_In (K1, N_Expanded_Name,
5432                           N_Selected_Component,
5433                           N_Defining_Program_Unit_Name)
5434               and then
5435             Nkind_In (K2, N_Expanded_Name,
5436                           N_Selected_Component,
5437                           N_Defining_Program_Unit_Name)
5438       then
5439          return
5440            (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
5441              and then
5442                Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
5443
5444       else
5445          return False;
5446       end if;
5447    end Designate_Same_Unit;
5448
5449    ------------------------------------------
5450    -- function Dynamic_Accessibility_Level --
5451    ------------------------------------------
5452
5453    function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
5454       E : Entity_Id;
5455       Loc : constant Source_Ptr := Sloc (Expr);
5456
5457       function Make_Level_Literal (Level : Uint) return Node_Id;
5458       --  Construct an integer literal representing an accessibility level
5459       --  with its type set to Natural.
5460
5461       ------------------------
5462       -- Make_Level_Literal --
5463       ------------------------
5464
5465       function Make_Level_Literal (Level : Uint) return Node_Id is
5466          Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
5467       begin
5468          Set_Etype (Result, Standard_Natural);
5469          return Result;
5470       end Make_Level_Literal;
5471
5472    --  Start of processing for Dynamic_Accessibility_Level
5473
5474    begin
5475       if Is_Entity_Name (Expr) then
5476          E := Entity (Expr);
5477
5478          if Present (Renamed_Object (E)) then
5479             return Dynamic_Accessibility_Level (Renamed_Object (E));
5480          end if;
5481
5482          if Is_Formal (E) or else Ekind_In (E, E_Variable, E_Constant) then
5483             if Present (Extra_Accessibility (E)) then
5484                return New_Occurrence_Of (Extra_Accessibility (E), Loc);
5485             end if;
5486          end if;
5487       end if;
5488
5489       --  Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
5490
5491       case Nkind (Expr) is
5492
5493          --  For access discriminant, the level of the enclosing object
5494
5495          when N_Selected_Component =>
5496             if Ekind (Entity (Selector_Name (Expr))) = E_Discriminant
5497               and then Ekind (Etype (Entity (Selector_Name (Expr)))) =
5498                                             E_Anonymous_Access_Type
5499             then
5500                return Make_Level_Literal (Object_Access_Level (Expr));
5501             end if;
5502
5503          when N_Attribute_Reference =>
5504             case Get_Attribute_Id (Attribute_Name (Expr)) is
5505
5506                --  For X'Access, the level of the prefix X
5507
5508                when Attribute_Access =>
5509                   return Make_Level_Literal
5510                            (Object_Access_Level (Prefix (Expr)));
5511
5512                --  Treat the unchecked attributes as library-level
5513
5514                when Attribute_Unchecked_Access    |
5515                     Attribute_Unrestricted_Access =>
5516                   return Make_Level_Literal (Scope_Depth (Standard_Standard));
5517
5518                --  No other access-valued attributes
5519
5520                when others =>
5521                   raise Program_Error;
5522             end case;
5523
5524          when N_Allocator =>
5525
5526             --  Unimplemented: depends on context. As an actual parameter where
5527             --  formal type is anonymous, use
5528             --    Scope_Depth (Current_Scope) + 1.
5529             --  For other cases, see 3.10.2(14/3) and following. ???
5530
5531             null;
5532
5533          when N_Type_Conversion =>
5534             if not Is_Local_Anonymous_Access (Etype (Expr)) then
5535
5536                --  Handle type conversions introduced for a rename of an
5537                --  Ada 2012 stand-alone object of an anonymous access type.
5538
5539                return Dynamic_Accessibility_Level (Expression (Expr));
5540             end if;
5541
5542          when others =>
5543             null;
5544       end case;
5545
5546       return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
5547    end Dynamic_Accessibility_Level;
5548
5549    -----------------------------------
5550    -- Effective_Extra_Accessibility --
5551    -----------------------------------
5552
5553    function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id is
5554    begin
5555       if Present (Renamed_Object (Id))
5556         and then Is_Entity_Name (Renamed_Object (Id))
5557       then
5558          return Effective_Extra_Accessibility (Entity (Renamed_Object (Id)));
5559       else
5560          return Extra_Accessibility (Id);
5561       end if;
5562    end Effective_Extra_Accessibility;
5563
5564    -----------------------------
5565    -- Effective_Reads_Enabled --
5566    -----------------------------
5567
5568    function Effective_Reads_Enabled (Id : Entity_Id) return Boolean is
5569    begin
5570       return Has_Enabled_Property (Id, Name_Effective_Reads);
5571    end Effective_Reads_Enabled;
5572
5573    ------------------------------
5574    -- Effective_Writes_Enabled --
5575    ------------------------------
5576
5577    function Effective_Writes_Enabled (Id : Entity_Id) return Boolean is
5578    begin
5579       return Has_Enabled_Property (Id, Name_Effective_Writes);
5580    end Effective_Writes_Enabled;
5581
5582    ------------------------------
5583    -- Enclosing_Comp_Unit_Node --
5584    ------------------------------
5585
5586    function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
5587       Current_Node : Node_Id;
5588
5589    begin
5590       Current_Node := N;
5591       while Present (Current_Node)
5592         and then Nkind (Current_Node) /= N_Compilation_Unit
5593       loop
5594          Current_Node := Parent (Current_Node);
5595       end loop;
5596
5597       if Nkind (Current_Node) /= N_Compilation_Unit then
5598          return Empty;
5599       else
5600          return Current_Node;
5601       end if;
5602    end Enclosing_Comp_Unit_Node;
5603
5604    --------------------------
5605    -- Enclosing_CPP_Parent --
5606    --------------------------
5607
5608    function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id is
5609       Parent_Typ : Entity_Id := Typ;
5610
5611    begin
5612       while not Is_CPP_Class (Parent_Typ)
5613          and then Etype (Parent_Typ) /= Parent_Typ
5614       loop
5615          Parent_Typ := Etype (Parent_Typ);
5616
5617          if Is_Private_Type (Parent_Typ) then
5618             Parent_Typ := Full_View (Base_Type (Parent_Typ));
5619          end if;
5620       end loop;
5621
5622       pragma Assert (Is_CPP_Class (Parent_Typ));
5623       return Parent_Typ;
5624    end Enclosing_CPP_Parent;
5625
5626    ---------------------------
5627    -- Enclosing_Declaration --
5628    ---------------------------
5629
5630    function Enclosing_Declaration (N : Node_Id) return Node_Id is
5631       Decl : Node_Id := N;
5632
5633    begin
5634       while Present (Decl)
5635         and then not (Nkind (Decl) in N_Declaration
5636                         or else
5637                       Nkind (Decl) in N_Later_Decl_Item)
5638       loop
5639          Decl := Parent (Decl);
5640       end loop;
5641
5642       return Decl;
5643    end Enclosing_Declaration;
5644
5645    ----------------------------
5646    -- Enclosing_Generic_Body --
5647    ----------------------------
5648
5649    function Enclosing_Generic_Body
5650      (N : Node_Id) return Node_Id
5651    is
5652       P    : Node_Id;
5653       Decl : Node_Id;
5654       Spec : Node_Id;
5655
5656    begin
5657       P := Parent (N);
5658       while Present (P) loop
5659          if Nkind (P) = N_Package_Body
5660            or else Nkind (P) = N_Subprogram_Body
5661          then
5662             Spec := Corresponding_Spec (P);
5663
5664             if Present (Spec) then
5665                Decl := Unit_Declaration_Node (Spec);
5666
5667                if Nkind (Decl) = N_Generic_Package_Declaration
5668                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
5669                then
5670                   return P;
5671                end if;
5672             end if;
5673          end if;
5674
5675          P := Parent (P);
5676       end loop;
5677
5678       return Empty;
5679    end Enclosing_Generic_Body;
5680
5681    ----------------------------
5682    -- Enclosing_Generic_Unit --
5683    ----------------------------
5684
5685    function Enclosing_Generic_Unit
5686      (N : Node_Id) return Node_Id
5687    is
5688       P    : Node_Id;
5689       Decl : Node_Id;
5690       Spec : Node_Id;
5691
5692    begin
5693       P := Parent (N);
5694       while Present (P) loop
5695          if Nkind (P) = N_Generic_Package_Declaration
5696            or else Nkind (P) = N_Generic_Subprogram_Declaration
5697          then
5698             return P;
5699
5700          elsif Nkind (P) = N_Package_Body
5701            or else Nkind (P) = N_Subprogram_Body
5702          then
5703             Spec := Corresponding_Spec (P);
5704
5705             if Present (Spec) then
5706                Decl := Unit_Declaration_Node (Spec);
5707
5708                if Nkind (Decl) = N_Generic_Package_Declaration
5709                  or else Nkind (Decl) = N_Generic_Subprogram_Declaration
5710                then
5711                   return Decl;
5712                end if;
5713             end if;
5714          end if;
5715
5716          P := Parent (P);
5717       end loop;
5718
5719       return Empty;
5720    end Enclosing_Generic_Unit;
5721
5722    -------------------------------
5723    -- Enclosing_Lib_Unit_Entity --
5724    -------------------------------
5725
5726    function Enclosing_Lib_Unit_Entity
5727       (E : Entity_Id := Current_Scope) return Entity_Id
5728    is
5729       Unit_Entity : Entity_Id;
5730
5731    begin
5732       --  Look for enclosing library unit entity by following scope links.
5733       --  Equivalent to, but faster than indexing through the scope stack.
5734
5735       Unit_Entity := E;
5736       while (Present (Scope (Unit_Entity))
5737         and then Scope (Unit_Entity) /= Standard_Standard)
5738         and not Is_Child_Unit (Unit_Entity)
5739       loop
5740          Unit_Entity := Scope (Unit_Entity);
5741       end loop;
5742
5743       return Unit_Entity;
5744    end Enclosing_Lib_Unit_Entity;
5745
5746    -----------------------------
5747    -- Enclosing_Lib_Unit_Node --
5748    -----------------------------
5749
5750    function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
5751       Encl_Unit : Node_Id;
5752
5753    begin
5754       Encl_Unit := Enclosing_Comp_Unit_Node (N);
5755       while Present (Encl_Unit)
5756         and then Nkind (Unit (Encl_Unit)) = N_Subunit
5757       loop
5758          Encl_Unit := Library_Unit (Encl_Unit);
5759       end loop;
5760
5761       return Encl_Unit;
5762    end Enclosing_Lib_Unit_Node;
5763
5764    -----------------------
5765    -- Enclosing_Package --
5766    -----------------------
5767
5768    function Enclosing_Package (E : Entity_Id) return Entity_Id is
5769       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5770
5771    begin
5772       if Dynamic_Scope = Standard_Standard then
5773          return Standard_Standard;
5774
5775       elsif Dynamic_Scope = Empty then
5776          return Empty;
5777
5778       elsif Ekind_In (Dynamic_Scope, E_Package, E_Package_Body,
5779                       E_Generic_Package)
5780       then
5781          return Dynamic_Scope;
5782
5783       else
5784          return Enclosing_Package (Dynamic_Scope);
5785       end if;
5786    end Enclosing_Package;
5787
5788    -------------------------------------
5789    -- Enclosing_Package_Or_Subprogram --
5790    -------------------------------------
5791
5792    function Enclosing_Package_Or_Subprogram (E : Entity_Id) return Entity_Id is
5793       S : Entity_Id;
5794
5795    begin
5796       S := Scope (E);
5797       while Present (S) loop
5798          if Is_Package_Or_Generic_Package (S)
5799            or else Ekind (S) = E_Package_Body
5800          then
5801             return S;
5802
5803          elsif Is_Subprogram_Or_Generic_Subprogram (S)
5804            or else Ekind (S) = E_Subprogram_Body
5805          then
5806             return S;
5807
5808          else
5809             S := Scope (S);
5810          end if;
5811       end loop;
5812
5813       return Empty;
5814    end Enclosing_Package_Or_Subprogram;
5815
5816    --------------------------
5817    -- Enclosing_Subprogram --
5818    --------------------------
5819
5820    function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
5821       Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
5822
5823    begin
5824       if Dynamic_Scope = Standard_Standard then
5825          return Empty;
5826
5827       elsif Dynamic_Scope = Empty then
5828          return Empty;
5829
5830       elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
5831          return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
5832
5833       elsif Ekind (Dynamic_Scope) = E_Block
5834         or else Ekind (Dynamic_Scope) = E_Return_Statement
5835       then
5836          return Enclosing_Subprogram (Dynamic_Scope);
5837
5838       elsif Ekind (Dynamic_Scope) = E_Task_Type then
5839          return Get_Task_Body_Procedure (Dynamic_Scope);
5840
5841       elsif Ekind (Dynamic_Scope) = E_Limited_Private_Type
5842         and then Present (Full_View (Dynamic_Scope))
5843         and then Ekind (Full_View (Dynamic_Scope)) = E_Task_Type
5844       then
5845          return Get_Task_Body_Procedure (Full_View (Dynamic_Scope));
5846
5847       --  No body is generated if the protected operation is eliminated
5848
5849       elsif Convention (Dynamic_Scope) = Convention_Protected
5850         and then not Is_Eliminated (Dynamic_Scope)
5851         and then Present (Protected_Body_Subprogram (Dynamic_Scope))
5852       then
5853          return Protected_Body_Subprogram (Dynamic_Scope);
5854
5855       else
5856          return Dynamic_Scope;
5857       end if;
5858    end Enclosing_Subprogram;
5859
5860    ------------------------
5861    -- Ensure_Freeze_Node --
5862    ------------------------
5863
5864    procedure Ensure_Freeze_Node (E : Entity_Id) is
5865       FN : Node_Id;
5866    begin
5867       if No (Freeze_Node (E)) then
5868          FN := Make_Freeze_Entity (Sloc (E));
5869          Set_Has_Delayed_Freeze (E);
5870          Set_Freeze_Node (E, FN);
5871          Set_Access_Types_To_Process (FN, No_Elist);
5872          Set_TSS_Elist (FN, No_Elist);
5873          Set_Entity (FN, E);
5874       end if;
5875    end Ensure_Freeze_Node;
5876
5877    ----------------
5878    -- Enter_Name --
5879    ----------------
5880
5881    procedure Enter_Name (Def_Id : Entity_Id) is
5882       C : constant Entity_Id := Current_Entity (Def_Id);
5883       E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
5884       S : constant Entity_Id := Current_Scope;
5885
5886    begin
5887       Generate_Definition (Def_Id);
5888
5889       --  Add new name to current scope declarations. Check for duplicate
5890       --  declaration, which may or may not be a genuine error.
5891
5892       if Present (E) then
5893
5894          --  Case of previous entity entered because of a missing declaration
5895          --  or else a bad subtype indication. Best is to use the new entity,
5896          --  and make the previous one invisible.
5897
5898          if Etype (E) = Any_Type then
5899             Set_Is_Immediately_Visible (E, False);
5900
5901          --  Case of renaming declaration constructed for package instances.
5902          --  if there is an explicit declaration with the same identifier,
5903          --  the renaming is not immediately visible any longer, but remains
5904          --  visible through selected component notation.
5905
5906          elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
5907            and then not Comes_From_Source (E)
5908          then
5909             Set_Is_Immediately_Visible (E, False);
5910
5911          --  The new entity may be the package renaming, which has the same
5912          --  same name as a generic formal which has been seen already.
5913
5914          elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
5915            and then not Comes_From_Source (Def_Id)
5916          then
5917             Set_Is_Immediately_Visible (E, False);
5918
5919          --  For a fat pointer corresponding to a remote access to subprogram,
5920          --  we use the same identifier as the RAS type, so that the proper
5921          --  name appears in the stub. This type is only retrieved through
5922          --  the RAS type and never by visibility, and is not added to the
5923          --  visibility list (see below).
5924
5925          elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
5926            and then Ekind (Def_Id) = E_Record_Type
5927            and then Present (Corresponding_Remote_Type (Def_Id))
5928          then
5929             null;
5930
5931          --  Case of an implicit operation or derived literal. The new entity
5932          --  hides the implicit one,  which is removed from all visibility,
5933          --  i.e. the entity list of its scope, and homonym chain of its name.
5934
5935          elsif (Is_Overloadable (E) and then Is_Inherited_Operation (E))
5936            or else Is_Internal (E)
5937          then
5938             declare
5939                Prev     : Entity_Id;
5940                Prev_Vis : Entity_Id;
5941                Decl     : constant Node_Id := Parent (E);
5942
5943             begin
5944                --  If E is an implicit declaration, it cannot be the first
5945                --  entity in the scope.
5946
5947                Prev := First_Entity (Current_Scope);
5948                while Present (Prev) and then Next_Entity (Prev) /= E loop
5949                   Next_Entity (Prev);
5950                end loop;
5951
5952                if No (Prev) then
5953
5954                   --  If E is not on the entity chain of the current scope,
5955                   --  it is an implicit declaration in the generic formal
5956                   --  part of a generic subprogram. When analyzing the body,
5957                   --  the generic formals are visible but not on the entity
5958                   --  chain of the subprogram. The new entity will become
5959                   --  the visible one in the body.
5960
5961                   pragma Assert
5962                     (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
5963                   null;
5964
5965                else
5966                   Set_Next_Entity (Prev, Next_Entity (E));
5967
5968                   if No (Next_Entity (Prev)) then
5969                      Set_Last_Entity (Current_Scope, Prev);
5970                   end if;
5971
5972                   if E = Current_Entity (E) then
5973                      Prev_Vis := Empty;
5974
5975                   else
5976                      Prev_Vis := Current_Entity (E);
5977                      while Homonym (Prev_Vis) /= E loop
5978                         Prev_Vis := Homonym (Prev_Vis);
5979                      end loop;
5980                   end if;
5981
5982                   if Present (Prev_Vis)  then
5983
5984                      --  Skip E in the visibility chain
5985
5986                      Set_Homonym (Prev_Vis, Homonym (E));
5987
5988                   else
5989                      Set_Name_Entity_Id (Chars (E), Homonym (E));
5990                   end if;
5991                end if;
5992             end;
5993
5994          --  This section of code could use a comment ???
5995
5996          elsif Present (Etype (E))
5997            and then Is_Concurrent_Type (Etype (E))
5998            and then E = Def_Id
5999          then
6000             return;
6001
6002          --  If the homograph is a protected component renaming, it should not
6003          --  be hiding the current entity. Such renamings are treated as weak
6004          --  declarations.
6005
6006          elsif Is_Prival (E) then
6007             Set_Is_Immediately_Visible (E, False);
6008
6009          --  In this case the current entity is a protected component renaming.
6010          --  Perform minimal decoration by setting the scope and return since
6011          --  the prival should not be hiding other visible entities.
6012
6013          elsif Is_Prival (Def_Id) then
6014             Set_Scope (Def_Id, Current_Scope);
6015             return;
6016
6017          --  Analogous to privals, the discriminal generated for an entry index
6018          --  parameter acts as a weak declaration. Perform minimal decoration
6019          --  to avoid bogus errors.
6020
6021          elsif Is_Discriminal (Def_Id)
6022            and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
6023          then
6024             Set_Scope (Def_Id, Current_Scope);
6025             return;
6026
6027          --  In the body or private part of an instance, a type extension may
6028          --  introduce a component with the same name as that of an actual. The
6029          --  legality rule is not enforced, but the semantics of the full type
6030          --  with two components of same name are not clear at this point???
6031
6032          elsif In_Instance_Not_Visible then
6033             null;
6034
6035          --  When compiling a package body, some child units may have become
6036          --  visible. They cannot conflict with local entities that hide them.
6037
6038          elsif Is_Child_Unit (E)
6039            and then In_Open_Scopes (Scope (E))
6040            and then not Is_Immediately_Visible (E)
6041          then
6042             null;
6043
6044          --  Conversely, with front-end inlining we may compile the parent body
6045          --  first, and a child unit subsequently. The context is now the
6046          --  parent spec, and body entities are not visible.
6047
6048          elsif Is_Child_Unit (Def_Id)
6049            and then Is_Package_Body_Entity (E)
6050            and then not In_Package_Body (Current_Scope)
6051          then
6052             null;
6053
6054          --  Case of genuine duplicate declaration
6055
6056          else
6057             Error_Msg_Sloc := Sloc (E);
6058
6059             --  If the previous declaration is an incomplete type declaration
6060             --  this may be an attempt to complete it with a private type. The
6061             --  following avoids confusing cascaded errors.
6062
6063             if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
6064               and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
6065             then
6066                Error_Msg_N
6067                  ("incomplete type cannot be completed with a private " &
6068                   "declaration", Parent (Def_Id));
6069                Set_Is_Immediately_Visible (E, False);
6070                Set_Full_View (E, Def_Id);
6071
6072             --  An inherited component of a record conflicts with a new
6073             --  discriminant. The discriminant is inserted first in the scope,
6074             --  but the error should be posted on it, not on the component.
6075
6076             elsif Ekind (E) = E_Discriminant
6077               and then Present (Scope (Def_Id))
6078               and then Scope (Def_Id) /= Current_Scope
6079             then
6080                Error_Msg_Sloc := Sloc (Def_Id);
6081                Error_Msg_N ("& conflicts with declaration#", E);
6082                return;
6083
6084             --  If the name of the unit appears in its own context clause, a
6085             --  dummy package with the name has already been created, and the
6086             --  error emitted. Try to continue quietly.
6087
6088             elsif Error_Posted (E)
6089               and then Sloc (E) = No_Location
6090               and then Nkind (Parent (E)) = N_Package_Specification
6091               and then Current_Scope = Standard_Standard
6092             then
6093                Set_Scope (Def_Id, Current_Scope);
6094                return;
6095
6096             else
6097                Error_Msg_N ("& conflicts with declaration#", Def_Id);
6098
6099                --  Avoid cascaded messages with duplicate components in
6100                --  derived types.
6101
6102                if Ekind_In (E, E_Component, E_Discriminant) then
6103                   return;
6104                end if;
6105             end if;
6106
6107             if Nkind (Parent (Parent (Def_Id))) =
6108                                              N_Generic_Subprogram_Declaration
6109               and then Def_Id =
6110                 Defining_Entity (Specification (Parent (Parent (Def_Id))))
6111             then
6112                Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
6113             end if;
6114
6115             --  If entity is in standard, then we are in trouble, because it
6116             --  means that we have a library package with a duplicated name.
6117             --  That's hard to recover from, so abort.
6118
6119             if S = Standard_Standard then
6120                raise Unrecoverable_Error;
6121
6122             --  Otherwise we continue with the declaration. Having two
6123             --  identical declarations should not cause us too much trouble.
6124
6125             else
6126                null;
6127             end if;
6128          end if;
6129       end if;
6130
6131       --  If we fall through, declaration is OK, at least OK enough to continue
6132
6133       --  If Def_Id is a discriminant or a record component we are in the midst
6134       --  of inheriting components in a derived record definition. Preserve
6135       --  their Ekind and Etype.
6136
6137       if Ekind_In (Def_Id, E_Discriminant, E_Component) then
6138          null;
6139
6140       --  If a type is already set, leave it alone (happens when a type
6141       --  declaration is reanalyzed following a call to the optimizer).
6142
6143       elsif Present (Etype (Def_Id)) then
6144          null;
6145
6146       --  Otherwise, the kind E_Void insures that premature uses of the entity
6147       --  will be detected. Any_Type insures that no cascaded errors will occur
6148
6149       else
6150          Set_Ekind (Def_Id, E_Void);
6151          Set_Etype (Def_Id, Any_Type);
6152       end if;
6153
6154       --  Inherited discriminants and components in derived record types are
6155       --  immediately visible. Itypes are not.
6156
6157       --  Unless the Itype is for a record type with a corresponding remote
6158       --  type (what is that about, it was not commented ???)
6159
6160       if Ekind_In (Def_Id, E_Discriminant, E_Component)
6161         or else
6162           ((not Is_Record_Type (Def_Id)
6163              or else No (Corresponding_Remote_Type (Def_Id)))
6164             and then not Is_Itype (Def_Id))
6165       then
6166          Set_Is_Immediately_Visible (Def_Id);
6167          Set_Current_Entity         (Def_Id);
6168       end if;
6169
6170       Set_Homonym       (Def_Id, C);
6171       Append_Entity     (Def_Id, S);
6172       Set_Public_Status (Def_Id);
6173
6174       --  Declaring a homonym is not allowed in SPARK ...
6175
6176       if Present (C) and then Restriction_Check_Required (SPARK_05) then
6177          declare
6178             Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id);
6179             Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id);
6180             Other_Scope    : constant Node_Id := Enclosing_Dynamic_Scope (C);
6181
6182          begin
6183             --  ... unless the new declaration is in a subprogram, and the
6184             --  visible declaration is a variable declaration or a parameter
6185             --  specification outside that subprogram.
6186
6187             if Present (Enclosing_Subp)
6188               and then Nkind_In (Parent (C), N_Object_Declaration,
6189                                              N_Parameter_Specification)
6190               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Subp)
6191             then
6192                null;
6193
6194             --  ... or the new declaration is in a package, and the visible
6195             --  declaration occurs outside that package.
6196
6197             elsif Present (Enclosing_Pack)
6198               and then not Scope_Within_Or_Same (Other_Scope, Enclosing_Pack)
6199             then
6200                null;
6201
6202             --  ... or the new declaration is a component declaration in a
6203             --  record type definition.
6204
6205             elsif Nkind (Parent (Def_Id)) = N_Component_Declaration then
6206                null;
6207
6208             --  Don't issue error for non-source entities
6209
6210             elsif Comes_From_Source (Def_Id)
6211               and then Comes_From_Source (C)
6212             then
6213                Error_Msg_Sloc := Sloc (C);
6214                Check_SPARK_05_Restriction
6215                  ("redeclaration of identifier &#", Def_Id);
6216             end if;
6217          end;
6218       end if;
6219
6220       --  Warn if new entity hides an old one
6221
6222       if Warn_On_Hiding and then Present (C)
6223
6224         --  Don't warn for record components since they always have a well
6225         --  defined scope which does not confuse other uses. Note that in
6226         --  some cases, Ekind has not been set yet.
6227
6228         and then Ekind (C) /= E_Component
6229         and then Ekind (C) /= E_Discriminant
6230         and then Nkind (Parent (C)) /= N_Component_Declaration
6231         and then Ekind (Def_Id) /= E_Component
6232         and then Ekind (Def_Id) /= E_Discriminant
6233         and then Nkind (Parent (Def_Id)) /= N_Component_Declaration
6234
6235         --  Don't warn for one character variables. It is too common to use
6236         --  such variables as locals and will just cause too many false hits.
6237
6238         and then Length_Of_Name (Chars (C)) /= 1
6239
6240         --  Don't warn for non-source entities
6241
6242         and then Comes_From_Source (C)
6243         and then Comes_From_Source (Def_Id)
6244
6245         --  Don't warn unless entity in question is in extended main source
6246
6247         and then In_Extended_Main_Source_Unit (Def_Id)
6248
6249         --  Finally, the hidden entity must be either immediately visible or
6250         --  use visible (i.e. from a used package).
6251
6252         and then
6253           (Is_Immediately_Visible (C)
6254              or else
6255            Is_Potentially_Use_Visible (C))
6256       then
6257          Error_Msg_Sloc := Sloc (C);
6258          Error_Msg_N ("declaration hides &#?h?", Def_Id);
6259       end if;
6260    end Enter_Name;
6261
6262    ---------------
6263    -- Entity_Of --
6264    ---------------
6265
6266    function Entity_Of (N : Node_Id) return Entity_Id is
6267       Id : Entity_Id;
6268
6269    begin
6270       Id := Empty;
6271
6272       if Is_Entity_Name (N) then
6273          Id := Entity (N);
6274
6275          --  Follow a possible chain of renamings to reach the root renamed
6276          --  object.
6277
6278          while Present (Id) and then Present (Renamed_Object (Id)) loop
6279             if Is_Entity_Name (Renamed_Object (Id)) then
6280                Id := Entity (Renamed_Object (Id));
6281             else
6282                Id := Empty;
6283                exit;
6284             end if;
6285          end loop;
6286       end if;
6287
6288       return Id;
6289    end Entity_Of;
6290
6291    --------------------------
6292    -- Explain_Limited_Type --
6293    --------------------------
6294
6295    procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
6296       C : Entity_Id;
6297
6298    begin
6299       --  For array, component type must be limited
6300
6301       if Is_Array_Type (T) then
6302          Error_Msg_Node_2 := T;
6303          Error_Msg_NE
6304            ("\component type& of type& is limited", N, Component_Type (T));
6305          Explain_Limited_Type (Component_Type (T), N);
6306
6307       elsif Is_Record_Type (T) then
6308
6309          --  No need for extra messages if explicit limited record
6310
6311          if Is_Limited_Record (Base_Type (T)) then
6312             return;
6313          end if;
6314
6315          --  Otherwise find a limited component. Check only components that
6316          --  come from source, or inherited components that appear in the
6317          --  source of the ancestor.
6318
6319          C := First_Component (T);
6320          while Present (C) loop
6321             if Is_Limited_Type (Etype (C))
6322               and then
6323                 (Comes_From_Source (C)
6324                    or else
6325                      (Present (Original_Record_Component (C))
6326                        and then
6327                          Comes_From_Source (Original_Record_Component (C))))
6328             then
6329                Error_Msg_Node_2 := T;
6330                Error_Msg_NE ("\component& of type& has limited type", N, C);
6331                Explain_Limited_Type (Etype (C), N);
6332                return;
6333             end if;
6334
6335             Next_Component (C);
6336          end loop;
6337
6338          --  The type may be declared explicitly limited, even if no component
6339          --  of it is limited, in which case we fall out of the loop.
6340          return;
6341       end if;
6342    end Explain_Limited_Type;
6343
6344    -------------------------------
6345    -- Extensions_Visible_Status --
6346    -------------------------------
6347
6348    function Extensions_Visible_Status
6349      (Id : Entity_Id) return Extensions_Visible_Mode
6350    is
6351       Arg  : Node_Id;
6352       Decl : Node_Id;
6353       Expr : Node_Id;
6354       Prag : Node_Id;
6355       Subp : Entity_Id;
6356
6357    begin
6358       --  When a formal parameter is subject to Extensions_Visible, the pragma
6359       --  is stored in the contract of related subprogram.
6360
6361       if Is_Formal (Id) then
6362          Subp := Scope (Id);
6363
6364       elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
6365          Subp := Id;
6366
6367       --  No other construct carries this pragma
6368
6369       else
6370          return Extensions_Visible_None;
6371       end if;
6372
6373       Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
6374
6375       --  In certain cases analysis may request the Extensions_Visible status
6376       --  of an expression function before the pragma has been analyzed yet.
6377       --  Inspect the declarative items after the expression function looking
6378       --  for the pragma (if any).
6379
6380       if No (Prag) and then Is_Expression_Function (Subp) then
6381          Decl := Next (Unit_Declaration_Node (Subp));
6382          while Present (Decl) loop
6383             if Nkind (Decl) = N_Pragma
6384               and then Pragma_Name (Decl) = Name_Extensions_Visible
6385             then
6386                Prag := Decl;
6387                exit;
6388
6389             --  A source construct ends the region where Extensions_Visible may
6390             --  appear, stop the traversal. An expanded expression function is
6391             --  no longer a source construct, but it must still be recognized.
6392
6393             elsif Comes_From_Source (Decl)
6394               or else
6395                 (Nkind_In (Decl, N_Subprogram_Body,
6396                                  N_Subprogram_Declaration)
6397                   and then Is_Expression_Function (Defining_Entity (Decl)))
6398             then
6399                exit;
6400             end if;
6401
6402             Next (Decl);
6403          end loop;
6404       end if;
6405
6406       --  Extract the value from the Boolean expression (if any)
6407
6408       if Present (Prag) then
6409          Arg := First (Pragma_Argument_Associations (Prag));
6410
6411          if Present (Arg) then
6412             Expr := Get_Pragma_Arg (Arg);
6413
6414             --  When the associated subprogram is an expression function, the
6415             --  argument of the pragma may not have been analyzed.
6416
6417             if not Analyzed (Expr) then
6418                Preanalyze_And_Resolve (Expr, Standard_Boolean);
6419             end if;
6420
6421             --  Guard against cascading errors when the argument of pragma
6422             --  Extensions_Visible is not a valid static Boolean expression.
6423
6424             if Error_Posted (Expr) then
6425                return Extensions_Visible_None;
6426
6427             elsif Is_True (Expr_Value (Expr)) then
6428                return Extensions_Visible_True;
6429
6430             else
6431                return Extensions_Visible_False;
6432             end if;
6433
6434          --  Otherwise the aspect or pragma defaults to True
6435
6436          else
6437             return Extensions_Visible_True;
6438          end if;
6439
6440       --  Otherwise aspect or pragma Extensions_Visible is not inherited or
6441       --  directly specified. In SPARK code, its value defaults to "False".
6442
6443       elsif SPARK_Mode = On then
6444          return Extensions_Visible_False;
6445
6446       --  In non-SPARK code, aspect or pragma Extensions_Visible defaults to
6447       --  "True".
6448
6449       else
6450          return Extensions_Visible_True;
6451       end if;
6452    end Extensions_Visible_Status;
6453
6454    -----------------
6455    -- Find_Actual --
6456    -----------------
6457
6458    procedure Find_Actual
6459      (N        : Node_Id;
6460       Formal   : out Entity_Id;
6461       Call     : out Node_Id)
6462    is
6463       Context  : constant Node_Id := Parent (N);
6464       Actual   : Node_Id;
6465       Call_Nam : Node_Id;
6466
6467    begin
6468       if Nkind_In (Context, N_Indexed_Component, N_Selected_Component)
6469         and then N = Prefix (Context)
6470       then
6471          Find_Actual (Context, Formal, Call);
6472          return;
6473
6474       elsif Nkind (Context) = N_Parameter_Association
6475         and then N = Explicit_Actual_Parameter (Context)
6476       then
6477          Call := Parent (Context);
6478
6479       elsif Nkind_In (Context, N_Entry_Call_Statement,
6480                                N_Function_Call,
6481                                N_Procedure_Call_Statement)
6482       then
6483          Call := Context;
6484
6485       else
6486          Formal := Empty;
6487          Call   := Empty;
6488          return;
6489       end if;
6490
6491       --  If we have a call to a subprogram look for the parameter. Note that
6492       --  we exclude overloaded calls, since we don't know enough to be sure
6493       --  of giving the right answer in this case.
6494
6495       if Nkind_In (Call, N_Entry_Call_Statement,
6496                          N_Function_Call,
6497                          N_Procedure_Call_Statement)
6498       then
6499          Call_Nam := Name (Call);
6500
6501          --  A call to a protected or task entry appears as a selected
6502          --  component rather than an expanded name.
6503
6504          if Nkind (Call_Nam) = N_Selected_Component then
6505             Call_Nam := Selector_Name (Call_Nam);
6506          end if;
6507
6508          if Is_Entity_Name (Call_Nam)
6509            and then Present (Entity (Call_Nam))
6510            and then Is_Overloadable (Entity (Call_Nam))
6511            and then not Is_Overloaded (Call_Nam)
6512          then
6513             --  If node is name in call it is not an actual
6514
6515             if N = Call_Nam then
6516                Formal := Empty;
6517                Call   := Empty;
6518                return;
6519             end if;
6520
6521             --  Fall here if we are definitely a parameter
6522
6523             Actual := First_Actual (Call);
6524             Formal := First_Formal (Entity (Call_Nam));
6525             while Present (Formal) and then Present (Actual) loop
6526                if Actual = N then
6527                   return;
6528
6529                --  An actual that is the prefix in a prefixed call may have
6530                --  been rewritten in the call, after the deferred reference
6531                --  was collected. Check if sloc and kinds and names match.
6532
6533                elsif Sloc (Actual) = Sloc (N)
6534                  and then Nkind (Actual) = N_Identifier
6535                  and then Nkind (Actual) = Nkind (N)
6536                  and then Chars (Actual) = Chars (N)
6537                then
6538                   return;
6539
6540                else
6541                   Actual := Next_Actual (Actual);
6542                   Formal := Next_Formal (Formal);
6543                end if;
6544             end loop;
6545          end if;
6546       end if;
6547
6548       --  Fall through here if we did not find matching actual
6549
6550       Formal := Empty;
6551       Call   := Empty;
6552    end Find_Actual;
6553
6554    ---------------------------
6555    -- Find_Body_Discriminal --
6556    ---------------------------
6557
6558    function Find_Body_Discriminal
6559      (Spec_Discriminant : Entity_Id) return Entity_Id
6560    is
6561       Tsk  : Entity_Id;
6562       Disc : Entity_Id;
6563
6564    begin
6565       --  If expansion is suppressed, then the scope can be the concurrent type
6566       --  itself rather than a corresponding concurrent record type.
6567
6568       if Is_Concurrent_Type (Scope (Spec_Discriminant)) then
6569          Tsk := Scope (Spec_Discriminant);
6570
6571       else
6572          pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
6573
6574          Tsk := Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
6575       end if;
6576
6577       --  Find discriminant of original concurrent type, and use its current
6578       --  discriminal, which is the renaming within the task/protected body.
6579
6580       Disc := First_Discriminant (Tsk);
6581       while Present (Disc) loop
6582          if Chars (Disc) = Chars (Spec_Discriminant) then
6583             return Discriminal (Disc);
6584          end if;
6585
6586          Next_Discriminant (Disc);
6587       end loop;
6588
6589       --  That loop should always succeed in finding a matching entry and
6590       --  returning. Fatal error if not.
6591
6592       raise Program_Error;
6593    end Find_Body_Discriminal;
6594
6595    -------------------------------------
6596    -- Find_Corresponding_Discriminant --
6597    -------------------------------------
6598
6599    function Find_Corresponding_Discriminant
6600      (Id  : Node_Id;
6601       Typ : Entity_Id) return Entity_Id
6602    is
6603       Par_Disc : Entity_Id;
6604       Old_Disc : Entity_Id;
6605       New_Disc : Entity_Id;
6606
6607    begin
6608       Par_Disc := Original_Record_Component (Original_Discriminant (Id));
6609
6610       --  The original type may currently be private, and the discriminant
6611       --  only appear on its full view.
6612
6613       if Is_Private_Type (Scope (Par_Disc))
6614         and then not Has_Discriminants (Scope (Par_Disc))
6615         and then Present (Full_View (Scope (Par_Disc)))
6616       then
6617          Old_Disc := First_Discriminant (Full_View (Scope (Par_Disc)));
6618       else
6619          Old_Disc := First_Discriminant (Scope (Par_Disc));
6620       end if;
6621
6622       if Is_Class_Wide_Type (Typ) then
6623          New_Disc := First_Discriminant (Root_Type (Typ));
6624       else
6625          New_Disc := First_Discriminant (Typ);
6626       end if;
6627
6628       while Present (Old_Disc) and then Present (New_Disc) loop
6629          if Old_Disc = Par_Disc  then
6630             return New_Disc;
6631          end if;
6632
6633          Next_Discriminant (Old_Disc);
6634          Next_Discriminant (New_Disc);
6635       end loop;
6636
6637       --  Should always find it
6638
6639       raise Program_Error;
6640    end Find_Corresponding_Discriminant;
6641
6642    ----------------------------------
6643    -- Find_Enclosing_Iterator_Loop --
6644    ----------------------------------
6645
6646    function Find_Enclosing_Iterator_Loop (Id : Entity_Id) return Entity_Id is
6647       Constr : Node_Id;
6648       S      : Entity_Id;
6649
6650    begin
6651       --  Traverse the scope chain looking for an iterator loop. Such loops are
6652       --  usually transformed into blocks, hence the use of Original_Node.
6653
6654       S := Id;
6655       while Present (S) and then S /= Standard_Standard loop
6656          if Ekind (S) = E_Loop
6657            and then Nkind (Parent (S)) = N_Implicit_Label_Declaration
6658          then
6659             Constr := Original_Node (Label_Construct (Parent (S)));
6660
6661             if Nkind (Constr) = N_Loop_Statement
6662               and then Present (Iteration_Scheme (Constr))
6663               and then Nkind (Iterator_Specification
6664                                 (Iteration_Scheme (Constr))) =
6665                                                  N_Iterator_Specification
6666             then
6667                return S;
6668             end if;
6669          end if;
6670
6671          S := Scope (S);
6672       end loop;
6673
6674       return Empty;
6675    end Find_Enclosing_Iterator_Loop;
6676
6677    ------------------------------------
6678    -- Find_Loop_In_Conditional_Block --
6679    ------------------------------------
6680
6681    function Find_Loop_In_Conditional_Block (N : Node_Id) return Node_Id is
6682       Stmt : Node_Id;
6683
6684    begin
6685       Stmt := N;
6686
6687       if Nkind (Stmt) = N_If_Statement then
6688          Stmt := First (Then_Statements (Stmt));
6689       end if;
6690
6691       pragma Assert (Nkind (Stmt) = N_Block_Statement);
6692
6693       --  Inspect the statements of the conditional block. In general the loop
6694       --  should be the first statement in the statement sequence of the block,
6695       --  but the finalization machinery may have introduced extra object
6696       --  declarations.
6697
6698       Stmt := First (Statements (Handled_Statement_Sequence (Stmt)));
6699       while Present (Stmt) loop
6700          if Nkind (Stmt) = N_Loop_Statement then
6701             return Stmt;
6702          end if;
6703
6704          Next (Stmt);
6705       end loop;
6706
6707       --  The expansion of attribute 'Loop_Entry produced a malformed block
6708
6709       raise Program_Error;
6710    end Find_Loop_In_Conditional_Block;
6711
6712    --------------------------
6713    -- Find_Overlaid_Entity --
6714    --------------------------
6715
6716    procedure Find_Overlaid_Entity
6717      (N   : Node_Id;
6718       Ent : out Entity_Id;
6719       Off : out Boolean)
6720    is
6721       Expr : Node_Id;
6722
6723    begin
6724       --  We are looking for one of the two following forms:
6725
6726       --    for X'Address use Y'Address
6727
6728       --  or
6729
6730       --    Const : constant Address := expr;
6731       --    ...
6732       --    for X'Address use Const;
6733
6734       --  In the second case, the expr is either Y'Address, or recursively a
6735       --  constant that eventually references Y'Address.
6736
6737       Ent := Empty;
6738       Off := False;
6739
6740       if Nkind (N) = N_Attribute_Definition_Clause
6741         and then Chars (N) = Name_Address
6742       then
6743          Expr := Expression (N);
6744
6745          --  This loop checks the form of the expression for Y'Address,
6746          --  using recursion to deal with intermediate constants.
6747
6748          loop
6749             --  Check for Y'Address
6750
6751             if Nkind (Expr) = N_Attribute_Reference
6752               and then Attribute_Name (Expr) = Name_Address
6753             then
6754                Expr := Prefix (Expr);
6755                exit;
6756
6757                --  Check for Const where Const is a constant entity
6758
6759             elsif Is_Entity_Name (Expr)
6760               and then Ekind (Entity (Expr)) = E_Constant
6761             then
6762                Expr := Constant_Value (Entity (Expr));
6763
6764             --  Anything else does not need checking
6765
6766             else
6767                return;
6768             end if;
6769          end loop;
6770
6771          --  This loop checks the form of the prefix for an entity, using
6772          --  recursion to deal with intermediate components.
6773
6774          loop
6775             --  Check for Y where Y is an entity
6776
6777             if Is_Entity_Name (Expr) then
6778                Ent := Entity (Expr);
6779                return;
6780
6781             --  Check for components
6782
6783             elsif
6784               Nkind_In (Expr, N_Selected_Component, N_Indexed_Component)
6785             then
6786                Expr := Prefix (Expr);
6787                Off := True;
6788
6789             --  Anything else does not need checking
6790
6791             else
6792                return;
6793             end if;
6794          end loop;
6795       end if;
6796    end Find_Overlaid_Entity;
6797
6798    -------------------------
6799    -- Find_Parameter_Type --
6800    -------------------------
6801
6802    function Find_Parameter_Type (Param : Node_Id) return Entity_Id is
6803    begin
6804       if Nkind (Param) /= N_Parameter_Specification then
6805          return Empty;
6806
6807       --  For an access parameter, obtain the type from the formal entity
6808       --  itself, because access to subprogram nodes do not carry a type.
6809       --  Shouldn't we always use the formal entity ???
6810
6811       elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then
6812          return Etype (Defining_Identifier (Param));
6813
6814       else
6815          return Etype (Parameter_Type (Param));
6816       end if;
6817    end Find_Parameter_Type;
6818
6819    -----------------------------------
6820    -- Find_Placement_In_State_Space --
6821    -----------------------------------
6822
6823    procedure Find_Placement_In_State_Space
6824      (Item_Id   : Entity_Id;
6825       Placement : out State_Space_Kind;
6826       Pack_Id   : out Entity_Id)
6827    is
6828       Context : Entity_Id;
6829
6830    begin
6831       --  Assume that the item does not appear in the state space of a package
6832
6833       Placement := Not_In_Package;
6834       Pack_Id   := Empty;
6835
6836       --  Climb the scope stack and examine the enclosing context
6837
6838       Context := Scope (Item_Id);
6839       while Present (Context) and then Context /= Standard_Standard loop
6840          if Ekind (Context) = E_Package then
6841             Pack_Id := Context;
6842
6843             --  A package body is a cut off point for the traversal as the item
6844             --  cannot be visible to the outside from this point on. Note that
6845             --  this test must be done first as a body is also classified as a
6846             --  private part.
6847
6848             if In_Package_Body (Context) then
6849                Placement := Body_State_Space;
6850                return;
6851
6852             --  The private part of a package is a cut off point for the
6853             --  traversal as the item cannot be visible to the outside from
6854             --  this point on.
6855
6856             elsif In_Private_Part (Context) then
6857                Placement := Private_State_Space;
6858                return;
6859
6860             --  When the item appears in the visible state space of a package,
6861             --  continue to climb the scope stack as this may not be the final
6862             --  state space.
6863
6864             else
6865                Placement := Visible_State_Space;
6866
6867                --  The visible state space of a child unit acts as the proper
6868                --  placement of an item.
6869
6870                if Is_Child_Unit (Context) then
6871                   return;
6872                end if;
6873             end if;
6874
6875          --  The item or its enclosing package appear in a construct that has
6876          --  no state space.
6877
6878          else
6879             Placement := Not_In_Package;
6880             return;
6881          end if;
6882
6883          Context := Scope (Context);
6884       end loop;
6885    end Find_Placement_In_State_Space;
6886
6887    ------------------------
6888    -- Find_Specific_Type --
6889    ------------------------
6890
6891    function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
6892       Typ : Entity_Id := Root_Type (CW);
6893
6894    begin
6895       if Ekind (Typ) = E_Incomplete_Type then
6896          if From_Limited_With (Typ) then
6897             Typ := Non_Limited_View (Typ);
6898          else
6899             Typ := Full_View (Typ);
6900          end if;
6901       end if;
6902
6903       if Is_Private_Type (Typ)
6904         and then not Is_Tagged_Type (Typ)
6905         and then Present (Full_View (Typ))
6906       then
6907          return Full_View (Typ);
6908       else
6909          return Typ;
6910       end if;
6911    end Find_Specific_Type;
6912
6913    -----------------------------
6914    -- Find_Static_Alternative --
6915    -----------------------------
6916
6917    function Find_Static_Alternative (N : Node_Id) return Node_Id is
6918       Expr   : constant Node_Id := Expression (N);
6919       Val    : constant Uint    := Expr_Value (Expr);
6920       Alt    : Node_Id;
6921       Choice : Node_Id;
6922
6923    begin
6924       Alt := First (Alternatives (N));
6925
6926       Search : loop
6927          if Nkind (Alt) /= N_Pragma then
6928             Choice := First (Discrete_Choices (Alt));
6929             while Present (Choice) loop
6930
6931                --  Others choice, always matches
6932
6933                if Nkind (Choice) = N_Others_Choice then
6934                   exit Search;
6935
6936                --  Range, check if value is in the range
6937
6938                elsif Nkind (Choice) = N_Range then
6939                   exit Search when
6940                     Val >= Expr_Value (Low_Bound (Choice))
6941                       and then
6942                     Val <= Expr_Value (High_Bound (Choice));
6943
6944                --  Choice is a subtype name. Note that we know it must
6945                --  be a static subtype, since otherwise it would have
6946                --  been diagnosed as illegal.
6947
6948                elsif Is_Entity_Name (Choice)
6949                  and then Is_Type (Entity (Choice))
6950                then
6951                   exit Search when Is_In_Range (Expr, Etype (Choice),
6952                                                 Assume_Valid => False);
6953
6954                --  Choice is a subtype indication
6955
6956                elsif Nkind (Choice) = N_Subtype_Indication then
6957                   declare
6958                      C : constant Node_Id := Constraint (Choice);
6959                      R : constant Node_Id := Range_Expression (C);
6960
6961                   begin
6962                      exit Search when
6963                        Val >= Expr_Value (Low_Bound  (R))
6964                          and then
6965                        Val <= Expr_Value (High_Bound (R));
6966                   end;
6967
6968                --  Choice is a simple expression
6969
6970                else
6971                   exit Search when Val = Expr_Value (Choice);
6972                end if;
6973
6974                Next (Choice);
6975             end loop;
6976          end if;
6977
6978          Next (Alt);
6979          pragma Assert (Present (Alt));
6980       end loop Search;
6981
6982       --  The above loop *must* terminate by finding a match, since
6983       --  we know the case statement is valid, and the value of the
6984       --  expression is known at compile time. When we fall out of
6985       --  the loop, Alt points to the alternative that we know will
6986       --  be selected at run time.
6987
6988       return Alt;
6989    end Find_Static_Alternative;
6990
6991    ------------------
6992    -- First_Actual --
6993    ------------------
6994
6995    function First_Actual (Node : Node_Id) return Node_Id is
6996       N : Node_Id;
6997
6998    begin
6999       if No (Parameter_Associations (Node)) then
7000          return Empty;
7001       end if;
7002
7003       N := First (Parameter_Associations (Node));
7004
7005       if Nkind (N) = N_Parameter_Association then
7006          return First_Named_Actual (Node);
7007       else
7008          return N;
7009       end if;
7010    end First_Actual;
7011
7012    -----------------------
7013    -- Gather_Components --
7014    -----------------------
7015
7016    procedure Gather_Components
7017      (Typ           : Entity_Id;
7018       Comp_List     : Node_Id;
7019       Governed_By   : List_Id;
7020       Into          : Elist_Id;
7021       Report_Errors : out Boolean)
7022    is
7023       Assoc           : Node_Id;
7024       Variant         : Node_Id;
7025       Discrete_Choice : Node_Id;
7026       Comp_Item       : Node_Id;
7027
7028       Discrim       : Entity_Id;
7029       Discrim_Name  : Node_Id;
7030       Discrim_Value : Node_Id;
7031
7032    begin
7033       Report_Errors := False;
7034
7035       if No (Comp_List) or else Null_Present (Comp_List) then
7036          return;
7037
7038       elsif Present (Component_Items (Comp_List)) then
7039          Comp_Item := First (Component_Items (Comp_List));
7040
7041       else
7042          Comp_Item := Empty;
7043       end if;
7044
7045       while Present (Comp_Item) loop
7046
7047          --  Skip the tag of a tagged record, the interface tags, as well
7048          --  as all items that are not user components (anonymous types,
7049          --  rep clauses, Parent field, controller field).
7050
7051          if Nkind (Comp_Item) = N_Component_Declaration then
7052             declare
7053                Comp : constant Entity_Id := Defining_Identifier (Comp_Item);
7054             begin
7055                if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then
7056                   Append_Elmt (Comp, Into);
7057                end if;
7058             end;
7059          end if;
7060
7061          Next (Comp_Item);
7062       end loop;
7063
7064       if No (Variant_Part (Comp_List)) then
7065          return;
7066       else
7067          Discrim_Name := Name (Variant_Part (Comp_List));
7068          Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
7069       end if;
7070
7071       --  Look for the discriminant that governs this variant part.
7072       --  The discriminant *must* be in the Governed_By List
7073
7074       Assoc := First (Governed_By);
7075       Find_Constraint : loop
7076          Discrim := First (Choices (Assoc));
7077          exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
7078            or else (Present (Corresponding_Discriminant (Entity (Discrim)))
7079                      and then
7080                        Chars (Corresponding_Discriminant (Entity (Discrim))) =
7081                                                        Chars  (Discrim_Name))
7082            or else Chars (Original_Record_Component (Entity (Discrim)))
7083                          = Chars (Discrim_Name);
7084
7085          if No (Next (Assoc)) then
7086             if not Is_Constrained (Typ)
7087               and then Is_Derived_Type (Typ)
7088               and then Present (Stored_Constraint (Typ))
7089             then
7090                --  If the type is a tagged type with inherited discriminants,
7091                --  use the stored constraint on the parent in order to find
7092                --  the values of discriminants that are otherwise hidden by an
7093                --  explicit constraint. Renamed discriminants are handled in
7094                --  the code above.
7095
7096                --  If several parent discriminants are renamed by a single
7097                --  discriminant of the derived type, the call to obtain the
7098                --  Corresponding_Discriminant field only retrieves the last
7099                --  of them. We recover the constraint on the others from the
7100                --  Stored_Constraint as well.
7101
7102                declare
7103                   D : Entity_Id;
7104                   C : Elmt_Id;
7105
7106                begin
7107                   D := First_Discriminant (Etype (Typ));
7108                   C := First_Elmt (Stored_Constraint (Typ));
7109                   while Present (D) and then Present (C) loop
7110                      if Chars (Discrim_Name) = Chars (D) then
7111                         if Is_Entity_Name (Node (C))
7112                           and then Entity (Node (C)) = Entity (Discrim)
7113                         then
7114                            --  D is renamed by Discrim, whose value is given in
7115                            --  Assoc.
7116
7117                            null;
7118
7119                         else
7120                            Assoc :=
7121                              Make_Component_Association (Sloc (Typ),
7122                                New_List
7123                                  (New_Occurrence_Of (D, Sloc (Typ))),
7124                                   Duplicate_Subexpr_No_Checks (Node (C)));
7125                         end if;
7126                         exit Find_Constraint;
7127                      end if;
7128
7129                      Next_Discriminant (D);
7130                      Next_Elmt (C);
7131                   end loop;
7132                end;
7133             end if;
7134          end if;
7135
7136          if No (Next (Assoc)) then
7137             Error_Msg_NE (" missing value for discriminant&",
7138               First (Governed_By), Discrim_Name);
7139             Report_Errors := True;
7140             return;
7141          end if;
7142
7143          Next (Assoc);
7144       end loop Find_Constraint;
7145
7146       Discrim_Value := Expression (Assoc);
7147
7148       if not Is_OK_Static_Expression (Discrim_Value) then
7149
7150          --  If the variant part is governed by a discriminant of the type
7151          --  this is an error. If the variant part and the discriminant are
7152          --  inherited from an ancestor this is legal (AI05-120) unless the
7153          --  components are being gathered for an aggregate, in which case
7154          --  the caller must check Report_Errors.
7155
7156          if Scope (Original_Record_Component
7157                      ((Entity (First (Choices (Assoc)))))) = Typ
7158          then
7159             Error_Msg_FE
7160               ("value for discriminant & must be static!",
7161                Discrim_Value, Discrim);
7162             Why_Not_Static (Discrim_Value);
7163          end if;
7164
7165          Report_Errors := True;
7166          return;
7167       end if;
7168
7169       Search_For_Discriminant_Value : declare
7170          Low  : Node_Id;
7171          High : Node_Id;
7172
7173          UI_High          : Uint;
7174          UI_Low           : Uint;
7175          UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
7176
7177       begin
7178          Find_Discrete_Value : while Present (Variant) loop
7179             Discrete_Choice := First (Discrete_Choices (Variant));
7180             while Present (Discrete_Choice) loop
7181                exit Find_Discrete_Value when
7182                  Nkind (Discrete_Choice) = N_Others_Choice;
7183
7184                Get_Index_Bounds (Discrete_Choice, Low, High);
7185
7186                UI_Low  := Expr_Value (Low);
7187                UI_High := Expr_Value (High);
7188
7189                exit Find_Discrete_Value when
7190                  UI_Low <= UI_Discrim_Value
7191                    and then
7192                  UI_High >= UI_Discrim_Value;
7193
7194                Next (Discrete_Choice);
7195             end loop;
7196
7197             Next_Non_Pragma (Variant);
7198          end loop Find_Discrete_Value;
7199       end Search_For_Discriminant_Value;
7200
7201       if No (Variant) then
7202          Error_Msg_NE
7203            ("value of discriminant & is out of range", Discrim_Value, Discrim);
7204          Report_Errors := True;
7205          return;
7206       end  if;
7207
7208       --  If we have found the corresponding choice, recursively add its
7209       --  components to the Into list. The nested components are part of
7210       --  the same record type.
7211
7212       Gather_Components
7213         (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
7214    end Gather_Components;
7215
7216    ------------------------
7217    -- Get_Actual_Subtype --
7218    ------------------------
7219
7220    function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
7221       Typ  : constant Entity_Id := Etype (N);
7222       Utyp : Entity_Id := Underlying_Type (Typ);
7223       Decl : Node_Id;
7224       Atyp : Entity_Id;
7225
7226    begin
7227       if No (Utyp) then
7228          Utyp := Typ;
7229       end if;
7230
7231       --  If what we have is an identifier that references a subprogram
7232       --  formal, or a variable or constant object, then we get the actual
7233       --  subtype from the referenced entity if one has been built.
7234
7235       if Nkind (N) = N_Identifier
7236         and then
7237           (Is_Formal (Entity (N))
7238             or else Ekind (Entity (N)) = E_Constant
7239             or else Ekind (Entity (N)) = E_Variable)
7240         and then Present (Actual_Subtype (Entity (N)))
7241       then
7242          return Actual_Subtype (Entity (N));
7243
7244       --  Actual subtype of unchecked union is always itself. We never need
7245       --  the "real" actual subtype. If we did, we couldn't get it anyway
7246       --  because the discriminant is not available. The restrictions on
7247       --  Unchecked_Union are designed to make sure that this is OK.
7248
7249       elsif Is_Unchecked_Union (Base_Type (Utyp)) then
7250          return Typ;
7251
7252       --  Here for the unconstrained case, we must find actual subtype
7253       --  No actual subtype is available, so we must build it on the fly.
7254
7255       --  Checking the type, not the underlying type, for constrainedness
7256       --  seems to be necessary. Maybe all the tests should be on the type???
7257
7258       elsif (not Is_Constrained (Typ))
7259            and then (Is_Array_Type (Utyp)
7260                       or else (Is_Record_Type (Utyp)
7261                                 and then Has_Discriminants (Utyp)))
7262            and then not Has_Unknown_Discriminants (Utyp)
7263            and then not (Ekind (Utyp) = E_String_Literal_Subtype)
7264       then
7265          --  Nothing to do if in spec expression (why not???)
7266
7267          if In_Spec_Expression then
7268             return Typ;
7269
7270          elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
7271
7272             --  If the type has no discriminants, there is no subtype to
7273             --  build, even if the underlying type is discriminated.
7274
7275             return Typ;
7276
7277          --  Else build the actual subtype
7278
7279          else
7280             Decl := Build_Actual_Subtype (Typ, N);
7281             Atyp := Defining_Identifier (Decl);
7282
7283             --  If Build_Actual_Subtype generated a new declaration then use it
7284
7285             if Atyp /= Typ then
7286
7287                --  The actual subtype is an Itype, so analyze the declaration,
7288                --  but do not attach it to the tree, to get the type defined.
7289
7290                Set_Parent (Decl, N);
7291                Set_Is_Itype (Atyp);
7292                Analyze (Decl, Suppress => All_Checks);
7293                Set_Associated_Node_For_Itype (Atyp, N);
7294                Set_Has_Delayed_Freeze (Atyp, False);
7295
7296                --  We need to freeze the actual subtype immediately. This is
7297                --  needed, because otherwise this Itype will not get frozen
7298                --  at all, and it is always safe to freeze on creation because
7299                --  any associated types must be frozen at this point.
7300
7301                Freeze_Itype (Atyp, N);
7302                return Atyp;
7303
7304             --  Otherwise we did not build a declaration, so return original
7305
7306             else
7307                return Typ;
7308             end if;
7309          end if;
7310
7311       --  For all remaining cases, the actual subtype is the same as
7312       --  the nominal type.
7313
7314       else
7315          return Typ;
7316       end if;
7317    end Get_Actual_Subtype;
7318
7319    -------------------------------------
7320    -- Get_Actual_Subtype_If_Available --
7321    -------------------------------------
7322
7323    function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
7324       Typ  : constant Entity_Id := Etype (N);
7325
7326    begin
7327       --  If what we have is an identifier that references a subprogram
7328       --  formal, or a variable or constant object, then we get the actual
7329       --  subtype from the referenced entity if one has been built.
7330
7331       if Nkind (N) = N_Identifier
7332         and then
7333           (Is_Formal (Entity (N))
7334             or else Ekind (Entity (N)) = E_Constant
7335             or else Ekind (Entity (N)) = E_Variable)
7336         and then Present (Actual_Subtype (Entity (N)))
7337       then
7338          return Actual_Subtype (Entity (N));
7339
7340       --  Otherwise the Etype of N is returned unchanged
7341
7342       else
7343          return Typ;
7344       end if;
7345    end Get_Actual_Subtype_If_Available;
7346
7347    ------------------------
7348    -- Get_Body_From_Stub --
7349    ------------------------
7350
7351    function Get_Body_From_Stub (N : Node_Id) return Node_Id is
7352    begin
7353       return Proper_Body (Unit (Library_Unit (N)));
7354    end Get_Body_From_Stub;
7355
7356    ---------------------
7357    -- Get_Cursor_Type --
7358    ---------------------
7359
7360    function Get_Cursor_Type
7361      (Aspect : Node_Id;
7362       Typ    : Entity_Id) return Entity_Id
7363    is
7364       Assoc    : Node_Id;
7365       Func     : Entity_Id;
7366       First_Op : Entity_Id;
7367       Cursor   : Entity_Id;
7368
7369    begin
7370       --  If error already detected, return
7371
7372       if Error_Posted (Aspect) then
7373          return Any_Type;
7374       end if;
7375
7376       --  The cursor type for an Iterable aspect is the return type of a
7377       --  non-overloaded First primitive operation. Locate association for
7378       --  First.
7379
7380       Assoc := First (Component_Associations (Expression (Aspect)));
7381       First_Op  := Any_Id;
7382       while Present (Assoc) loop
7383          if Chars (First (Choices (Assoc))) = Name_First then
7384             First_Op := Expression (Assoc);
7385             exit;
7386          end if;
7387
7388          Next (Assoc);
7389       end loop;
7390
7391       if First_Op = Any_Id then
7392          Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
7393          return Any_Type;
7394       end if;
7395
7396       Cursor := Any_Type;
7397
7398       --  Locate function with desired name and profile in scope of type
7399
7400       Func := First_Entity (Scope (Typ));
7401       while Present (Func) loop
7402          if Chars (Func) = Chars (First_Op)
7403            and then Ekind (Func) = E_Function
7404            and then Present (First_Formal (Func))
7405            and then Etype (First_Formal (Func)) = Typ
7406            and then No (Next_Formal (First_Formal (Func)))
7407          then
7408             if Cursor /= Any_Type then
7409                Error_Msg_N
7410                  ("Operation First for iterable type must be unique", Aspect);
7411                return Any_Type;
7412             else
7413                Cursor := Etype (Func);
7414             end if;
7415          end if;
7416
7417          Next_Entity (Func);
7418       end loop;
7419
7420       --  If not found, no way to resolve remaining primitives.
7421
7422       if Cursor = Any_Type then
7423          Error_Msg_N
7424            ("No legal primitive operation First for Iterable type", Aspect);
7425       end if;
7426
7427       return Cursor;
7428    end Get_Cursor_Type;
7429
7430    function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
7431    begin
7432       return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
7433    end Get_Cursor_Type;
7434
7435    -------------------------------
7436    -- Get_Default_External_Name --
7437    -------------------------------
7438
7439    function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
7440    begin
7441       Get_Decoded_Name_String (Chars (E));
7442
7443       if Opt.External_Name_Imp_Casing = Uppercase then
7444          Set_Casing (All_Upper_Case);
7445       else
7446          Set_Casing (All_Lower_Case);
7447       end if;
7448
7449       return
7450         Make_String_Literal (Sloc (E),
7451           Strval => String_From_Name_Buffer);
7452    end Get_Default_External_Name;
7453
7454    --------------------------
7455    -- Get_Enclosing_Object --
7456    --------------------------
7457
7458    function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
7459    begin
7460       if Is_Entity_Name (N) then
7461          return Entity (N);
7462       else
7463          case Nkind (N) is
7464             when N_Indexed_Component  |
7465                  N_Slice              |
7466                  N_Selected_Component =>
7467
7468                --  If not generating code, a dereference may be left implicit.
7469                --  In thoses cases, return Empty.
7470
7471                if Is_Access_Type (Etype (Prefix (N))) then
7472                   return Empty;
7473                else
7474                   return Get_Enclosing_Object (Prefix (N));
7475                end if;
7476
7477             when N_Type_Conversion =>
7478                return Get_Enclosing_Object (Expression (N));
7479
7480             when others =>
7481                return Empty;
7482          end case;
7483       end if;
7484    end Get_Enclosing_Object;
7485
7486    ---------------------------
7487    -- Get_Enum_Lit_From_Pos --
7488    ---------------------------
7489
7490    function Get_Enum_Lit_From_Pos
7491      (T   : Entity_Id;
7492       Pos : Uint;
7493       Loc : Source_Ptr) return Node_Id
7494    is
7495       Btyp : Entity_Id := Base_Type (T);
7496       Lit  : Node_Id;
7497
7498    begin
7499       --  In the case where the literal is of type Character, Wide_Character
7500       --  or Wide_Wide_Character or of a type derived from them, there needs
7501       --  to be some special handling since there is no explicit chain of
7502       --  literals to search. Instead, an N_Character_Literal node is created
7503       --  with the appropriate Char_Code and Chars fields.
7504
7505       if Is_Standard_Character_Type (T) then
7506          Set_Character_Literal_Name (UI_To_CC (Pos));
7507          return
7508            Make_Character_Literal (Loc,
7509              Chars              => Name_Find,
7510              Char_Literal_Value => Pos);
7511
7512       --  For all other cases, we have a complete table of literals, and
7513       --  we simply iterate through the chain of literal until the one
7514       --  with the desired position value is found.
7515
7516       else
7517          if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
7518             Btyp := Full_View (Btyp);
7519          end if;
7520
7521          Lit := First_Literal (Btyp);
7522          for J in 1 .. UI_To_Int (Pos) loop
7523             Next_Literal (Lit);
7524          end loop;
7525
7526          return New_Occurrence_Of (Lit, Loc);
7527       end if;
7528    end Get_Enum_Lit_From_Pos;
7529
7530    ------------------------
7531    -- Get_Generic_Entity --
7532    ------------------------
7533
7534    function Get_Generic_Entity (N : Node_Id) return Entity_Id is
7535       Ent : constant Entity_Id := Entity (Name (N));
7536    begin
7537       if Present (Renamed_Object (Ent)) then
7538          return Renamed_Object (Ent);
7539       else
7540          return Ent;
7541       end if;
7542    end Get_Generic_Entity;
7543
7544    -------------------------------------
7545    -- Get_Incomplete_View_Of_Ancestor --
7546    -------------------------------------
7547
7548    function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
7549       Cur_Unit  : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
7550       Par_Scope : Entity_Id;
7551       Par_Type  : Entity_Id;
7552
7553    begin
7554       --  The incomplete view of an ancestor is only relevant for private
7555       --  derived types in child units.
7556
7557       if not Is_Derived_Type (E)
7558         or else not Is_Child_Unit (Cur_Unit)
7559       then
7560          return Empty;
7561
7562       else
7563          Par_Scope := Scope (Cur_Unit);
7564          if No (Par_Scope) then
7565             return Empty;
7566          end if;
7567
7568          Par_Type := Etype (Base_Type (E));
7569
7570          --  Traverse list of ancestor types until we find one declared in
7571          --  a parent or grandparent unit (two levels seem sufficient).
7572
7573          while Present (Par_Type) loop
7574             if Scope (Par_Type) = Par_Scope
7575               or else Scope (Par_Type) = Scope (Par_Scope)
7576             then
7577                return Par_Type;
7578
7579             elsif not Is_Derived_Type (Par_Type) then
7580                return Empty;
7581
7582             else
7583                Par_Type := Etype (Base_Type (Par_Type));
7584             end if;
7585          end loop;
7586
7587          --  If none found, there is no relevant ancestor type.
7588
7589          return Empty;
7590       end if;
7591    end Get_Incomplete_View_Of_Ancestor;
7592
7593    ----------------------
7594    -- Get_Index_Bounds --
7595    ----------------------
7596
7597    procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
7598       Kind : constant Node_Kind := Nkind (N);
7599       R    : Node_Id;
7600
7601    begin
7602       if Kind = N_Range then
7603          L := Low_Bound (N);
7604          H := High_Bound (N);
7605
7606       elsif Kind = N_Subtype_Indication then
7607          R := Range_Expression (Constraint (N));
7608
7609          if R = Error then
7610             L := Error;
7611             H := Error;
7612             return;
7613
7614          else
7615             L := Low_Bound  (Range_Expression (Constraint (N)));
7616             H := High_Bound (Range_Expression (Constraint (N)));
7617          end if;
7618
7619       elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
7620          if Error_Posted (Scalar_Range (Entity (N))) then
7621             L := Error;
7622             H := Error;
7623
7624          elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
7625             Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
7626
7627          else
7628             L := Low_Bound  (Scalar_Range (Entity (N)));
7629             H := High_Bound (Scalar_Range (Entity (N)));
7630          end if;
7631
7632       else
7633          --  N is an expression, indicating a range with one value
7634
7635          L := N;
7636          H := N;
7637       end if;
7638    end Get_Index_Bounds;
7639
7640    ---------------------------------
7641    -- Get_Iterable_Type_Primitive --
7642    ---------------------------------
7643
7644    function Get_Iterable_Type_Primitive
7645      (Typ : Entity_Id;
7646       Nam : Name_Id) return Entity_Id
7647    is
7648       Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
7649       Assoc : Node_Id;
7650
7651    begin
7652       if No (Funcs) then
7653          return Empty;
7654
7655       else
7656          Assoc := First (Component_Associations (Funcs));
7657          while Present (Assoc) loop
7658             if Chars (First (Choices (Assoc))) = Nam then
7659                return Entity (Expression (Assoc));
7660             end if;
7661
7662             Assoc := Next (Assoc);
7663          end loop;
7664
7665          return Empty;
7666       end if;
7667    end Get_Iterable_Type_Primitive;
7668
7669    ----------------------------------
7670    -- Get_Library_Unit_Name_string --
7671    ----------------------------------
7672
7673    procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
7674       Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
7675
7676    begin
7677       Get_Unit_Name_String (Unit_Name_Id);
7678
7679       --  Remove seven last character (" (spec)" or " (body)")
7680
7681       Name_Len := Name_Len - 7;
7682       pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
7683    end Get_Library_Unit_Name_String;
7684
7685    ------------------------
7686    -- Get_Name_Entity_Id --
7687    ------------------------
7688
7689    function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
7690    begin
7691       return Entity_Id (Get_Name_Table_Int (Id));
7692    end Get_Name_Entity_Id;
7693
7694    ------------------------------
7695    -- Get_Name_From_CTC_Pragma --
7696    ------------------------------
7697
7698    function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
7699       Arg : constant Node_Id :=
7700               Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
7701    begin
7702       return Strval (Expr_Value_S (Arg));
7703    end Get_Name_From_CTC_Pragma;
7704
7705    -----------------------
7706    -- Get_Parent_Entity --
7707    -----------------------
7708
7709    function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
7710    begin
7711       if Nkind (Unit) = N_Package_Body
7712         and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
7713       then
7714          return Defining_Entity
7715                   (Specification (Instance_Spec (Original_Node (Unit))));
7716       elsif Nkind (Unit) = N_Package_Instantiation then
7717          return Defining_Entity (Specification (Instance_Spec (Unit)));
7718       else
7719          return Defining_Entity (Unit);
7720       end if;
7721    end Get_Parent_Entity;
7722    -------------------
7723    -- Get_Pragma_Id --
7724    -------------------
7725
7726    function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
7727    begin
7728       return Get_Pragma_Id (Pragma_Name (N));
7729    end Get_Pragma_Id;
7730
7731    -----------------------
7732    -- Get_Reason_String --
7733    -----------------------
7734
7735    procedure Get_Reason_String (N : Node_Id) is
7736    begin
7737       if Nkind (N) = N_String_Literal then
7738          Store_String_Chars (Strval (N));
7739
7740       elsif Nkind (N) = N_Op_Concat then
7741          Get_Reason_String (Left_Opnd (N));
7742          Get_Reason_String (Right_Opnd (N));
7743
7744       --  If not of required form, error
7745
7746       else
7747          Error_Msg_N
7748            ("Reason for pragma Warnings has wrong form", N);
7749          Error_Msg_N
7750            ("\must be string literal or concatenation of string literals", N);
7751          return;
7752       end if;
7753    end Get_Reason_String;
7754
7755    --------------------------------
7756    -- Get_Reference_Discriminant --
7757    --------------------------------
7758
7759    function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
7760       D : Entity_Id;
7761
7762    begin
7763       D := First_Discriminant (Typ);
7764       while Present (D) loop
7765          if Has_Implicit_Dereference (D) then
7766             return D;
7767          end if;
7768          Next_Discriminant (D);
7769       end loop;
7770
7771       return Empty;
7772    end Get_Reference_Discriminant;
7773
7774    ---------------------------
7775    -- Get_Referenced_Object --
7776    ---------------------------
7777
7778    function Get_Referenced_Object (N : Node_Id) return Node_Id is
7779       R : Node_Id;
7780
7781    begin
7782       R := N;
7783       while Is_Entity_Name (R)
7784         and then Present (Renamed_Object (Entity (R)))
7785       loop
7786          R := Renamed_Object (Entity (R));
7787       end loop;
7788
7789       return R;
7790    end Get_Referenced_Object;
7791
7792    ------------------------
7793    -- Get_Renamed_Entity --
7794    ------------------------
7795
7796    function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
7797       R : Entity_Id;
7798
7799    begin
7800       R := E;
7801       while Present (Renamed_Entity (R)) loop
7802          R := Renamed_Entity (R);
7803       end loop;
7804
7805       return R;
7806    end Get_Renamed_Entity;
7807
7808    -----------------------
7809    -- Get_Return_Object --
7810    -----------------------
7811
7812    function Get_Return_Object (N : Node_Id) return Entity_Id is
7813       Decl : Node_Id;
7814
7815    begin
7816       Decl := First (Return_Object_Declarations (N));
7817       while Present (Decl) loop
7818          exit when Nkind (Decl) = N_Object_Declaration
7819            and then Is_Return_Object (Defining_Identifier (Decl));
7820          Next (Decl);
7821       end loop;
7822
7823       pragma Assert (Present (Decl));
7824       return Defining_Identifier (Decl);
7825    end Get_Return_Object;
7826
7827    ---------------------------
7828    -- Get_Subprogram_Entity --
7829    ---------------------------
7830
7831    function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
7832       Subp    : Node_Id;
7833       Subp_Id : Entity_Id;
7834
7835    begin
7836       if Nkind (Nod) = N_Accept_Statement then
7837          Subp := Entry_Direct_Name (Nod);
7838
7839       elsif Nkind (Nod) = N_Slice then
7840          Subp := Prefix (Nod);
7841
7842       else
7843          Subp := Name (Nod);
7844       end if;
7845
7846       --  Strip the subprogram call
7847
7848       loop
7849          if Nkind_In (Subp, N_Explicit_Dereference,
7850                             N_Indexed_Component,
7851                             N_Selected_Component)
7852          then
7853             Subp := Prefix (Subp);
7854
7855          elsif Nkind_In (Subp, N_Type_Conversion,
7856                                N_Unchecked_Type_Conversion)
7857          then
7858             Subp := Expression (Subp);
7859
7860          else
7861             exit;
7862          end if;
7863       end loop;
7864
7865       --  Extract the entity of the subprogram call
7866
7867       if Is_Entity_Name (Subp) then
7868          Subp_Id := Entity (Subp);
7869
7870          if Ekind (Subp_Id) = E_Access_Subprogram_Type then
7871             Subp_Id := Directly_Designated_Type (Subp_Id);
7872          end if;
7873
7874          if Is_Subprogram (Subp_Id) then
7875             return Subp_Id;
7876          else
7877             return Empty;
7878          end if;
7879
7880       --  The search did not find a construct that denotes a subprogram
7881
7882       else
7883          return Empty;
7884       end if;
7885    end Get_Subprogram_Entity;
7886
7887    -----------------------------
7888    -- Get_Task_Body_Procedure --
7889    -----------------------------
7890
7891    function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
7892    begin
7893       --  Note: A task type may be the completion of a private type with
7894       --  discriminants. When performing elaboration checks on a task
7895       --  declaration, the current view of the type may be the private one,
7896       --  and the procedure that holds the body of the task is held in its
7897       --  underlying type.
7898
7899       --  This is an odd function, why not have Task_Body_Procedure do
7900       --  the following digging???
7901
7902       return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
7903    end Get_Task_Body_Procedure;
7904
7905    -------------------------
7906    -- Get_User_Defined_Eq --
7907    -------------------------
7908
7909    function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
7910       Prim : Elmt_Id;
7911       Op   : Entity_Id;
7912
7913    begin
7914       Prim := First_Elmt (Collect_Primitive_Operations (E));
7915       while Present (Prim) loop
7916          Op := Node (Prim);
7917
7918          if Chars (Op) = Name_Op_Eq
7919            and then Etype (Op) = Standard_Boolean
7920            and then Etype (First_Formal (Op)) = E
7921            and then Etype (Next_Formal (First_Formal (Op))) = E
7922          then
7923             return Op;
7924          end if;
7925
7926          Next_Elmt (Prim);
7927       end loop;
7928
7929       return Empty;
7930    end Get_User_Defined_Eq;
7931
7932    -----------------------
7933    -- Has_Access_Values --
7934    -----------------------
7935
7936    function Has_Access_Values (T : Entity_Id) return Boolean is
7937       Typ : constant Entity_Id := Underlying_Type (T);
7938
7939    begin
7940       --  Case of a private type which is not completed yet. This can only
7941       --  happen in the case of a generic format type appearing directly, or
7942       --  as a component of the type to which this function is being applied
7943       --  at the top level. Return False in this case, since we certainly do
7944       --  not know that the type contains access types.
7945
7946       if No (Typ) then
7947          return False;
7948
7949       elsif Is_Access_Type (Typ) then
7950          return True;
7951
7952       elsif Is_Array_Type (Typ) then
7953          return Has_Access_Values (Component_Type (Typ));
7954
7955       elsif Is_Record_Type (Typ) then
7956          declare
7957             Comp : Entity_Id;
7958
7959          begin
7960             --  Loop to Check components
7961
7962             Comp := First_Component_Or_Discriminant (Typ);
7963             while Present (Comp) loop
7964
7965                --  Check for access component, tag field does not count, even
7966                --  though it is implemented internally using an access type.
7967
7968                if Has_Access_Values (Etype (Comp))
7969                  and then Chars (Comp) /= Name_uTag
7970                then
7971                   return True;
7972                end if;
7973
7974                Next_Component_Or_Discriminant (Comp);
7975             end loop;
7976          end;
7977
7978          return False;
7979
7980       else
7981          return False;
7982       end if;
7983    end Has_Access_Values;
7984
7985    ------------------------------
7986    -- Has_Compatible_Alignment --
7987    ------------------------------
7988
7989    function Has_Compatible_Alignment
7990      (Obj  : Entity_Id;
7991       Expr : Node_Id) return Alignment_Result
7992    is
7993       function Has_Compatible_Alignment_Internal
7994         (Obj     : Entity_Id;
7995          Expr    : Node_Id;
7996          Default : Alignment_Result) return Alignment_Result;
7997       --  This is the internal recursive function that actually does the work.
7998       --  There is one additional parameter, which says what the result should
7999       --  be if no alignment information is found, and there is no definite
8000       --  indication of compatible alignments. At the outer level, this is set
8001       --  to Unknown, but for internal recursive calls in the case where types
8002       --  are known to be correct, it is set to Known_Compatible.
8003
8004       ---------------------------------------
8005       -- Has_Compatible_Alignment_Internal --
8006       ---------------------------------------
8007
8008       function Has_Compatible_Alignment_Internal
8009         (Obj     : Entity_Id;
8010          Expr    : Node_Id;
8011          Default : Alignment_Result) return Alignment_Result
8012       is
8013          Result : Alignment_Result := Known_Compatible;
8014          --  Holds the current status of the result. Note that once a value of
8015          --  Known_Incompatible is set, it is sticky and does not get changed
8016          --  to Unknown (the value in Result only gets worse as we go along,
8017          --  never better).
8018
8019          Offs : Uint := No_Uint;
8020          --  Set to a factor of the offset from the base object when Expr is a
8021          --  selected or indexed component, based on Component_Bit_Offset and
8022          --  Component_Size respectively. A negative value is used to represent
8023          --  a value which is not known at compile time.
8024
8025          procedure Check_Prefix;
8026          --  Checks the prefix recursively in the case where the expression
8027          --  is an indexed or selected component.
8028
8029          procedure Set_Result (R : Alignment_Result);
8030          --  If R represents a worse outcome (unknown instead of known
8031          --  compatible, or known incompatible), then set Result to R.
8032
8033          ------------------
8034          -- Check_Prefix --
8035          ------------------
8036
8037          procedure Check_Prefix is
8038          begin
8039             --  The subtlety here is that in doing a recursive call to check
8040             --  the prefix, we have to decide what to do in the case where we
8041             --  don't find any specific indication of an alignment problem.
8042
8043             --  At the outer level, we normally set Unknown as the result in
8044             --  this case, since we can only set Known_Compatible if we really
8045             --  know that the alignment value is OK, but for the recursive
8046             --  call, in the case where the types match, and we have not
8047             --  specified a peculiar alignment for the object, we are only
8048             --  concerned about suspicious rep clauses, the default case does
8049             --  not affect us, since the compiler will, in the absence of such
8050             --  rep clauses, ensure that the alignment is correct.
8051
8052             if Default = Known_Compatible
8053               or else
8054                 (Etype (Obj) = Etype (Expr)
8055                   and then (Unknown_Alignment (Obj)
8056                              or else
8057                                Alignment (Obj) = Alignment (Etype (Obj))))
8058             then
8059                Set_Result
8060                  (Has_Compatible_Alignment_Internal
8061                     (Obj, Prefix (Expr), Known_Compatible));
8062
8063             --  In all other cases, we need a full check on the prefix
8064
8065             else
8066                Set_Result
8067                  (Has_Compatible_Alignment_Internal
8068                     (Obj, Prefix (Expr), Unknown));
8069             end if;
8070          end Check_Prefix;
8071
8072          ----------------
8073          -- Set_Result --
8074          ----------------
8075
8076          procedure Set_Result (R : Alignment_Result) is
8077          begin
8078             if R > Result then
8079                Result := R;
8080             end if;
8081          end Set_Result;
8082
8083       --  Start of processing for Has_Compatible_Alignment_Internal
8084
8085       begin
8086          --  If Expr is a selected component, we must make sure there is no
8087          --  potentially troublesome component clause, and that the record is
8088          --  not packed.
8089
8090          if Nkind (Expr) = N_Selected_Component then
8091
8092             --  Packed record always generate unknown alignment
8093
8094             if Is_Packed (Etype (Prefix (Expr))) then
8095                Set_Result (Unknown);
8096             end if;
8097
8098             --  Check prefix and component offset
8099
8100             Check_Prefix;
8101             Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
8102
8103          --  If Expr is an indexed component, we must make sure there is no
8104          --  potentially troublesome Component_Size clause and that the array
8105          --  is not bit-packed.
8106
8107          elsif Nkind (Expr) = N_Indexed_Component then
8108             declare
8109                Typ : constant Entity_Id := Etype (Prefix (Expr));
8110                Ind : constant Node_Id   := First_Index (Typ);
8111
8112             begin
8113                --  Bit packed array always generates unknown alignment
8114
8115                if Is_Bit_Packed_Array (Typ) then
8116                   Set_Result (Unknown);
8117                end if;
8118
8119                --  Check prefix and component offset
8120
8121                Check_Prefix;
8122                Offs := Component_Size (Typ);
8123
8124                --  Small optimization: compute the full offset when possible
8125
8126                if Offs /= No_Uint
8127                  and then Offs > Uint_0
8128                  and then Present (Ind)
8129                  and then Nkind (Ind) = N_Range
8130                  and then Compile_Time_Known_Value (Low_Bound (Ind))
8131                  and then Compile_Time_Known_Value (First (Expressions (Expr)))
8132                then
8133                   Offs := Offs * (Expr_Value (First (Expressions (Expr)))
8134                                     - Expr_Value (Low_Bound ((Ind))));
8135                end if;
8136             end;
8137          end if;
8138
8139          --  If we have a null offset, the result is entirely determined by
8140          --  the base object and has already been computed recursively.
8141
8142          if Offs = Uint_0 then
8143             null;
8144
8145          --  Case where we know the alignment of the object
8146
8147          elsif Known_Alignment (Obj) then
8148             declare
8149                ObjA : constant Uint := Alignment (Obj);
8150                ExpA : Uint          := No_Uint;
8151                SizA : Uint          := No_Uint;
8152
8153             begin
8154                --  If alignment of Obj is 1, then we are always OK
8155
8156                if ObjA = 1 then
8157                   Set_Result (Known_Compatible);
8158
8159                --  Alignment of Obj is greater than 1, so we need to check
8160
8161                else
8162                   --  If we have an offset, see if it is compatible
8163
8164                   if Offs /= No_Uint and Offs > Uint_0 then
8165                      if Offs mod (System_Storage_Unit * ObjA) /= 0 then
8166                         Set_Result (Known_Incompatible);
8167                      end if;
8168
8169                      --  See if Expr is an object with known alignment
8170
8171                   elsif Is_Entity_Name (Expr)
8172                     and then Known_Alignment (Entity (Expr))
8173                   then
8174                      ExpA := Alignment (Entity (Expr));
8175
8176                      --  Otherwise, we can use the alignment of the type of
8177                      --  Expr given that we already checked for
8178                      --  discombobulating rep clauses for the cases of indexed
8179                      --  and selected components above.
8180
8181                   elsif Known_Alignment (Etype (Expr)) then
8182                      ExpA := Alignment (Etype (Expr));
8183
8184                      --  Otherwise the alignment is unknown
8185
8186                   else
8187                      Set_Result (Default);
8188                   end if;
8189
8190                   --  If we got an alignment, see if it is acceptable
8191
8192                   if ExpA /= No_Uint and then ExpA < ObjA then
8193                      Set_Result (Known_Incompatible);
8194                   end if;
8195
8196                   --  If Expr is not a piece of a larger object, see if size
8197                   --  is given. If so, check that it is not too small for the
8198                   --  required alignment.
8199
8200                   if Offs /= No_Uint then
8201                      null;
8202
8203                      --  See if Expr is an object with known size
8204
8205                   elsif Is_Entity_Name (Expr)
8206                     and then Known_Static_Esize (Entity (Expr))
8207                   then
8208                      SizA := Esize (Entity (Expr));
8209
8210                      --  Otherwise, we check the object size of the Expr type
8211
8212                   elsif Known_Static_Esize (Etype (Expr)) then
8213                      SizA := Esize (Etype (Expr));
8214                   end if;
8215
8216                   --  If we got a size, see if it is a multiple of the Obj
8217                   --  alignment, if not, then the alignment cannot be
8218                   --  acceptable, since the size is always a multiple of the
8219                   --  alignment.
8220
8221                   if SizA /= No_Uint then
8222                      if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
8223                         Set_Result (Known_Incompatible);
8224                      end if;
8225                   end if;
8226                end if;
8227             end;
8228
8229          --  If we do not know required alignment, any non-zero offset is a
8230          --  potential problem (but certainly may be OK, so result is unknown).
8231
8232          elsif Offs /= No_Uint then
8233             Set_Result (Unknown);
8234
8235          --  If we can't find the result by direct comparison of alignment
8236          --  values, then there is still one case that we can determine known
8237          --  result, and that is when we can determine that the types are the
8238          --  same, and no alignments are specified. Then we known that the
8239          --  alignments are compatible, even if we don't know the alignment
8240          --  value in the front end.
8241
8242          elsif Etype (Obj) = Etype (Expr) then
8243
8244             --  Types are the same, but we have to check for possible size
8245             --  and alignments on the Expr object that may make the alignment
8246             --  different, even though the types are the same.
8247
8248             if Is_Entity_Name (Expr) then
8249
8250                --  First check alignment of the Expr object. Any alignment less
8251                --  than Maximum_Alignment is worrisome since this is the case
8252                --  where we do not know the alignment of Obj.
8253
8254                if Known_Alignment (Entity (Expr))
8255                  and then UI_To_Int (Alignment (Entity (Expr))) <
8256                                                     Ttypes.Maximum_Alignment
8257                then
8258                   Set_Result (Unknown);
8259
8260                   --  Now check size of Expr object. Any size that is not an
8261                   --  even multiple of Maximum_Alignment is also worrisome
8262                   --  since it may cause the alignment of the object to be less
8263                   --  than the alignment of the type.
8264
8265                elsif Known_Static_Esize (Entity (Expr))
8266                  and then
8267                    (UI_To_Int (Esize (Entity (Expr))) mod
8268                      (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
8269                                                                         /= 0
8270                then
8271                   Set_Result (Unknown);
8272
8273                   --  Otherwise same type is decisive
8274
8275                else
8276                   Set_Result (Known_Compatible);
8277                end if;
8278             end if;
8279
8280          --  Another case to deal with is when there is an explicit size or
8281          --  alignment clause when the types are not the same. If so, then the
8282          --  result is Unknown. We don't need to do this test if the Default is
8283          --  Unknown, since that result will be set in any case.
8284
8285          elsif Default /= Unknown
8286            and then (Has_Size_Clause      (Etype (Expr))
8287                        or else
8288                      Has_Alignment_Clause (Etype (Expr)))
8289          then
8290             Set_Result (Unknown);
8291
8292          --  If no indication found, set default
8293
8294          else
8295             Set_Result (Default);
8296          end if;
8297
8298          --  Return worst result found
8299
8300          return Result;
8301       end Has_Compatible_Alignment_Internal;
8302
8303    --  Start of processing for Has_Compatible_Alignment
8304
8305    begin
8306       --  If Obj has no specified alignment, then set alignment from the type
8307       --  alignment. Perhaps we should always do this, but for sure we should
8308       --  do it when there is an address clause since we can do more if the
8309       --  alignment is known.
8310
8311       if Unknown_Alignment (Obj) then
8312          Set_Alignment (Obj, Alignment (Etype (Obj)));
8313       end if;
8314
8315       --  Now do the internal call that does all the work
8316
8317       return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown);
8318    end Has_Compatible_Alignment;
8319
8320    ----------------------
8321    -- Has_Declarations --
8322    ----------------------
8323
8324    function Has_Declarations (N : Node_Id) return Boolean is
8325    begin
8326       return Nkind_In (Nkind (N), N_Accept_Statement,
8327                                   N_Block_Statement,
8328                                   N_Compilation_Unit_Aux,
8329                                   N_Entry_Body,
8330                                   N_Package_Body,
8331                                   N_Protected_Body,
8332                                   N_Subprogram_Body,
8333                                   N_Task_Body,
8334                                   N_Package_Specification);
8335    end Has_Declarations;
8336
8337    ---------------------------------
8338    -- Has_Defaulted_Discriminants --
8339    ---------------------------------
8340
8341    function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
8342    begin
8343       return Has_Discriminants (Typ)
8344        and then Present (First_Discriminant (Typ))
8345        and then Present (Discriminant_Default_Value
8346                            (First_Discriminant (Typ)));
8347    end Has_Defaulted_Discriminants;
8348
8349    -------------------
8350    -- Has_Denormals --
8351    -------------------
8352
8353    function Has_Denormals (E : Entity_Id) return Boolean is
8354    begin
8355       return Is_Floating_Point_Type (E) and then Denorm_On_Target;
8356    end Has_Denormals;
8357
8358    -------------------------------------------
8359    -- Has_Discriminant_Dependent_Constraint --
8360    -------------------------------------------
8361
8362    function Has_Discriminant_Dependent_Constraint
8363      (Comp : Entity_Id) return Boolean
8364    is
8365       Comp_Decl  : constant Node_Id := Parent (Comp);
8366       Subt_Indic : Node_Id;
8367       Constr     : Node_Id;
8368       Assn       : Node_Id;
8369
8370    begin
8371       --  Discriminants can't depend on discriminants
8372
8373       if Ekind (Comp) = E_Discriminant then
8374          return False;
8375
8376       else
8377          Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
8378
8379          if Nkind (Subt_Indic) = N_Subtype_Indication then
8380             Constr := Constraint (Subt_Indic);
8381
8382             if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
8383                Assn := First (Constraints (Constr));
8384                while Present (Assn) loop
8385                   case Nkind (Assn) is
8386                      when N_Subtype_Indication |
8387                           N_Range              |
8388                           N_Identifier
8389                        =>
8390                         if Depends_On_Discriminant (Assn) then
8391                            return True;
8392                         end if;
8393
8394                      when N_Discriminant_Association =>
8395                         if Depends_On_Discriminant (Expression (Assn)) then
8396                            return True;
8397                         end if;
8398
8399                      when others =>
8400                         null;
8401                   end case;
8402
8403                   Next (Assn);
8404                end loop;
8405             end if;
8406          end if;
8407       end if;
8408
8409       return False;
8410    end Has_Discriminant_Dependent_Constraint;
8411
8412    --------------------------------------
8413    -- Has_Effectively_Volatile_Profile --
8414    --------------------------------------
8415
8416    function Has_Effectively_Volatile_Profile
8417      (Subp_Id : Entity_Id) return Boolean
8418    is
8419       Formal : Entity_Id;
8420
8421    begin
8422       --  Inspect the formal parameters looking for an effectively volatile
8423       --  type.
8424
8425       Formal := First_Formal (Subp_Id);
8426       while Present (Formal) loop
8427          if Is_Effectively_Volatile (Etype (Formal)) then
8428             return True;
8429          end if;
8430
8431          Next_Formal (Formal);
8432       end loop;
8433
8434       --  Inspect the return type of functions
8435
8436       if Ekind_In (Subp_Id, E_Function, E_Generic_Function)
8437         and then Is_Effectively_Volatile (Etype (Subp_Id))
8438       then
8439          return True;
8440       end if;
8441
8442       return False;
8443    end Has_Effectively_Volatile_Profile;
8444
8445    --------------------------
8446    -- Has_Enabled_Property --
8447    --------------------------
8448
8449    function Has_Enabled_Property
8450      (Item_Id  : Entity_Id;
8451       Property : Name_Id) return Boolean
8452    is
8453       function State_Has_Enabled_Property return Boolean;
8454       --  Determine whether a state denoted by Item_Id has the property enabled
8455
8456       function Variable_Has_Enabled_Property return Boolean;
8457       --  Determine whether a variable denoted by Item_Id has the property
8458       --  enabled.
8459
8460       --------------------------------
8461       -- State_Has_Enabled_Property --
8462       --------------------------------
8463
8464       function State_Has_Enabled_Property return Boolean is
8465          Decl     : constant Node_Id := Parent (Item_Id);
8466          Opt      : Node_Id;
8467          Opt_Nam  : Node_Id;
8468          Prop     : Node_Id;
8469          Prop_Nam : Node_Id;
8470          Props    : Node_Id;
8471
8472       begin
8473          --  The declaration of an external abstract state appears as an
8474          --  extension aggregate. If this is not the case, properties can never
8475          --  be set.
8476
8477          if Nkind (Decl) /= N_Extension_Aggregate then
8478             return False;
8479          end if;
8480
8481          --  When External appears as a simple option, it automatically enables
8482          --  all properties.
8483
8484          Opt := First (Expressions (Decl));
8485          while Present (Opt) loop
8486             if Nkind (Opt) = N_Identifier
8487               and then Chars (Opt) = Name_External
8488             then
8489                return True;
8490             end if;
8491
8492             Next (Opt);
8493          end loop;
8494
8495          --  When External specifies particular properties, inspect those and
8496          --  find the desired one (if any).
8497
8498          Opt := First (Component_Associations (Decl));
8499          while Present (Opt) loop
8500             Opt_Nam := First (Choices (Opt));
8501
8502             if Nkind (Opt_Nam) = N_Identifier
8503               and then Chars (Opt_Nam) = Name_External
8504             then
8505                Props := Expression (Opt);
8506
8507                --  Multiple properties appear as an aggregate
8508
8509                if Nkind (Props) = N_Aggregate then
8510
8511                   --  Simple property form
8512
8513                   Prop := First (Expressions (Props));
8514                   while Present (Prop) loop
8515                      if Chars (Prop) = Property then
8516                         return True;
8517                      end if;
8518
8519                      Next (Prop);
8520                   end loop;
8521
8522                   --  Property with expression form
8523
8524                   Prop := First (Component_Associations (Props));
8525                   while Present (Prop) loop
8526                      Prop_Nam := First (Choices (Prop));
8527
8528                      --  The property can be represented in two ways:
8529                      --      others   => <value>
8530                      --    <property> => <value>
8531
8532                      if Nkind (Prop_Nam) = N_Others_Choice
8533                        or else (Nkind (Prop_Nam) = N_Identifier
8534                                  and then Chars (Prop_Nam) = Property)
8535                      then
8536                         return Is_True (Expr_Value (Expression (Prop)));
8537                      end if;
8538
8539                      Next (Prop);
8540                   end loop;
8541
8542                --  Single property
8543
8544                else
8545                   return Chars (Props) = Property;
8546                end if;
8547             end if;
8548
8549             Next (Opt);
8550          end loop;
8551
8552          return False;
8553       end State_Has_Enabled_Property;
8554
8555       -----------------------------------
8556       -- Variable_Has_Enabled_Property --
8557       -----------------------------------
8558
8559       function Variable_Has_Enabled_Property return Boolean is
8560          function Is_Enabled (Prag : Node_Id) return Boolean;
8561          --  Determine whether property pragma Prag (if present) denotes an
8562          --  enabled property.
8563
8564          ----------------
8565          -- Is_Enabled --
8566          ----------------
8567
8568          function Is_Enabled (Prag : Node_Id) return Boolean is
8569             Arg1 : Node_Id;
8570
8571          begin
8572             if Present (Prag) then
8573                Arg1 := First (Pragma_Argument_Associations (Prag));
8574
8575                --  The pragma has an optional Boolean expression, the related
8576                --  property is enabled only when the expression evaluates to
8577                --  True.
8578
8579                if Present (Arg1) then
8580                   return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
8581
8582                --  Otherwise the lack of expression enables the property by
8583                --  default.
8584
8585                else
8586                   return True;
8587                end if;
8588
8589             --  The property was never set in the first place
8590
8591             else
8592                return False;
8593             end if;
8594          end Is_Enabled;
8595
8596          --  Local variables
8597
8598          AR : constant Node_Id :=
8599                 Get_Pragma (Item_Id, Pragma_Async_Readers);
8600          AW : constant Node_Id :=
8601                 Get_Pragma (Item_Id, Pragma_Async_Writers);
8602          ER : constant Node_Id :=
8603                 Get_Pragma (Item_Id, Pragma_Effective_Reads);
8604          EW : constant Node_Id :=
8605                 Get_Pragma (Item_Id, Pragma_Effective_Writes);
8606
8607       --  Start of processing for Variable_Has_Enabled_Property
8608
8609       begin
8610          --  A non-effectively volatile object can never possess external
8611          --  properties.
8612
8613          if not Is_Effectively_Volatile (Item_Id) then
8614             return False;
8615
8616          --  External properties related to variables come in two flavors -
8617          --  explicit and implicit. The explicit case is characterized by the
8618          --  presence of a property pragma with an optional Boolean flag. The
8619          --  property is enabled when the flag evaluates to True or the flag is
8620          --  missing altogether.
8621
8622          elsif Property = Name_Async_Readers    and then Is_Enabled (AR) then
8623             return True;
8624
8625          elsif Property = Name_Async_Writers    and then Is_Enabled (AW) then
8626             return True;
8627
8628          elsif Property = Name_Effective_Reads  and then Is_Enabled (ER) then
8629             return True;
8630
8631          elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then
8632             return True;
8633
8634          --  The implicit case lacks all property pragmas
8635
8636          elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
8637             return True;
8638
8639          else
8640             return False;
8641          end if;
8642       end Variable_Has_Enabled_Property;
8643
8644    --  Start of processing for Has_Enabled_Property
8645
8646    begin
8647       --  Abstract states and variables have a flexible scheme of specifying
8648       --  external properties.
8649
8650       if Ekind (Item_Id) = E_Abstract_State then
8651          return State_Has_Enabled_Property;
8652
8653       elsif Ekind (Item_Id) = E_Variable then
8654          return Variable_Has_Enabled_Property;
8655
8656       --  Otherwise a property is enabled when the related item is effectively
8657       --  volatile.
8658
8659       else
8660          return Is_Effectively_Volatile (Item_Id);
8661       end if;
8662    end Has_Enabled_Property;
8663
8664    --------------------
8665    -- Has_Infinities --
8666    --------------------
8667
8668    function Has_Infinities (E : Entity_Id) return Boolean is
8669    begin
8670       return
8671         Is_Floating_Point_Type (E)
8672           and then Nkind (Scalar_Range (E)) = N_Range
8673           and then Includes_Infinities (Scalar_Range (E));
8674    end Has_Infinities;
8675
8676    --------------------
8677    -- Has_Interfaces --
8678    --------------------
8679
8680    function Has_Interfaces
8681      (T             : Entity_Id;
8682       Use_Full_View : Boolean := True) return Boolean
8683    is
8684       Typ : Entity_Id := Base_Type (T);
8685
8686    begin
8687       --  Handle concurrent types
8688
8689       if Is_Concurrent_Type (Typ) then
8690          Typ := Corresponding_Record_Type (Typ);
8691       end if;
8692
8693       if not Present (Typ)
8694         or else not Is_Record_Type (Typ)
8695         or else not Is_Tagged_Type (Typ)
8696       then
8697          return False;
8698       end if;
8699
8700       --  Handle private types
8701
8702       if Use_Full_View and then Present (Full_View (Typ)) then
8703          Typ := Full_View (Typ);
8704       end if;
8705
8706       --  Handle concurrent record types
8707
8708       if Is_Concurrent_Record_Type (Typ)
8709         and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
8710       then
8711          return True;
8712       end if;
8713
8714       loop
8715          if Is_Interface (Typ)
8716            or else
8717              (Is_Record_Type (Typ)
8718                and then Present (Interfaces (Typ))
8719                and then not Is_Empty_Elmt_List (Interfaces (Typ)))
8720          then
8721             return True;
8722          end if;
8723
8724          exit when Etype (Typ) = Typ
8725
8726             --  Handle private types
8727
8728             or else (Present (Full_View (Etype (Typ)))
8729                       and then Full_View (Etype (Typ)) = Typ)
8730
8731             --  Protect frontend against wrong sources with cyclic derivations
8732
8733             or else Etype (Typ) = T;
8734
8735          --  Climb to the ancestor type handling private types
8736
8737          if Present (Full_View (Etype (Typ))) then
8738             Typ := Full_View (Etype (Typ));
8739          else
8740             Typ := Etype (Typ);
8741          end if;
8742       end loop;
8743
8744       return False;
8745    end Has_Interfaces;
8746
8747    ---------------------------------
8748    -- Has_No_Obvious_Side_Effects --
8749    ---------------------------------
8750
8751    function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
8752    begin
8753       --  For now, just handle literals, constants, and non-volatile
8754       --  variables and expressions combining these with operators or
8755       --  short circuit forms.
8756
8757       if Nkind (N) in N_Numeric_Or_String_Literal then
8758          return True;
8759
8760       elsif Nkind (N) = N_Character_Literal then
8761          return True;
8762
8763       elsif Nkind (N) in N_Unary_Op then
8764          return Has_No_Obvious_Side_Effects (Right_Opnd (N));
8765
8766       elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
8767          return Has_No_Obvious_Side_Effects (Left_Opnd  (N))
8768                    and then
8769                 Has_No_Obvious_Side_Effects (Right_Opnd (N));
8770
8771       elsif Nkind (N) = N_Expression_With_Actions
8772         and then Is_Empty_List (Actions (N))
8773       then
8774          return Has_No_Obvious_Side_Effects (Expression (N));
8775
8776       elsif Nkind (N) in N_Has_Entity then
8777          return Present (Entity (N))
8778            and then Ekind_In (Entity (N), E_Variable,
8779                                           E_Constant,
8780                                           E_Enumeration_Literal,
8781                                           E_In_Parameter,
8782                                           E_Out_Parameter,
8783                                           E_In_Out_Parameter)
8784            and then not Is_Volatile (Entity (N));
8785
8786       else
8787          return False;
8788       end if;
8789    end Has_No_Obvious_Side_Effects;
8790
8791    ------------------------
8792    -- Has_Null_Exclusion --
8793    ------------------------
8794
8795    function Has_Null_Exclusion (N : Node_Id) return Boolean is
8796    begin
8797       case Nkind (N) is
8798          when N_Access_Definition               |
8799               N_Access_Function_Definition      |
8800               N_Access_Procedure_Definition     |
8801               N_Access_To_Object_Definition     |
8802               N_Allocator                       |
8803               N_Derived_Type_Definition         |
8804               N_Function_Specification          |
8805               N_Subtype_Declaration             =>
8806             return Null_Exclusion_Present (N);
8807
8808          when N_Component_Definition            |
8809               N_Formal_Object_Declaration       |
8810               N_Object_Renaming_Declaration     =>
8811             if Present (Subtype_Mark (N)) then
8812                return Null_Exclusion_Present (N);
8813             else pragma Assert (Present (Access_Definition (N)));
8814                return Null_Exclusion_Present (Access_Definition (N));
8815             end if;
8816
8817          when N_Discriminant_Specification =>
8818             if Nkind (Discriminant_Type (N)) = N_Access_Definition then
8819                return Null_Exclusion_Present (Discriminant_Type (N));
8820             else
8821                return Null_Exclusion_Present (N);
8822             end if;
8823
8824          when N_Object_Declaration =>
8825             if Nkind (Object_Definition (N)) = N_Access_Definition then
8826                return Null_Exclusion_Present (Object_Definition (N));
8827             else
8828                return Null_Exclusion_Present (N);
8829             end if;
8830
8831          when N_Parameter_Specification =>
8832             if Nkind (Parameter_Type (N)) = N_Access_Definition then
8833                return Null_Exclusion_Present (Parameter_Type (N));
8834             else
8835                return Null_Exclusion_Present (N);
8836             end if;
8837
8838          when others =>
8839             return False;
8840
8841       end case;
8842    end Has_Null_Exclusion;
8843
8844    ------------------------
8845    -- Has_Null_Extension --
8846    ------------------------
8847
8848    function Has_Null_Extension (T : Entity_Id) return Boolean is
8849       B     : constant Entity_Id := Base_Type (T);
8850       Comps : Node_Id;
8851       Ext   : Node_Id;
8852
8853    begin
8854       if Nkind (Parent (B)) = N_Full_Type_Declaration
8855         and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
8856       then
8857          Ext := Record_Extension_Part (Type_Definition (Parent (B)));
8858
8859          if Present (Ext) then
8860             if Null_Present (Ext) then
8861                return True;
8862             else
8863                Comps := Component_List (Ext);
8864
8865                --  The null component list is rewritten during analysis to
8866                --  include the parent component. Any other component indicates
8867                --  that the extension was not originally null.
8868
8869                return Null_Present (Comps)
8870                  or else No (Next (First (Component_Items (Comps))));
8871             end if;
8872          else
8873             return False;
8874          end if;
8875
8876       else
8877          return False;
8878       end if;
8879    end Has_Null_Extension;
8880
8881    -------------------------------
8882    -- Has_Overriding_Initialize --
8883    -------------------------------
8884
8885    function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
8886       BT   : constant Entity_Id := Base_Type (T);
8887       P    : Elmt_Id;
8888
8889    begin
8890       if Is_Controlled (BT) then
8891          if Is_RTU (Scope (BT), Ada_Finalization) then
8892             return False;
8893
8894          elsif Present (Primitive_Operations (BT)) then
8895             P := First_Elmt (Primitive_Operations (BT));
8896             while Present (P) loop
8897                declare
8898                   Init : constant Entity_Id := Node (P);
8899                   Formal : constant Entity_Id := First_Formal (Init);
8900                begin
8901                   if Ekind (Init) = E_Procedure
8902                     and then Chars (Init) = Name_Initialize
8903                     and then Comes_From_Source (Init)
8904                     and then Present (Formal)
8905                     and then Etype (Formal) = BT
8906                     and then No (Next_Formal (Formal))
8907                     and then (Ada_Version < Ada_2012
8908                                or else not Null_Present (Parent (Init)))
8909                   then
8910                      return True;
8911                   end if;
8912                end;
8913
8914                Next_Elmt (P);
8915             end loop;
8916          end if;
8917
8918          --  Here if type itself does not have a non-null Initialize operation:
8919          --  check immediate ancestor.
8920
8921          if Is_Derived_Type (BT)
8922            and then Has_Overriding_Initialize (Etype (BT))
8923          then
8924             return True;
8925          end if;
8926       end if;
8927
8928       return False;
8929    end Has_Overriding_Initialize;
8930
8931    --------------------------------------
8932    -- Has_Preelaborable_Initialization --
8933    --------------------------------------
8934
8935    function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
8936       Has_PE : Boolean;
8937
8938       procedure Check_Components (E : Entity_Id);
8939       --  Check component/discriminant chain, sets Has_PE False if a component
8940       --  or discriminant does not meet the preelaborable initialization rules.
8941
8942       ----------------------
8943       -- Check_Components --
8944       ----------------------
8945
8946       procedure Check_Components (E : Entity_Id) is
8947          Ent : Entity_Id;
8948          Exp : Node_Id;
8949
8950          function Is_Preelaborable_Expression (N : Node_Id) return Boolean;
8951          --  Returns True if and only if the expression denoted by N does not
8952          --  violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
8953
8954          ---------------------------------
8955          -- Is_Preelaborable_Expression --
8956          ---------------------------------
8957
8958          function Is_Preelaborable_Expression (N : Node_Id) return Boolean is
8959             Exp           : Node_Id;
8960             Assn          : Node_Id;
8961             Choice        : Node_Id;
8962             Comp_Type     : Entity_Id;
8963             Is_Array_Aggr : Boolean;
8964
8965          begin
8966             if Is_OK_Static_Expression (N) then
8967                return True;
8968
8969             elsif Nkind (N) = N_Null then
8970                return True;
8971
8972             --  Attributes are allowed in general, even if their prefix is a
8973             --  formal type. (It seems that certain attributes known not to be
8974             --  static might not be allowed, but there are no rules to prevent
8975             --  them.)
8976
8977             elsif Nkind (N) = N_Attribute_Reference then
8978                return True;
8979
8980             --  The name of a discriminant evaluated within its parent type is
8981             --  defined to be preelaborable (10.2.1(8)). Note that we test for
8982             --  names that denote discriminals as well as discriminants to
8983             --  catch references occurring within init procs.
8984
8985             elsif Is_Entity_Name (N)
8986               and then
8987                 (Ekind (Entity (N)) = E_Discriminant
8988                   or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter)
8989                             and then Present (Discriminal_Link (Entity (N)))))
8990             then
8991                return True;
8992
8993             elsif Nkind (N) = N_Qualified_Expression then
8994                return Is_Preelaborable_Expression (Expression (N));
8995
8996             --  For aggregates we have to check that each of the associations
8997             --  is preelaborable.
8998
8999             elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
9000                Is_Array_Aggr := Is_Array_Type (Etype (N));
9001
9002                if Is_Array_Aggr then
9003                   Comp_Type := Component_Type (Etype (N));
9004                end if;
9005
9006                --  Check the ancestor part of extension aggregates, which must
9007                --  be either the name of a type that has preelaborable init or
9008                --  an expression that is preelaborable.
9009
9010                if Nkind (N) = N_Extension_Aggregate then
9011                   declare
9012                      Anc_Part : constant Node_Id := Ancestor_Part (N);
9013
9014                   begin
9015                      if Is_Entity_Name (Anc_Part)
9016                        and then Is_Type (Entity (Anc_Part))
9017                      then
9018                         if not Has_Preelaborable_Initialization
9019                                  (Entity (Anc_Part))
9020                         then
9021                            return False;
9022                         end if;
9023
9024                      elsif not Is_Preelaborable_Expression (Anc_Part) then
9025                         return False;
9026                      end if;
9027                   end;
9028                end if;
9029
9030                --  Check positional associations
9031
9032                Exp := First (Expressions (N));
9033                while Present (Exp) loop
9034                   if not Is_Preelaborable_Expression (Exp) then
9035                      return False;
9036                   end if;
9037
9038                   Next (Exp);
9039                end loop;
9040
9041                --  Check named associations
9042
9043                Assn := First (Component_Associations (N));
9044                while Present (Assn) loop
9045                   Choice := First (Choices (Assn));
9046                   while Present (Choice) loop
9047                      if Is_Array_Aggr then
9048                         if Nkind (Choice) = N_Others_Choice then
9049                            null;
9050
9051                         elsif Nkind (Choice) = N_Range then
9052                            if not Is_OK_Static_Range (Choice) then
9053                               return False;
9054                            end if;
9055
9056                         elsif not Is_OK_Static_Expression (Choice) then
9057                            return False;
9058                         end if;
9059
9060                      else
9061                         Comp_Type := Etype (Choice);
9062                      end if;
9063
9064                      Next (Choice);
9065                   end loop;
9066
9067                   --  If the association has a <> at this point, then we have
9068                   --  to check whether the component's type has preelaborable
9069                   --  initialization. Note that this only occurs when the
9070                   --  association's corresponding component does not have a
9071                   --  default expression, the latter case having already been
9072                   --  expanded as an expression for the association.
9073
9074                   if Box_Present (Assn) then
9075                      if not Has_Preelaborable_Initialization (Comp_Type) then
9076                         return False;
9077                      end if;
9078
9079                   --  In the expression case we check whether the expression
9080                   --  is preelaborable.
9081
9082                   elsif
9083                     not Is_Preelaborable_Expression (Expression (Assn))
9084                   then
9085                      return False;
9086                   end if;
9087
9088                   Next (Assn);
9089                end loop;
9090
9091                --  If we get here then aggregate as a whole is preelaborable
9092
9093                return True;
9094
9095             --  All other cases are not preelaborable
9096
9097             else
9098                return False;
9099             end if;
9100          end Is_Preelaborable_Expression;
9101
9102       --  Start of processing for Check_Components
9103
9104       begin
9105          --  Loop through entities of record or protected type
9106
9107          Ent := E;
9108          while Present (Ent) loop
9109
9110             --  We are interested only in components and discriminants
9111
9112             Exp := Empty;
9113
9114             case Ekind (Ent) is
9115                when E_Component =>
9116
9117                   --  Get default expression if any. If there is no declaration
9118                   --  node, it means we have an internal entity. The parent and
9119                   --  tag fields are examples of such entities. For such cases,
9120                   --  we just test the type of the entity.
9121
9122                   if Present (Declaration_Node (Ent)) then
9123                      Exp := Expression (Declaration_Node (Ent));
9124                   end if;
9125
9126                when E_Discriminant =>
9127
9128                   --  Note: for a renamed discriminant, the Declaration_Node
9129                   --  may point to the one from the ancestor, and have a
9130                   --  different expression, so use the proper attribute to
9131                   --  retrieve the expression from the derived constraint.
9132
9133                   Exp := Discriminant_Default_Value (Ent);
9134
9135                when others =>
9136                   goto Check_Next_Entity;
9137             end case;
9138
9139             --  A component has PI if it has no default expression and the
9140             --  component type has PI.
9141
9142             if No (Exp) then
9143                if not Has_Preelaborable_Initialization (Etype (Ent)) then
9144                   Has_PE := False;
9145                   exit;
9146                end if;
9147
9148             --  Require the default expression to be preelaborable
9149
9150             elsif not Is_Preelaborable_Expression (Exp) then
9151                Has_PE := False;
9152                exit;
9153             end if;
9154
9155          <<Check_Next_Entity>>
9156             Next_Entity (Ent);
9157          end loop;
9158       end Check_Components;
9159
9160    --  Start of processing for Has_Preelaborable_Initialization
9161
9162    begin
9163       --  Immediate return if already marked as known preelaborable init. This
9164       --  covers types for which this function has already been called once
9165       --  and returned True (in which case the result is cached), and also
9166       --  types to which a pragma Preelaborable_Initialization applies.
9167
9168       if Known_To_Have_Preelab_Init (E) then
9169          return True;
9170       end if;
9171
9172       --  If the type is a subtype representing a generic actual type, then
9173       --  test whether its base type has preelaborable initialization since
9174       --  the subtype representing the actual does not inherit this attribute
9175       --  from the actual or formal. (but maybe it should???)
9176
9177       if Is_Generic_Actual_Type (E) then
9178          return Has_Preelaborable_Initialization (Base_Type (E));
9179       end if;
9180
9181       --  All elementary types have preelaborable initialization
9182
9183       if Is_Elementary_Type (E) then
9184          Has_PE := True;
9185
9186       --  Array types have PI if the component type has PI
9187
9188       elsif Is_Array_Type (E) then
9189          Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
9190
9191       --  A derived type has preelaborable initialization if its parent type
9192       --  has preelaborable initialization and (in the case of a derived record
9193       --  extension) if the non-inherited components all have preelaborable
9194       --  initialization. However, a user-defined controlled type with an
9195       --  overriding Initialize procedure does not have preelaborable
9196       --  initialization.
9197
9198       elsif Is_Derived_Type (E) then
9199
9200          --  If the derived type is a private extension then it doesn't have
9201          --  preelaborable initialization.
9202
9203          if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
9204             return False;
9205          end if;
9206
9207          --  First check whether ancestor type has preelaborable initialization
9208
9209          Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
9210
9211          --  If OK, check extension components (if any)
9212
9213          if Has_PE and then Is_Record_Type (E) then
9214             Check_Components (First_Entity (E));
9215          end if;
9216
9217          --  Check specifically for 10.2.1(11.4/2) exception: a controlled type
9218          --  with a user defined Initialize procedure does not have PI. If
9219          --  the type is untagged, the control primitives come from a component
9220          --  that has already been checked.
9221
9222          if Has_PE
9223            and then Is_Controlled (E)
9224            and then Is_Tagged_Type (E)
9225            and then Has_Overriding_Initialize (E)
9226          then
9227             Has_PE := False;
9228          end if;
9229
9230       --  Private types not derived from a type having preelaborable init and
9231       --  that are not marked with pragma Preelaborable_Initialization do not
9232       --  have preelaborable initialization.
9233
9234       elsif Is_Private_Type (E) then
9235          return False;
9236
9237       --  Record type has PI if it is non private and all components have PI
9238
9239       elsif Is_Record_Type (E) then
9240          Has_PE := True;
9241          Check_Components (First_Entity (E));
9242
9243       --  Protected types must not have entries, and components must meet
9244       --  same set of rules as for record components.
9245
9246       elsif Is_Protected_Type (E) then
9247          if Has_Entries (E) then
9248             Has_PE := False;
9249          else
9250             Has_PE := True;
9251             Check_Components (First_Entity (E));
9252             Check_Components (First_Private_Entity (E));
9253          end if;
9254
9255       --  Type System.Address always has preelaborable initialization
9256
9257       elsif Is_RTE (E, RE_Address) then
9258          Has_PE := True;
9259
9260       --  In all other cases, type does not have preelaborable initialization
9261
9262       else
9263          return False;
9264       end if;
9265
9266       --  If type has preelaborable initialization, cache result
9267
9268       if Has_PE then
9269          Set_Known_To_Have_Preelab_Init (E);
9270       end if;
9271
9272       return Has_PE;
9273    end Has_Preelaborable_Initialization;
9274
9275    ---------------------------
9276    -- Has_Private_Component --
9277    ---------------------------
9278
9279    function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
9280       Btype     : Entity_Id := Base_Type (Type_Id);
9281       Component : Entity_Id;
9282
9283    begin
9284       if Error_Posted (Type_Id)
9285         or else Error_Posted (Btype)
9286       then
9287          return False;
9288       end if;
9289
9290       if Is_Class_Wide_Type (Btype) then
9291          Btype := Root_Type (Btype);
9292       end if;
9293
9294       if Is_Private_Type (Btype) then
9295          declare
9296             UT : constant Entity_Id := Underlying_Type (Btype);
9297          begin
9298             if No (UT) then
9299                if No (Full_View (Btype)) then
9300                   return not Is_Generic_Type (Btype)
9301                             and then
9302                          not Is_Generic_Type (Root_Type (Btype));
9303                else
9304                   return not Is_Generic_Type (Root_Type (Full_View (Btype)));
9305                end if;
9306             else
9307                return not Is_Frozen (UT) and then Has_Private_Component (UT);
9308             end if;
9309          end;
9310
9311       elsif Is_Array_Type (Btype) then
9312          return Has_Private_Component (Component_Type (Btype));
9313
9314       elsif Is_Record_Type (Btype) then
9315          Component := First_Component (Btype);
9316          while Present (Component) loop
9317             if Has_Private_Component (Etype (Component)) then
9318                return True;
9319             end if;
9320
9321             Next_Component (Component);
9322          end loop;
9323
9324          return False;
9325
9326       elsif Is_Protected_Type (Btype)
9327         and then Present (Corresponding_Record_Type (Btype))
9328       then
9329          return Has_Private_Component (Corresponding_Record_Type (Btype));
9330
9331       else
9332          return False;
9333       end if;
9334    end Has_Private_Component;
9335
9336    ----------------------
9337    -- Has_Signed_Zeros --
9338    ----------------------
9339
9340    function Has_Signed_Zeros (E : Entity_Id) return Boolean is
9341    begin
9342       return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
9343    end Has_Signed_Zeros;
9344
9345    ------------------------------
9346    -- Has_Significant_Contract --
9347    ------------------------------
9348
9349    function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
9350       Subp_Nam : constant Name_Id := Chars (Subp_Id);
9351
9352    begin
9353       --  _Finalizer procedure
9354
9355       if Subp_Nam = Name_uFinalizer then
9356          return False;
9357
9358       --  _Postconditions procedure
9359
9360       elsif Subp_Nam = Name_uPostconditions then
9361          return False;
9362
9363       --  Predicate function
9364
9365       elsif Ekind (Subp_Id) = E_Function
9366         and then Is_Predicate_Function (Subp_Id)
9367       then
9368          return False;
9369
9370       --  TSS subprogram
9371
9372       elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
9373          return False;
9374
9375       else
9376          return True;
9377       end if;
9378    end Has_Significant_Contract;
9379
9380    -----------------------------
9381    -- Has_Static_Array_Bounds --
9382    -----------------------------
9383
9384    function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
9385       Ndims : constant Nat := Number_Dimensions (Typ);
9386
9387       Index : Node_Id;
9388       Low   : Node_Id;
9389       High  : Node_Id;
9390
9391    begin
9392       --  Unconstrained types do not have static bounds
9393
9394       if not Is_Constrained (Typ) then
9395          return False;
9396       end if;
9397
9398       --  First treat string literals specially, as the lower bound and length
9399       --  of string literals are not stored like those of arrays.
9400
9401       --  A string literal always has static bounds
9402
9403       if Ekind (Typ) = E_String_Literal_Subtype then
9404          return True;
9405       end if;
9406
9407       --  Treat all dimensions in turn
9408
9409       Index := First_Index (Typ);
9410       for Indx in 1 .. Ndims loop
9411
9412          --  In case of an illegal index which is not a discrete type, return
9413          --  that the type is not static.
9414
9415          if not Is_Discrete_Type (Etype (Index))
9416            or else Etype (Index) = Any_Type
9417          then
9418             return False;
9419          end if;
9420
9421          Get_Index_Bounds (Index, Low, High);
9422
9423          if Error_Posted (Low) or else Error_Posted (High) then
9424             return False;
9425          end if;
9426
9427          if Is_OK_Static_Expression (Low)
9428               and then
9429             Is_OK_Static_Expression (High)
9430          then
9431             null;
9432          else
9433             return False;
9434          end if;
9435
9436          Next (Index);
9437       end loop;
9438
9439       --  If we fall through the loop, all indexes matched
9440
9441       return True;
9442    end Has_Static_Array_Bounds;
9443
9444    ----------------
9445    -- Has_Stream --
9446    ----------------
9447
9448    function Has_Stream (T : Entity_Id) return Boolean is
9449       E : Entity_Id;
9450
9451    begin
9452       if No (T) then
9453          return False;
9454
9455       elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
9456          return True;
9457
9458       elsif Is_Array_Type (T) then
9459          return Has_Stream (Component_Type (T));
9460
9461       elsif Is_Record_Type (T) then
9462          E := First_Component (T);
9463          while Present (E) loop
9464             if Has_Stream (Etype (E)) then
9465                return True;
9466             else
9467                Next_Component (E);
9468             end if;
9469          end loop;
9470
9471          return False;
9472
9473       elsif Is_Private_Type (T) then
9474          return Has_Stream (Underlying_Type (T));
9475
9476       else
9477          return False;
9478       end if;
9479    end Has_Stream;
9480
9481    ----------------
9482    -- Has_Suffix --
9483    ----------------
9484
9485    function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
9486    begin
9487       Get_Name_String (Chars (E));
9488       return Name_Buffer (Name_Len) = Suffix;
9489    end Has_Suffix;
9490
9491    ----------------
9492    -- Add_Suffix --
9493    ----------------
9494
9495    function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
9496    begin
9497       Get_Name_String (Chars (E));
9498       Add_Char_To_Name_Buffer (Suffix);
9499       return Name_Find;
9500    end Add_Suffix;
9501
9502    -------------------
9503    -- Remove_Suffix --
9504    -------------------
9505
9506    function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
9507    begin
9508       pragma Assert (Has_Suffix (E, Suffix));
9509       Get_Name_String (Chars (E));
9510       Name_Len := Name_Len - 1;
9511       return Name_Find;
9512    end Remove_Suffix;
9513
9514    --------------------------
9515    -- Has_Tagged_Component --
9516    --------------------------
9517
9518    function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
9519       Comp : Entity_Id;
9520
9521    begin
9522       if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
9523          return Has_Tagged_Component (Underlying_Type (Typ));
9524
9525       elsif Is_Array_Type (Typ) then
9526          return Has_Tagged_Component (Component_Type (Typ));
9527
9528       elsif Is_Tagged_Type (Typ) then
9529          return True;
9530
9531       elsif Is_Record_Type (Typ) then
9532          Comp := First_Component (Typ);
9533          while Present (Comp) loop
9534             if Has_Tagged_Component (Etype (Comp)) then
9535                return True;
9536             end if;
9537
9538             Next_Component (Comp);
9539          end loop;
9540
9541          return False;
9542
9543       else
9544          return False;
9545       end if;
9546    end Has_Tagged_Component;
9547
9548    ----------------------------
9549    -- Has_Volatile_Component --
9550    ----------------------------
9551
9552    function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
9553       Comp : Entity_Id;
9554
9555    begin
9556       if Has_Volatile_Components (Typ) then
9557          return True;
9558
9559       elsif Is_Array_Type (Typ) then
9560          return Is_Volatile (Component_Type (Typ));
9561
9562       elsif Is_Record_Type (Typ) then
9563          Comp := First_Component (Typ);
9564          while Present (Comp) loop
9565             if Is_Volatile_Object (Comp) then
9566                return True;
9567             end if;
9568
9569             Comp := Next_Component (Comp);
9570          end loop;
9571       end if;
9572
9573       return False;
9574    end Has_Volatile_Component;
9575
9576    -------------------------
9577    -- Implementation_Kind --
9578    -------------------------
9579
9580    function Implementation_Kind (Subp : Entity_Id) return Name_Id is
9581       Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
9582       Arg       : Node_Id;
9583    begin
9584       pragma Assert (Present (Impl_Prag));
9585       Arg := Last (Pragma_Argument_Associations (Impl_Prag));
9586       return Chars (Get_Pragma_Arg (Arg));
9587    end Implementation_Kind;
9588
9589    --------------------------
9590    -- Implements_Interface --
9591    --------------------------
9592
9593    function Implements_Interface
9594      (Typ_Ent         : Entity_Id;
9595       Iface_Ent       : Entity_Id;
9596       Exclude_Parents : Boolean := False) return Boolean
9597    is
9598       Ifaces_List : Elist_Id;
9599       Elmt        : Elmt_Id;
9600       Iface       : Entity_Id := Base_Type (Iface_Ent);
9601       Typ         : Entity_Id := Base_Type (Typ_Ent);
9602
9603    begin
9604       if Is_Class_Wide_Type (Typ) then
9605          Typ := Root_Type (Typ);
9606       end if;
9607
9608       if not Has_Interfaces (Typ) then
9609          return False;
9610       end if;
9611
9612       if Is_Class_Wide_Type (Iface) then
9613          Iface := Root_Type (Iface);
9614       end if;
9615
9616       Collect_Interfaces (Typ, Ifaces_List);
9617
9618       Elmt := First_Elmt (Ifaces_List);
9619       while Present (Elmt) loop
9620          if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
9621            and then Exclude_Parents
9622          then
9623             null;
9624
9625          elsif Node (Elmt) = Iface then
9626             return True;
9627          end if;
9628
9629          Next_Elmt (Elmt);
9630       end loop;
9631
9632       return False;
9633    end Implements_Interface;
9634
9635    ------------------------------------
9636    -- In_Assertion_Expression_Pragma --
9637    ------------------------------------
9638
9639    function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
9640       Par  : Node_Id;
9641       Prag : Node_Id := Empty;
9642
9643    begin
9644       --  Climb the parent chain looking for an enclosing pragma
9645
9646       Par := N;
9647       while Present (Par) loop
9648          if Nkind (Par) = N_Pragma then
9649             Prag := Par;
9650             exit;
9651
9652          --  Precondition-like pragmas are expanded into if statements, check
9653          --  the original node instead.
9654
9655          elsif Nkind (Original_Node (Par)) = N_Pragma then
9656             Prag := Original_Node (Par);
9657             exit;
9658
9659          --  The expansion of attribute 'Old generates a constant to capture
9660          --  the result of the prefix. If the parent traversal reaches
9661          --  one of these constants, then the node technically came from a
9662          --  postcondition-like pragma. Note that the Ekind is not tested here
9663          --  because N may be the expression of an object declaration which is
9664          --  currently being analyzed. Such objects carry Ekind of E_Void.
9665
9666          elsif Nkind (Par) = N_Object_Declaration
9667            and then Constant_Present (Par)
9668            and then Stores_Attribute_Old_Prefix (Defining_Entity (Par))
9669          then
9670             return True;
9671
9672          --  Prevent the search from going too far
9673
9674          elsif Is_Body_Or_Package_Declaration (Par) then
9675             return False;
9676          end if;
9677
9678          Par := Parent (Par);
9679       end loop;
9680
9681       return
9682         Present (Prag)
9683           and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
9684    end In_Assertion_Expression_Pragma;
9685
9686    -----------------
9687    -- In_Instance --
9688    -----------------
9689
9690    function In_Instance return Boolean is
9691       Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
9692       S         : Entity_Id;
9693
9694    begin
9695       S := Current_Scope;
9696       while Present (S) and then S /= Standard_Standard loop
9697          if Ekind_In (S, E_Function, E_Package, E_Procedure)
9698            and then Is_Generic_Instance (S)
9699          then
9700             --  A child instance is always compiled in the context of a parent
9701             --  instance. Nevertheless, the actuals are not analyzed in an
9702             --  instance context. We detect this case by examining the current
9703             --  compilation unit, which must be a child instance, and checking
9704             --  that it is not currently on the scope stack.
9705
9706             if Is_Child_Unit (Curr_Unit)
9707               and then Nkind (Unit (Cunit (Current_Sem_Unit))) =
9708                                                      N_Package_Instantiation
9709               and then not In_Open_Scopes (Curr_Unit)
9710             then
9711                return False;
9712             else
9713                return True;
9714             end if;
9715          end if;
9716
9717          S := Scope (S);
9718       end loop;
9719
9720       return False;
9721    end In_Instance;
9722
9723    ----------------------
9724    -- In_Instance_Body --
9725    ----------------------
9726
9727    function In_Instance_Body return Boolean is
9728       S : Entity_Id;
9729
9730    begin
9731       S := Current_Scope;
9732       while Present (S) and then S /= Standard_Standard loop
9733          if Ekind_In (S, E_Function, E_Procedure)
9734            and then Is_Generic_Instance (S)
9735          then
9736             return True;
9737
9738          elsif Ekind (S) = E_Package
9739            and then In_Package_Body (S)
9740            and then Is_Generic_Instance (S)
9741          then
9742             return True;
9743          end if;
9744
9745          S := Scope (S);
9746       end loop;
9747
9748       return False;
9749    end In_Instance_Body;
9750
9751    -----------------------------
9752    -- In_Instance_Not_Visible --
9753    -----------------------------
9754
9755    function In_Instance_Not_Visible return Boolean is
9756       S : Entity_Id;
9757
9758    begin
9759       S := Current_Scope;
9760       while Present (S) and then S /= Standard_Standard loop
9761          if Ekind_In (S, E_Function, E_Procedure)
9762            and then Is_Generic_Instance (S)
9763          then
9764             return True;
9765
9766          elsif Ekind (S) = E_Package
9767            and then (In_Package_Body (S) or else In_Private_Part (S))
9768            and then Is_Generic_Instance (S)
9769          then
9770             return True;
9771          end if;
9772
9773          S := Scope (S);
9774       end loop;
9775
9776       return False;
9777    end In_Instance_Not_Visible;
9778
9779    ------------------------------
9780    -- In_Instance_Visible_Part --
9781    ------------------------------
9782
9783    function In_Instance_Visible_Part return Boolean is
9784       S : Entity_Id;
9785
9786    begin
9787       S := Current_Scope;
9788       while Present (S) and then S /= Standard_Standard loop
9789          if Ekind (S) = E_Package
9790            and then Is_Generic_Instance (S)
9791            and then not In_Package_Body (S)
9792            and then not In_Private_Part (S)
9793          then
9794             return True;
9795          end if;
9796
9797          S := Scope (S);
9798       end loop;
9799
9800       return False;
9801    end In_Instance_Visible_Part;
9802
9803    ---------------------
9804    -- In_Package_Body --
9805    ---------------------
9806
9807    function In_Package_Body return Boolean is
9808       S : Entity_Id;
9809
9810    begin
9811       S := Current_Scope;
9812       while Present (S) and then S /= Standard_Standard loop
9813          if Ekind (S) = E_Package and then In_Package_Body (S) then
9814             return True;
9815          else
9816             S := Scope (S);
9817          end if;
9818       end loop;
9819
9820       return False;
9821    end In_Package_Body;
9822
9823    --------------------------------
9824    -- In_Parameter_Specification --
9825    --------------------------------
9826
9827    function In_Parameter_Specification (N : Node_Id) return Boolean is
9828       PN : Node_Id;
9829
9830    begin
9831       PN := Parent (N);
9832       while Present (PN) loop
9833          if Nkind (PN) = N_Parameter_Specification then
9834             return True;
9835          end if;
9836
9837          PN := Parent (PN);
9838       end loop;
9839
9840       return False;
9841    end In_Parameter_Specification;
9842
9843    --------------------------
9844    -- In_Pragma_Expression --
9845    --------------------------
9846
9847    function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean is
9848       P : Node_Id;
9849    begin
9850       P := Parent (N);
9851       loop
9852          if No (P) then
9853             return False;
9854          elsif Nkind (P) = N_Pragma and then Pragma_Name (P) = Nam then
9855             return True;
9856          else
9857             P := Parent (P);
9858          end if;
9859       end loop;
9860    end In_Pragma_Expression;
9861
9862    -------------------------------------
9863    -- In_Reverse_Storage_Order_Object --
9864    -------------------------------------
9865
9866    function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean is
9867       Pref : Node_Id;
9868       Btyp : Entity_Id := Empty;
9869
9870    begin
9871       --  Climb up indexed components
9872
9873       Pref := N;
9874       loop
9875          case Nkind (Pref) is
9876             when N_Selected_Component =>
9877                Pref := Prefix (Pref);
9878                exit;
9879
9880             when N_Indexed_Component =>
9881                Pref := Prefix (Pref);
9882
9883             when others =>
9884                Pref := Empty;
9885                exit;
9886          end case;
9887       end loop;
9888
9889       if Present (Pref) then
9890          Btyp := Base_Type (Etype (Pref));
9891       end if;
9892
9893       return Present (Btyp)
9894         and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp))
9895         and then Reverse_Storage_Order (Btyp);
9896    end In_Reverse_Storage_Order_Object;
9897
9898    --------------------------------------
9899    -- In_Subprogram_Or_Concurrent_Unit --
9900    --------------------------------------
9901
9902    function In_Subprogram_Or_Concurrent_Unit return Boolean is
9903       E : Entity_Id;
9904       K : Entity_Kind;
9905
9906    begin
9907       --  Use scope chain to check successively outer scopes
9908
9909       E := Current_Scope;
9910       loop
9911          K := Ekind (E);
9912
9913          if K in Subprogram_Kind
9914            or else K in Concurrent_Kind
9915            or else K in Generic_Subprogram_Kind
9916          then
9917             return True;
9918
9919          elsif E = Standard_Standard then
9920             return False;
9921          end if;
9922
9923          E := Scope (E);
9924       end loop;
9925    end In_Subprogram_Or_Concurrent_Unit;
9926
9927    ---------------------
9928    -- In_Visible_Part --
9929    ---------------------
9930
9931    function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
9932    begin
9933       return Is_Package_Or_Generic_Package (Scope_Id)
9934         and then In_Open_Scopes (Scope_Id)
9935         and then not In_Package_Body (Scope_Id)
9936         and then not In_Private_Part (Scope_Id);
9937    end In_Visible_Part;
9938
9939    --------------------------------
9940    -- Incomplete_Or_Partial_View --
9941    --------------------------------
9942
9943    function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is
9944       function Inspect_Decls
9945         (Decls : List_Id;
9946          Taft  : Boolean := False) return Entity_Id;
9947       --  Check whether a declarative region contains the incomplete or partial
9948       --  view of Id.
9949
9950       -------------------
9951       -- Inspect_Decls --
9952       -------------------
9953
9954       function Inspect_Decls
9955         (Decls : List_Id;
9956          Taft  : Boolean := False) return Entity_Id
9957       is
9958          Decl  : Node_Id;
9959          Match : Node_Id;
9960
9961       begin
9962          Decl := First (Decls);
9963          while Present (Decl) loop
9964             Match := Empty;
9965
9966             if Taft then
9967                if Nkind (Decl) = N_Incomplete_Type_Declaration then
9968                   Match := Defining_Identifier (Decl);
9969                end if;
9970
9971             else
9972                if Nkind_In (Decl, N_Private_Extension_Declaration,
9973                                   N_Private_Type_Declaration)
9974                then
9975                   Match := Defining_Identifier (Decl);
9976                end if;
9977             end if;
9978
9979             if Present (Match)
9980               and then Present (Full_View (Match))
9981               and then Full_View (Match) = Id
9982             then
9983                return Match;
9984             end if;
9985
9986             Next (Decl);
9987          end loop;
9988
9989          return Empty;
9990       end Inspect_Decls;
9991
9992       --  Local variables
9993
9994       Prev : Entity_Id;
9995
9996    --  Start of processing for Incomplete_Or_Partial_View
9997
9998    begin
9999       --  Deferred constant or incomplete type case
10000
10001       Prev := Current_Entity_In_Scope (Id);
10002
10003       if Present (Prev)
10004         and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant)
10005         and then Present (Full_View (Prev))
10006         and then Full_View (Prev) = Id
10007       then
10008          return Prev;
10009       end if;
10010
10011       --  Private or Taft amendment type case
10012
10013       declare
10014          Pkg      : constant Entity_Id := Scope (Id);
10015          Pkg_Decl : Node_Id := Pkg;
10016
10017       begin
10018          if Present (Pkg) and then Ekind (Pkg) = E_Package then
10019             while Nkind (Pkg_Decl) /= N_Package_Specification loop
10020                Pkg_Decl := Parent (Pkg_Decl);
10021             end loop;
10022
10023             --  It is knows that Typ has a private view, look for it in the
10024             --  visible declarations of the enclosing scope. A special case
10025             --  of this is when the two views have been exchanged - the full
10026             --  appears earlier than the private.
10027
10028             if Has_Private_Declaration (Id) then
10029                Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl));
10030
10031                --  Exchanged view case, look in the private declarations
10032
10033                if No (Prev) then
10034                   Prev := Inspect_Decls (Private_Declarations (Pkg_Decl));
10035                end if;
10036
10037                return Prev;
10038
10039             --  Otherwise if this is the package body, then Typ is a potential
10040             --  Taft amendment type. The incomplete view should be located in
10041             --  the private declarations of the enclosing scope.
10042
10043             elsif In_Package_Body (Pkg) then
10044                return Inspect_Decls (Private_Declarations (Pkg_Decl), True);
10045             end if;
10046          end if;
10047       end;
10048
10049       --  The type has no incomplete or private view
10050
10051       return Empty;
10052    end Incomplete_Or_Partial_View;
10053
10054    -----------------------------------------
10055    -- Inherit_Default_Init_Cond_Procedure --
10056    -----------------------------------------
10057
10058    procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
10059       Par_Typ : constant Entity_Id := Etype (Typ);
10060
10061    begin
10062       --  A derived type inherits the default initial condition procedure of
10063       --  its parent type.
10064
10065       if No (Default_Init_Cond_Procedure (Typ)) then
10066          Set_Default_Init_Cond_Procedure
10067            (Typ, Default_Init_Cond_Procedure (Par_Typ));
10068       end if;
10069    end Inherit_Default_Init_Cond_Procedure;
10070
10071    ----------------------------
10072    -- Inherit_Rep_Item_Chain --
10073    ----------------------------
10074
10075    procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
10076       From_Item : constant Node_Id := First_Rep_Item (From_Typ);
10077       Item      : Node_Id := Empty;
10078       Last_Item : Node_Id := Empty;
10079
10080    begin
10081       --  Reach the end of the destination type's chain (if any) and capture
10082       --  the last item.
10083
10084       Item := First_Rep_Item (Typ);
10085       while Present (Item) loop
10086
10087          --  Do not inherit a chain that has been inherited already
10088
10089          if Item = From_Item then
10090             return;
10091          end if;
10092
10093          Last_Item := Item;
10094          Item := Next_Rep_Item (Item);
10095       end loop;
10096
10097       --  When the destination type has a rep item chain, the chain of the
10098       --  source type is appended to it.
10099
10100       if Present (Last_Item) then
10101          Set_Next_Rep_Item (Last_Item, From_Item);
10102
10103       --  Otherwise the destination type directly inherits the rep item chain
10104       --  of the source type (if any).
10105
10106       else
10107          Set_First_Rep_Item (Typ, From_Item);
10108       end if;
10109    end Inherit_Rep_Item_Chain;
10110
10111    ---------------------------------
10112    -- Insert_Explicit_Dereference --
10113    ---------------------------------
10114
10115    procedure Insert_Explicit_Dereference (N : Node_Id) is
10116       New_Prefix : constant Node_Id := Relocate_Node (N);
10117       Ent        : Entity_Id := Empty;
10118       Pref       : Node_Id;
10119       I          : Interp_Index;
10120       It         : Interp;
10121       T          : Entity_Id;
10122
10123    begin
10124       Save_Interps (N, New_Prefix);
10125
10126       Rewrite (N,
10127         Make_Explicit_Dereference (Sloc (Parent (N)),
10128           Prefix => New_Prefix));
10129
10130       Set_Etype (N, Designated_Type (Etype (New_Prefix)));
10131
10132       if Is_Overloaded (New_Prefix) then
10133
10134          --  The dereference is also overloaded, and its interpretations are
10135          --  the designated types of the interpretations of the original node.
10136
10137          Set_Etype (N, Any_Type);
10138
10139          Get_First_Interp (New_Prefix, I, It);
10140          while Present (It.Nam) loop
10141             T := It.Typ;
10142
10143             if Is_Access_Type (T) then
10144                Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
10145             end if;
10146
10147             Get_Next_Interp (I, It);
10148          end loop;
10149
10150          End_Interp_List;
10151
10152       else
10153          --  Prefix is unambiguous: mark the original prefix (which might
10154          --  Come_From_Source) as a reference, since the new (relocated) one
10155          --  won't be taken into account.
10156
10157          if Is_Entity_Name (New_Prefix) then
10158             Ent := Entity (New_Prefix);
10159             Pref := New_Prefix;
10160
10161          --  For a retrieval of a subcomponent of some composite object,
10162          --  retrieve the ultimate entity if there is one.
10163
10164          elsif Nkind_In (New_Prefix, N_Selected_Component,
10165                                      N_Indexed_Component)
10166          then
10167             Pref := Prefix (New_Prefix);
10168             while Present (Pref)
10169               and then Nkind_In (Pref, N_Selected_Component,
10170                                        N_Indexed_Component)
10171             loop
10172                Pref := Prefix (Pref);
10173             end loop;
10174
10175             if Present (Pref) and then Is_Entity_Name (Pref) then
10176                Ent := Entity (Pref);
10177             end if;
10178          end if;
10179
10180          --  Place the reference on the entity node
10181
10182          if Present (Ent) then
10183             Generate_Reference (Ent, Pref);
10184          end if;
10185       end if;
10186    end Insert_Explicit_Dereference;
10187
10188    ------------------------------------------
10189    -- Inspect_Deferred_Constant_Completion --
10190    ------------------------------------------
10191
10192    procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
10193       Decl   : Node_Id;
10194
10195    begin
10196       Decl := First (Decls);
10197       while Present (Decl) loop
10198
10199          --  Deferred constant signature
10200
10201          if Nkind (Decl) = N_Object_Declaration
10202            and then Constant_Present (Decl)
10203            and then No (Expression (Decl))
10204
10205             --  No need to check internally generated constants
10206
10207            and then Comes_From_Source (Decl)
10208
10209             --  The constant is not completed. A full object declaration or a
10210             --  pragma Import complete a deferred constant.
10211
10212            and then not Has_Completion (Defining_Identifier (Decl))
10213          then
10214             Error_Msg_N
10215               ("constant declaration requires initialization expression",
10216               Defining_Identifier (Decl));
10217          end if;
10218
10219          Decl := Next (Decl);
10220       end loop;
10221    end Inspect_Deferred_Constant_Completion;
10222
10223    -----------------------------
10224    -- Install_Generic_Formals --
10225    -----------------------------
10226
10227    procedure Install_Generic_Formals (Subp_Id : Entity_Id) is
10228       E : Entity_Id;
10229
10230    begin
10231       pragma Assert (Is_Generic_Subprogram (Subp_Id));
10232
10233       E := First_Entity (Subp_Id);
10234       while Present (E) loop
10235          Install_Entity (E);
10236          Next_Entity (E);
10237       end loop;
10238    end Install_Generic_Formals;
10239
10240    -----------------------------
10241    -- Is_Actual_Out_Parameter --
10242    -----------------------------
10243
10244    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean is
10245       Formal : Entity_Id;
10246       Call   : Node_Id;
10247    begin
10248       Find_Actual (N, Formal, Call);
10249       return Present (Formal) and then Ekind (Formal) = E_Out_Parameter;
10250    end Is_Actual_Out_Parameter;
10251
10252    -------------------------
10253    -- Is_Actual_Parameter --
10254    -------------------------
10255
10256    function Is_Actual_Parameter (N : Node_Id) return Boolean is
10257       PK : constant Node_Kind := Nkind (Parent (N));
10258
10259    begin
10260       case PK is
10261          when N_Parameter_Association =>
10262             return N = Explicit_Actual_Parameter (Parent (N));
10263
10264          when N_Subprogram_Call =>
10265             return Is_List_Member (N)
10266               and then
10267                 List_Containing (N) = Parameter_Associations (Parent (N));
10268
10269          when others =>
10270             return False;
10271       end case;
10272    end Is_Actual_Parameter;
10273
10274    --------------------------------
10275    -- Is_Actual_Tagged_Parameter --
10276    --------------------------------
10277
10278    function Is_Actual_Tagged_Parameter (N : Node_Id) return Boolean is
10279       Formal : Entity_Id;
10280       Call   : Node_Id;
10281    begin
10282       Find_Actual (N, Formal, Call);
10283       return Present (Formal) and then Is_Tagged_Type (Etype (Formal));
10284    end Is_Actual_Tagged_Parameter;
10285
10286    ---------------------
10287    -- Is_Aliased_View --
10288    ---------------------
10289
10290    function Is_Aliased_View (Obj : Node_Id) return Boolean is
10291       E : Entity_Id;
10292
10293    begin
10294       if Is_Entity_Name (Obj) then
10295          E := Entity (Obj);
10296
10297          return
10298            (Is_Object (E)
10299              and then
10300                (Is_Aliased (E)
10301                  or else (Present (Renamed_Object (E))
10302                            and then Is_Aliased_View (Renamed_Object (E)))))
10303
10304            or else ((Is_Formal (E)
10305                       or else Ekind_In (E, E_Generic_In_Out_Parameter,
10306                                            E_Generic_In_Parameter))
10307                     and then Is_Tagged_Type (Etype (E)))
10308
10309            or else (Is_Concurrent_Type (E) and then In_Open_Scopes (E))
10310
10311            --  Current instance of type, either directly or as rewritten
10312            --  reference to the current object.
10313
10314            or else (Is_Entity_Name (Original_Node (Obj))
10315                      and then Present (Entity (Original_Node (Obj)))
10316                      and then Is_Type (Entity (Original_Node (Obj))))
10317
10318            or else (Is_Type (E) and then E = Current_Scope)
10319
10320            or else (Is_Incomplete_Or_Private_Type (E)
10321                      and then Full_View (E) = Current_Scope)
10322
10323            --  Ada 2012 AI05-0053: the return object of an extended return
10324            --  statement is aliased if its type is immutably limited.
10325
10326            or else (Is_Return_Object (E)
10327                      and then Is_Limited_View (Etype (E)));
10328
10329       elsif Nkind (Obj) = N_Selected_Component then
10330          return Is_Aliased (Entity (Selector_Name (Obj)));
10331
10332       elsif Nkind (Obj) = N_Indexed_Component then
10333          return Has_Aliased_Components (Etype (Prefix (Obj)))
10334            or else
10335              (Is_Access_Type (Etype (Prefix (Obj)))
10336                and then Has_Aliased_Components
10337                           (Designated_Type (Etype (Prefix (Obj)))));
10338
10339       elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
10340          return Is_Tagged_Type (Etype (Obj))
10341            and then Is_Aliased_View (Expression (Obj));
10342
10343       elsif Nkind (Obj) = N_Explicit_Dereference then
10344          return Nkind (Original_Node (Obj)) /= N_Function_Call;
10345
10346       else
10347          return False;
10348       end if;
10349    end Is_Aliased_View;
10350
10351    -------------------------
10352    -- Is_Ancestor_Package --
10353    -------------------------
10354
10355    function Is_Ancestor_Package
10356      (E1 : Entity_Id;
10357       E2 : Entity_Id) return Boolean
10358    is
10359       Par : Entity_Id;
10360
10361    begin
10362       Par := E2;
10363       while Present (Par) and then Par /= Standard_Standard loop
10364          if Par = E1 then
10365             return True;
10366          end if;
10367
10368          Par := Scope (Par);
10369       end loop;
10370
10371       return False;
10372    end Is_Ancestor_Package;
10373
10374    ----------------------
10375    -- Is_Atomic_Object --
10376    ----------------------
10377
10378    function Is_Atomic_Object (N : Node_Id) return Boolean is
10379
10380       function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
10381       --  Determines if given object has atomic components
10382
10383       function Is_Atomic_Prefix (N : Node_Id) return Boolean;
10384       --  If prefix is an implicit dereference, examine designated type
10385
10386       ----------------------
10387       -- Is_Atomic_Prefix --
10388       ----------------------
10389
10390       function Is_Atomic_Prefix (N : Node_Id) return Boolean is
10391       begin
10392          if Is_Access_Type (Etype (N)) then
10393             return
10394               Has_Atomic_Components (Designated_Type (Etype (N)));
10395          else
10396             return Object_Has_Atomic_Components (N);
10397          end if;
10398       end Is_Atomic_Prefix;
10399
10400       ----------------------------------
10401       -- Object_Has_Atomic_Components --
10402       ----------------------------------
10403
10404       function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
10405       begin
10406          if Has_Atomic_Components (Etype (N))
10407            or else Is_Atomic (Etype (N))
10408          then
10409             return True;
10410
10411          elsif Is_Entity_Name (N)
10412            and then (Has_Atomic_Components (Entity (N))
10413                       or else Is_Atomic (Entity (N)))
10414          then
10415             return True;
10416
10417          elsif Nkind (N) = N_Selected_Component
10418            and then Is_Atomic (Entity (Selector_Name (N)))
10419          then
10420             return True;
10421
10422          elsif Nkind (N) = N_Indexed_Component
10423            or else Nkind (N) = N_Selected_Component
10424          then
10425             return Is_Atomic_Prefix (Prefix (N));
10426
10427          else
10428             return False;
10429          end if;
10430       end Object_Has_Atomic_Components;
10431
10432    --  Start of processing for Is_Atomic_Object
10433
10434    begin
10435       --  Predicate is not relevant to subprograms
10436
10437       if Is_Entity_Name (N) and then Is_Overloadable (Entity (N)) then
10438          return False;
10439
10440       elsif Is_Atomic (Etype (N))
10441         or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
10442       then
10443          return True;
10444
10445       elsif Nkind (N) = N_Selected_Component
10446         and then Is_Atomic (Entity (Selector_Name (N)))
10447       then
10448          return True;
10449
10450       elsif Nkind (N) = N_Indexed_Component
10451         or else Nkind (N) = N_Selected_Component
10452       then
10453          return Is_Atomic_Prefix (Prefix (N));
10454
10455       else
10456          return False;
10457       end if;
10458    end Is_Atomic_Object;
10459
10460    -----------------------------
10461    -- Is_Atomic_Or_VFA_Object --
10462    -----------------------------
10463
10464    function Is_Atomic_Or_VFA_Object (N : Node_Id) return Boolean is
10465    begin
10466       return Is_Atomic_Object (N)
10467         or else (Is_Object_Reference (N)
10468                    and then Is_Entity_Name (N)
10469                    and then (Is_Volatile_Full_Access (Entity (N))
10470                                 or else
10471                              Is_Volatile_Full_Access (Etype (Entity (N)))));
10472    end Is_Atomic_Or_VFA_Object;
10473
10474    -------------------------
10475    -- Is_Attribute_Result --
10476    -------------------------
10477
10478    function Is_Attribute_Result (N : Node_Id) return Boolean is
10479    begin
10480       return Nkind (N) = N_Attribute_Reference
10481         and then Attribute_Name (N) = Name_Result;
10482    end Is_Attribute_Result;
10483
10484    -------------------------
10485    -- Is_Attribute_Update --
10486    -------------------------
10487
10488    function Is_Attribute_Update (N : Node_Id) return Boolean is
10489    begin
10490       return Nkind (N) = N_Attribute_Reference
10491         and then Attribute_Name (N) = Name_Update;
10492    end Is_Attribute_Update;
10493
10494    ------------------------------------
10495    -- Is_Body_Or_Package_Declaration --
10496    ------------------------------------
10497
10498    function Is_Body_Or_Package_Declaration (N : Node_Id) return Boolean is
10499    begin
10500       return Nkind_In (N, N_Entry_Body,
10501                           N_Package_Body,
10502                           N_Package_Declaration,
10503                           N_Protected_Body,
10504                           N_Subprogram_Body,
10505                           N_Task_Body);
10506    end Is_Body_Or_Package_Declaration;
10507
10508    -----------------------
10509    -- Is_Bounded_String --
10510    -----------------------
10511
10512    function Is_Bounded_String (T : Entity_Id) return Boolean is
10513       Under : constant Entity_Id := Underlying_Type (Root_Type (T));
10514
10515    begin
10516       --  Check whether T is ultimately derived from Ada.Strings.Superbounded.
10517       --  Super_String, or one of the [Wide_]Wide_ versions. This will
10518       --  be True for all the Bounded_String types in instances of the
10519       --  Generic_Bounded_Length generics, and for types derived from those.
10520
10521       return Present (Under)
10522         and then (Is_RTE (Root_Type (Under), RO_SU_Super_String) or else
10523                   Is_RTE (Root_Type (Under), RO_WI_Super_String) or else
10524                   Is_RTE (Root_Type (Under), RO_WW_Super_String));
10525    end Is_Bounded_String;
10526
10527    -------------------------
10528    -- Is_Child_Or_Sibling --
10529    -------------------------
10530
10531    function Is_Child_Or_Sibling
10532      (Pack_1 : Entity_Id;
10533       Pack_2 : Entity_Id) return Boolean
10534    is
10535       function Distance_From_Standard (Pack : Entity_Id) return Nat;
10536       --  Given an arbitrary package, return the number of "climbs" necessary
10537       --  to reach scope Standard_Standard.
10538
10539       procedure Equalize_Depths
10540         (Pack           : in out Entity_Id;
10541          Depth          : in out Nat;
10542          Depth_To_Reach : Nat);
10543       --  Given an arbitrary package, its depth and a target depth to reach,
10544       --  climb the scope chain until the said depth is reached. The pointer
10545       --  to the package and its depth a modified during the climb.
10546
10547       ----------------------------
10548       -- Distance_From_Standard --
10549       ----------------------------
10550
10551       function Distance_From_Standard (Pack : Entity_Id) return Nat is
10552          Dist : Nat;
10553          Scop : Entity_Id;
10554
10555       begin
10556          Dist := 0;
10557          Scop := Pack;
10558          while Present (Scop) and then Scop /= Standard_Standard loop
10559             Dist := Dist + 1;
10560             Scop := Scope (Scop);
10561          end loop;
10562
10563          return Dist;
10564       end Distance_From_Standard;
10565
10566       ---------------------
10567       -- Equalize_Depths --
10568       ---------------------
10569
10570       procedure Equalize_Depths
10571         (Pack           : in out Entity_Id;
10572          Depth          : in out Nat;
10573          Depth_To_Reach : Nat)
10574       is
10575       begin
10576          --  The package must be at a greater or equal depth
10577
10578          if Depth < Depth_To_Reach then
10579             raise Program_Error;
10580          end if;
10581
10582          --  Climb the scope chain until the desired depth is reached
10583
10584          while Present (Pack) and then Depth /= Depth_To_Reach loop
10585             Pack  := Scope (Pack);
10586             Depth := Depth - 1;
10587          end loop;
10588       end Equalize_Depths;
10589
10590       --  Local variables
10591
10592       P_1       : Entity_Id := Pack_1;
10593       P_1_Child : Boolean   := False;
10594       P_1_Depth : Nat       := Distance_From_Standard (P_1);
10595       P_2       : Entity_Id := Pack_2;
10596       P_2_Child : Boolean   := False;
10597       P_2_Depth : Nat       := Distance_From_Standard (P_2);
10598
10599    --  Start of processing for Is_Child_Or_Sibling
10600
10601    begin
10602       pragma Assert
10603         (Ekind (Pack_1) = E_Package and then Ekind (Pack_2) = E_Package);
10604
10605       --  Both packages denote the same entity, therefore they cannot be
10606       --  children or siblings.
10607
10608       if P_1 = P_2 then
10609          return False;
10610
10611       --  One of the packages is at a deeper level than the other. Note that
10612       --  both may still come from differen hierarchies.
10613
10614       --        (root)           P_2
10615       --        /    \            :
10616       --       X     P_2    or    X
10617       --       :                  :
10618       --      P_1                P_1
10619
10620       elsif P_1_Depth > P_2_Depth then
10621          Equalize_Depths
10622            (Pack           => P_1,
10623             Depth          => P_1_Depth,
10624             Depth_To_Reach => P_2_Depth);
10625          P_1_Child := True;
10626
10627       --        (root)           P_1
10628       --        /    \            :
10629       --      P_1     X     or    X
10630       --              :           :
10631       --             P_2         P_2
10632
10633       elsif P_2_Depth > P_1_Depth then
10634          Equalize_Depths
10635            (Pack           => P_2,
10636             Depth          => P_2_Depth,
10637             Depth_To_Reach => P_1_Depth);
10638          P_2_Child := True;
10639       end if;
10640
10641       --  At this stage the package pointers have been elevated to the same
10642       --  depth. If the related entities are the same, then one package is a
10643       --  potential child of the other:
10644
10645       --      P_1
10646       --       :
10647       --       X    became   P_1 P_2   or vica versa
10648       --       :
10649       --      P_2
10650
10651       if P_1 = P_2 then
10652          if P_1_Child then
10653             return Is_Child_Unit (Pack_1);
10654
10655          else pragma Assert (P_2_Child);
10656             return Is_Child_Unit (Pack_2);
10657          end if;
10658
10659       --  The packages may come from the same package chain or from entirely
10660       --  different hierarcies. To determine this, climb the scope stack until
10661       --  a common root is found.
10662
10663       --        (root)      (root 1)  (root 2)
10664       --        /    \         |         |
10665       --      P_1    P_2      P_1       P_2
10666
10667       else
10668          while Present (P_1) and then Present (P_2) loop
10669
10670             --  The two packages may be siblings
10671
10672             if P_1 = P_2 then
10673                return Is_Child_Unit (Pack_1) and then Is_Child_Unit (Pack_2);
10674             end if;
10675
10676             P_1 := Scope (P_1);
10677             P_2 := Scope (P_2);
10678          end loop;
10679       end if;
10680
10681       return False;
10682    end Is_Child_Or_Sibling;
10683
10684    -----------------------------
10685    -- Is_Concurrent_Interface --
10686    -----------------------------
10687
10688    function Is_Concurrent_Interface (T : Entity_Id) return Boolean is
10689    begin
10690       return Is_Interface (T)
10691         and then
10692           (Is_Protected_Interface (T)
10693             or else Is_Synchronized_Interface (T)
10694             or else Is_Task_Interface (T));
10695    end Is_Concurrent_Interface;
10696
10697    -----------------------
10698    -- Is_Constant_Bound --
10699    -----------------------
10700
10701    function Is_Constant_Bound (Exp : Node_Id) return Boolean is
10702    begin
10703       if Compile_Time_Known_Value (Exp) then
10704          return True;
10705
10706       elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
10707          return Is_Constant_Object (Entity (Exp))
10708            or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
10709
10710       elsif Nkind (Exp) in N_Binary_Op then
10711          return Is_Constant_Bound (Left_Opnd (Exp))
10712            and then Is_Constant_Bound (Right_Opnd (Exp))
10713            and then Scope (Entity (Exp)) = Standard_Standard;
10714
10715       else
10716          return False;
10717       end if;
10718    end Is_Constant_Bound;
10719
10720    ---------------------------
10721    --  Is_Container_Element --
10722    ---------------------------
10723
10724    function Is_Container_Element (Exp : Node_Id) return Boolean is
10725       Loc  : constant Source_Ptr := Sloc (Exp);
10726       Pref : constant Node_Id   := Prefix (Exp);
10727
10728       Call : Node_Id;
10729       --  Call to an indexing aspect
10730
10731       Cont_Typ : Entity_Id;
10732       --  The type of the container being accessed
10733
10734       Elem_Typ : Entity_Id;
10735       --  Its element type
10736
10737       Indexing : Entity_Id;
10738       Is_Const : Boolean;
10739       --  Indicates that constant indexing is used, and the element is thus
10740       --  a constant.
10741
10742       Ref_Typ : Entity_Id;
10743       --  The reference type returned by the indexing operation
10744
10745    begin
10746       --  If C is a container, in a context that imposes the element type of
10747       --  that container, the indexing notation C (X) is rewritten as:
10748
10749       --    Indexing (C, X).Discr.all
10750
10751       --  where Indexing is one of the indexing aspects of the container.
10752       --  If the context does not require a reference, the construct can be
10753       --  rewritten as
10754
10755       --    Element (C, X)
10756
10757       --  First, verify that the construct has the proper form
10758
10759       if not Expander_Active then
10760          return False;
10761
10762       elsif Nkind (Pref) /= N_Selected_Component then
10763          return False;
10764
10765       elsif Nkind (Prefix (Pref)) /= N_Function_Call then
10766          return False;
10767
10768       else
10769          Call    := Prefix (Pref);
10770          Ref_Typ := Etype (Call);
10771       end if;
10772
10773       if not Has_Implicit_Dereference (Ref_Typ)
10774         or else No (First (Parameter_Associations (Call)))
10775         or else not Is_Entity_Name (Name (Call))
10776       then
10777          return False;
10778       end if;
10779
10780       --  Retrieve type of container object, and its iterator aspects
10781
10782       Cont_Typ := Etype (First (Parameter_Associations (Call)));
10783       Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Constant_Indexing);
10784       Is_Const := False;
10785
10786       if No (Indexing) then
10787
10788          --  Container should have at least one indexing operation
10789
10790          return False;
10791
10792       elsif Entity (Name (Call)) /= Entity (Indexing) then
10793
10794          --  This may be a variable indexing operation
10795
10796          Indexing := Find_Value_Of_Aspect (Cont_Typ, Aspect_Variable_Indexing);
10797
10798          if No (Indexing)
10799            or else Entity (Name (Call)) /= Entity (Indexing)
10800          then
10801             return False;
10802          end if;
10803
10804       else
10805          Is_Const := True;
10806       end if;
10807
10808       Elem_Typ := Find_Value_Of_Aspect (Cont_Typ, Aspect_Iterator_Element);
10809
10810       if No (Elem_Typ) or else Entity (Elem_Typ) /= Etype (Exp) then
10811          return False;
10812       end if;
10813
10814       --  Check that the expression is not the target of an assignment, in
10815       --  which case the rewriting is not possible.
10816
10817       if not Is_Const then
10818          declare
10819             Par : Node_Id;
10820
10821          begin
10822             Par := Exp;
10823             while Present (Par)
10824             loop
10825                if Nkind (Parent (Par)) = N_Assignment_Statement
10826                  and then Par = Name (Parent (Par))
10827                then
10828                   return False;
10829
10830                --  A renaming produces a reference, and the transformation
10831                --  does not apply.
10832
10833                elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
10834                   return False;
10835
10836                elsif Nkind_In
10837                  (Nkind (Parent (Par)), N_Function_Call,
10838                                         N_Procedure_Call_Statement,
10839                                         N_Entry_Call_Statement)
10840                then
10841                   --  Check that the element is not part of an actual for an
10842                   --  in-out parameter.
10843
10844                   declare
10845                      F : Entity_Id;
10846                      A : Node_Id;
10847
10848                   begin
10849                      F := First_Formal (Entity (Name (Parent (Par))));
10850                      A := First (Parameter_Associations (Parent (Par)));
10851                      while Present (F) loop
10852                         if A = Par and then Ekind (F) /= E_In_Parameter then
10853                            return False;
10854                         end if;
10855
10856                         Next_Formal (F);
10857                         Next (A);
10858                      end loop;
10859                   end;
10860
10861                   --  E_In_Parameter in a call: element is not modified.
10862
10863                   exit;
10864                end if;
10865
10866                Par := Parent (Par);
10867             end loop;
10868          end;
10869       end if;
10870
10871       --  The expression has the proper form and the context requires the
10872       --  element type. Retrieve the Element function of the container and
10873       --  rewrite the construct as a call to it.
10874
10875       declare
10876          Op : Elmt_Id;
10877
10878       begin
10879          Op := First_Elmt (Primitive_Operations (Cont_Typ));
10880          while Present (Op) loop
10881             exit when Chars (Node (Op)) = Name_Element;
10882             Next_Elmt (Op);
10883          end loop;
10884
10885          if No (Op) then
10886             return False;
10887
10888          else
10889             Rewrite (Exp,
10890               Make_Function_Call (Loc,
10891                 Name                   => New_Occurrence_Of (Node (Op), Loc),
10892                 Parameter_Associations => Parameter_Associations (Call)));
10893             Analyze_And_Resolve (Exp, Entity (Elem_Typ));
10894             return True;
10895          end if;
10896       end;
10897    end Is_Container_Element;
10898
10899    ----------------------------
10900    -- Is_Contract_Annotation --
10901    ----------------------------
10902
10903    function Is_Contract_Annotation (Item : Node_Id) return Boolean is
10904    begin
10905       return Is_Package_Contract_Annotation (Item)
10906                or else
10907              Is_Subprogram_Contract_Annotation (Item);
10908    end Is_Contract_Annotation;
10909
10910    --------------------------------------
10911    -- Is_Controlling_Limited_Procedure --
10912    --------------------------------------
10913
10914    function Is_Controlling_Limited_Procedure
10915      (Proc_Nam : Entity_Id) return Boolean
10916    is
10917       Param_Typ : Entity_Id := Empty;
10918
10919    begin
10920       if Ekind (Proc_Nam) = E_Procedure
10921         and then Present (Parameter_Specifications (Parent (Proc_Nam)))
10922       then
10923          Param_Typ := Etype (Parameter_Type (First (
10924                         Parameter_Specifications (Parent (Proc_Nam)))));
10925
10926       --  In this case where an Itype was created, the procedure call has been
10927       --  rewritten.
10928
10929       elsif Present (Associated_Node_For_Itype (Proc_Nam))
10930         and then Present (Original_Node (Associated_Node_For_Itype (Proc_Nam)))
10931         and then
10932           Present (Parameter_Associations
10933                      (Associated_Node_For_Itype (Proc_Nam)))
10934       then
10935          Param_Typ :=
10936            Etype (First (Parameter_Associations
10937                           (Associated_Node_For_Itype (Proc_Nam))));
10938       end if;
10939
10940       if Present (Param_Typ) then
10941          return
10942            Is_Interface (Param_Typ)
10943              and then Is_Limited_Record (Param_Typ);
10944       end if;
10945
10946       return False;
10947    end Is_Controlling_Limited_Procedure;
10948
10949    -----------------------------
10950    -- Is_CPP_Constructor_Call --
10951    -----------------------------
10952
10953    function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
10954    begin
10955       return Nkind (N) = N_Function_Call
10956         and then Is_CPP_Class (Etype (Etype (N)))
10957         and then Is_Constructor (Entity (Name (N)))
10958         and then Is_Imported (Entity (Name (N)));
10959    end Is_CPP_Constructor_Call;
10960
10961    -------------------------
10962    -- Is_Current_Instance --
10963    -------------------------
10964
10965    function Is_Current_Instance (N : Node_Id) return Boolean is
10966       Typ : constant Entity_Id := Entity (N);
10967       P   : Node_Id;
10968
10969    begin
10970       --  Simplest case: entity is a concurrent type and we are currently
10971       --  inside the body. This will eventually be expanded into a
10972       --  call to Self (for tasks) or _object (for protected objects).
10973
10974       if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then
10975          return True;
10976
10977       else
10978          --  Check whether the context is a (sub)type declaration for the
10979          --  type entity.
10980
10981          P := Parent (N);
10982          while Present (P) loop
10983             if Nkind_In (P, N_Full_Type_Declaration,
10984                             N_Private_Type_Declaration,
10985                             N_Subtype_Declaration)
10986               and then Comes_From_Source (P)
10987               and then Defining_Entity (P) = Typ
10988             then
10989                return True;
10990             end if;
10991
10992             P := Parent (P);
10993          end loop;
10994       end if;
10995
10996       --  In any other context this is not a current occurrence
10997
10998       return False;
10999    end Is_Current_Instance;
11000
11001    --------------------
11002    -- Is_Declaration --
11003    --------------------
11004
11005    function Is_Declaration (N : Node_Id) return Boolean is
11006    begin
11007       case Nkind (N) is
11008          when N_Abstract_Subprogram_Declaration        |
11009               N_Exception_Declaration                  |
11010               N_Exception_Renaming_Declaration         |
11011               N_Full_Type_Declaration                  |
11012               N_Generic_Function_Renaming_Declaration  |
11013               N_Generic_Package_Declaration            |
11014               N_Generic_Package_Renaming_Declaration   |
11015               N_Generic_Procedure_Renaming_Declaration |
11016               N_Generic_Subprogram_Declaration         |
11017               N_Number_Declaration                     |
11018               N_Object_Declaration                     |
11019               N_Object_Renaming_Declaration            |
11020               N_Package_Declaration                    |
11021               N_Package_Renaming_Declaration           |
11022               N_Private_Extension_Declaration          |
11023               N_Private_Type_Declaration               |
11024               N_Subprogram_Declaration                 |
11025               N_Subprogram_Renaming_Declaration        |
11026               N_Subtype_Declaration                    =>
11027             return True;
11028
11029          when others                                   =>
11030             return False;
11031       end case;
11032    end Is_Declaration;
11033
11034    --------------------------------
11035    -- Is_Declared_Within_Variant --
11036    --------------------------------
11037
11038    function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
11039       Comp_Decl : constant Node_Id := Parent (Comp);
11040       Comp_List : constant Node_Id := Parent (Comp_Decl);
11041    begin
11042       return Nkind (Parent (Comp_List)) = N_Variant;
11043    end Is_Declared_Within_Variant;
11044
11045    ----------------------------------------------
11046    -- Is_Dependent_Component_Of_Mutable_Object --
11047    ----------------------------------------------
11048
11049    function Is_Dependent_Component_Of_Mutable_Object
11050      (Object : Node_Id) return Boolean
11051    is
11052       P           : Node_Id;
11053       Prefix_Type : Entity_Id;
11054       P_Aliased   : Boolean := False;
11055       Comp        : Entity_Id;
11056
11057       Deref : Node_Id := Object;
11058       --  Dereference node, in something like X.all.Y(2)
11059
11060    --  Start of processing for Is_Dependent_Component_Of_Mutable_Object
11061
11062    begin
11063       --  Find the dereference node if any
11064
11065       while Nkind_In (Deref, N_Indexed_Component,
11066                              N_Selected_Component,
11067                              N_Slice)
11068       loop
11069          Deref := Prefix (Deref);
11070       end loop;
11071
11072       --  Ada 2005: If we have a component or slice of a dereference,
11073       --  something like X.all.Y (2), and the type of X is access-to-constant,
11074       --  Is_Variable will return False, because it is indeed a constant
11075       --  view. But it might be a view of a variable object, so we want the
11076       --  following condition to be True in that case.
11077
11078       if Is_Variable (Object)
11079         or else (Ada_Version >= Ada_2005
11080                   and then Nkind (Deref) = N_Explicit_Dereference)
11081       then
11082          if Nkind (Object) = N_Selected_Component then
11083             P := Prefix (Object);
11084             Prefix_Type := Etype (P);
11085
11086             if Is_Entity_Name (P) then
11087                if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
11088                   Prefix_Type := Base_Type (Prefix_Type);
11089                end if;
11090
11091                if Is_Aliased (Entity (P)) then
11092                   P_Aliased := True;
11093                end if;
11094
11095             --  A discriminant check on a selected component may be expanded
11096             --  into a dereference when removing side-effects. Recover the
11097             --  original node and its type, which may be unconstrained.
11098
11099             elsif Nkind (P) = N_Explicit_Dereference
11100               and then not (Comes_From_Source (P))
11101             then
11102                P := Original_Node (P);
11103                Prefix_Type := Etype (P);
11104
11105             else
11106                --  Check for prefix being an aliased component???
11107
11108                null;
11109
11110             end if;
11111
11112             --  A heap object is constrained by its initial value
11113
11114             --  Ada 2005 (AI-363): Always assume the object could be mutable in
11115             --  the dereferenced case, since the access value might denote an
11116             --  unconstrained aliased object, whereas in Ada 95 the designated
11117             --  object is guaranteed to be constrained. A worst-case assumption
11118             --  has to apply in Ada 2005 because we can't tell at compile
11119             --  time whether the object is "constrained by its initial value"
11120             --  (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
11121             --  rules (these rules are acknowledged to need fixing).
11122
11123             if Ada_Version < Ada_2005 then
11124                if Is_Access_Type (Prefix_Type)
11125                  or else Nkind (P) = N_Explicit_Dereference
11126                then
11127                   return False;
11128                end if;
11129
11130             else pragma Assert (Ada_Version >= Ada_2005);
11131                if Is_Access_Type (Prefix_Type) then
11132
11133                   --  If the access type is pool-specific, and there is no
11134                   --  constrained partial view of the designated type, then the
11135                   --  designated object is known to be constrained.
11136
11137                   if Ekind (Prefix_Type) = E_Access_Type
11138                     and then not Object_Type_Has_Constrained_Partial_View
11139                                    (Typ  => Designated_Type (Prefix_Type),
11140                                     Scop => Current_Scope)
11141                   then
11142                      return False;
11143
11144                   --  Otherwise (general access type, or there is a constrained
11145                   --  partial view of the designated type), we need to check
11146                   --  based on the designated type.
11147
11148                   else
11149                      Prefix_Type := Designated_Type (Prefix_Type);
11150                   end if;
11151                end if;
11152             end if;
11153
11154             Comp :=
11155               Original_Record_Component (Entity (Selector_Name (Object)));
11156
11157             --  As per AI-0017, the renaming is illegal in a generic body, even
11158             --  if the subtype is indefinite.
11159
11160             --  Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
11161
11162             if not Is_Constrained (Prefix_Type)
11163               and then (Is_Definite_Subtype (Prefix_Type)
11164                          or else
11165                            (Is_Generic_Type (Prefix_Type)
11166                              and then Ekind (Current_Scope) = E_Generic_Package
11167                              and then In_Package_Body (Current_Scope)))
11168
11169               and then (Is_Declared_Within_Variant (Comp)
11170                          or else Has_Discriminant_Dependent_Constraint (Comp))
11171               and then (not P_Aliased or else Ada_Version >= Ada_2005)
11172             then
11173                return True;
11174
11175             --  If the prefix is of an access type at this point, then we want
11176             --  to return False, rather than calling this function recursively
11177             --  on the access object (which itself might be a discriminant-
11178             --  dependent component of some other object, but that isn't
11179             --  relevant to checking the object passed to us). This avoids
11180             --  issuing wrong errors when compiling with -gnatc, where there
11181             --  can be implicit dereferences that have not been expanded.
11182
11183             elsif Is_Access_Type (Etype (Prefix (Object))) then
11184                return False;
11185
11186             else
11187                return
11188                  Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
11189             end if;
11190
11191          elsif Nkind (Object) = N_Indexed_Component
11192            or else Nkind (Object) = N_Slice
11193          then
11194             return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
11195
11196          --  A type conversion that Is_Variable is a view conversion:
11197          --  go back to the denoted object.
11198
11199          elsif Nkind (Object) = N_Type_Conversion then
11200             return
11201               Is_Dependent_Component_Of_Mutable_Object (Expression (Object));
11202          end if;
11203       end if;
11204
11205       return False;
11206    end Is_Dependent_Component_Of_Mutable_Object;
11207
11208    ---------------------
11209    -- Is_Dereferenced --
11210    ---------------------
11211
11212    function Is_Dereferenced (N : Node_Id) return Boolean is
11213       P : constant Node_Id := Parent (N);
11214    begin
11215       return Nkind_In (P, N_Selected_Component,
11216                           N_Explicit_Dereference,
11217                           N_Indexed_Component,
11218                           N_Slice)
11219         and then Prefix (P) = N;
11220    end Is_Dereferenced;
11221
11222    ----------------------
11223    -- Is_Descendent_Of --
11224    ----------------------
11225
11226    function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
11227       T    : Entity_Id;
11228       Etyp : Entity_Id;
11229
11230    begin
11231       pragma Assert (Nkind (T1) in N_Entity);
11232       pragma Assert (Nkind (T2) in N_Entity);
11233
11234       T := Base_Type (T1);
11235
11236       --  Immediate return if the types match
11237
11238       if T = T2 then
11239          return True;
11240
11241       --  Comment needed here ???
11242
11243       elsif Ekind (T) = E_Class_Wide_Type then
11244          return Etype (T) = T2;
11245
11246       --  All other cases
11247
11248       else
11249          loop
11250             Etyp := Etype (T);
11251
11252             --  Done if we found the type we are looking for
11253
11254             if Etyp = T2 then
11255                return True;
11256
11257             --  Done if no more derivations to check
11258
11259             elsif T = T1
11260               or else T = Etyp
11261             then
11262                return False;
11263
11264             --  Following test catches error cases resulting from prev errors
11265
11266             elsif No (Etyp) then
11267                return False;
11268
11269             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
11270                return False;
11271
11272             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
11273                return False;
11274             end if;
11275
11276             T := Base_Type (Etyp);
11277          end loop;
11278       end if;
11279    end Is_Descendent_Of;
11280
11281    ---------------------------------------------
11282    -- Is_Double_Precision_Floating_Point_Type --
11283    ---------------------------------------------
11284
11285    function Is_Double_Precision_Floating_Point_Type
11286      (E : Entity_Id) return Boolean is
11287    begin
11288       return Is_Floating_Point_Type (E)
11289         and then Machine_Radix_Value (E) = Uint_2
11290         and then Machine_Mantissa_Value (E) = UI_From_Int (53)
11291         and then Machine_Emax_Value (E) = Uint_2 ** Uint_10
11292         and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_10);
11293    end Is_Double_Precision_Floating_Point_Type;
11294
11295    -----------------------------
11296    -- Is_Effectively_Volatile --
11297    -----------------------------
11298
11299    function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is
11300       function Is_Descendant_Of_Suspension_Object
11301         (Typ : Entity_Id) return Boolean;
11302       --  Determine whether type Typ is a descendant of type Suspension_Object
11303       --  defined in Ada.Synchronous_Task_Control.
11304
11305       ----------------------------------------
11306       -- Is_Descendant_Of_Suspension_Object --
11307       ----------------------------------------
11308
11309       function Is_Descendant_Of_Suspension_Object
11310         (Typ : Entity_Id) return Boolean
11311       is
11312          Cur_Typ : Entity_Id;
11313          Par_Typ : Entity_Id;
11314
11315       begin
11316          --  Climb the type derivation chain checking each parent type against
11317          --  Suspension_Object.
11318
11319          Cur_Typ := Base_Type (Typ);
11320          while Present (Cur_Typ) loop
11321             Par_Typ := Etype (Cur_Typ);
11322
11323             --  The current type is a match
11324
11325             if Is_Suspension_Object (Cur_Typ) then
11326                return True;
11327
11328             --  Stop the traversal once the root of the derivation chain has
11329             --  been reached. In that case the current type is its own base
11330             --  type.
11331
11332             elsif Cur_Typ = Par_Typ then
11333                exit;
11334             end if;
11335
11336             Cur_Typ := Base_Type (Par_Typ);
11337          end loop;
11338
11339          return False;
11340       end Is_Descendant_Of_Suspension_Object;
11341
11342    --  Start of processing for Is_Effectively_Volatile
11343
11344    begin
11345       if Is_Type (Id) then
11346
11347          --  An arbitrary type is effectively volatile when it is subject to
11348          --  pragma Atomic or Volatile.
11349
11350          if Is_Volatile (Id) then
11351             return True;
11352
11353          --  An array type is effectively volatile when it is subject to pragma
11354          --  Atomic_Components or Volatile_Components or its compolent type is
11355          --  effectively volatile.
11356
11357          elsif Is_Array_Type (Id) then
11358             return
11359               Has_Volatile_Components (Id)
11360                 or else
11361               Is_Effectively_Volatile (Component_Type (Base_Type (Id)));
11362
11363          --  A protected type is always volatile
11364
11365          elsif Is_Protected_Type (Id) then
11366             return True;
11367
11368          --  A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
11369          --  automatically volatile.
11370
11371          elsif Is_Descendant_Of_Suspension_Object (Id) then
11372             return True;
11373
11374          --  Otherwise the type is not effectively volatile
11375
11376          else
11377             return False;
11378          end if;
11379
11380       --  Otherwise Id denotes an object
11381
11382       else
11383          return
11384            Is_Volatile (Id)
11385              or else Has_Volatile_Components (Id)
11386              or else Is_Effectively_Volatile (Etype (Id));
11387       end if;
11388    end Is_Effectively_Volatile;
11389
11390    ------------------------------------
11391    -- Is_Effectively_Volatile_Object --
11392    ------------------------------------
11393
11394    function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is
11395    begin
11396       if Is_Entity_Name (N) then
11397          return Is_Effectively_Volatile (Entity (N));
11398
11399       elsif Nkind (N) = N_Expanded_Name then
11400          return Is_Effectively_Volatile (Entity (N));
11401
11402       elsif Nkind (N) = N_Indexed_Component then
11403          return Is_Effectively_Volatile_Object (Prefix (N));
11404
11405       elsif Nkind (N) = N_Selected_Component then
11406          return
11407            Is_Effectively_Volatile_Object (Prefix (N))
11408              or else
11409            Is_Effectively_Volatile_Object (Selector_Name (N));
11410
11411       else
11412          return False;
11413       end if;
11414    end Is_Effectively_Volatile_Object;
11415
11416    -------------------
11417    -- Is_Entry_Body --
11418    -------------------
11419
11420    function Is_Entry_Body (Id : Entity_Id) return Boolean is
11421    begin
11422       return
11423         Ekind_In (Id, E_Entry, E_Entry_Family)
11424           and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Body;
11425    end Is_Entry_Body;
11426
11427    --------------------------
11428    -- Is_Entry_Declaration --
11429    --------------------------
11430
11431    function Is_Entry_Declaration (Id : Entity_Id) return Boolean is
11432    begin
11433       return
11434         Ekind_In (Id, E_Entry, E_Entry_Family)
11435           and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration;
11436    end Is_Entry_Declaration;
11437
11438    ----------------------------
11439    -- Is_Expression_Function --
11440    ----------------------------
11441
11442    function Is_Expression_Function (Subp : Entity_Id) return Boolean is
11443       Decl : Node_Id;
11444
11445    begin
11446       if Ekind (Subp) /= E_Function then
11447          return False;
11448
11449       else
11450          Decl := Unit_Declaration_Node (Subp);
11451          return Nkind (Decl) = N_Subprogram_Declaration
11452            and then
11453              (Nkind (Original_Node (Decl)) = N_Expression_Function
11454                or else
11455                  (Present (Corresponding_Body (Decl))
11456                    and then
11457                      Nkind (Original_Node
11458                              (Unit_Declaration_Node
11459                                (Corresponding_Body (Decl)))) =
11460                                   N_Expression_Function));
11461       end if;
11462    end Is_Expression_Function;
11463
11464    -----------------------
11465    -- Is_EVF_Expression --
11466    -----------------------
11467
11468    function Is_EVF_Expression (N : Node_Id) return Boolean is
11469       Orig_N : constant Node_Id := Original_Node (N);
11470       Alt    : Node_Id;
11471       Expr   : Node_Id;
11472       Id     : Entity_Id;
11473
11474    begin
11475       --  Detect a reference to a formal parameter of a specific tagged type
11476       --  whose related subprogram is subject to pragma Expresions_Visible with
11477       --  value "False".
11478
11479       if Is_Entity_Name (N) and then Present (Entity (N)) then
11480          Id := Entity (N);
11481
11482          return
11483            Is_Formal (Id)
11484              and then Is_Specific_Tagged_Type (Etype (Id))
11485              and then Extensions_Visible_Status (Id) =
11486                       Extensions_Visible_False;
11487
11488       --  A case expression is an EVF expression when it contains at least one
11489       --  EVF dependent_expression. Note that a case expression may have been
11490       --  expanded, hence the use of Original_Node.
11491
11492       elsif Nkind (Orig_N) = N_Case_Expression then
11493          Alt := First (Alternatives (Orig_N));
11494          while Present (Alt) loop
11495             if Is_EVF_Expression (Expression (Alt)) then
11496                return True;
11497             end if;
11498
11499             Next (Alt);
11500          end loop;
11501
11502       --  An if expression is an EVF expression when it contains at least one
11503       --  EVF dependent_expression. Note that an if expression may have been
11504       --  expanded, hence the use of Original_Node.
11505
11506       elsif Nkind (Orig_N) = N_If_Expression then
11507          Expr := Next (First (Expressions (Orig_N)));
11508          while Present (Expr) loop
11509             if Is_EVF_Expression (Expr) then
11510                return True;
11511             end if;
11512
11513             Next (Expr);
11514          end loop;
11515
11516       --  A qualified expression or a type conversion is an EVF expression when
11517       --  its operand is an EVF expression.
11518
11519       elsif Nkind_In (N, N_Qualified_Expression,
11520                          N_Unchecked_Type_Conversion,
11521                          N_Type_Conversion)
11522       then
11523          return Is_EVF_Expression (Expression (N));
11524
11525       --  Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
11526       --  their prefix denotes an EVF expression.
11527
11528       elsif Nkind (N) = N_Attribute_Reference
11529         and then Nam_In (Attribute_Name (N), Name_Loop_Entry,
11530                                              Name_Old,
11531                                              Name_Update)
11532       then
11533          return Is_EVF_Expression (Prefix (N));
11534       end if;
11535
11536       return False;
11537    end Is_EVF_Expression;
11538
11539    --------------
11540    -- Is_False --
11541    --------------
11542
11543    function Is_False (U : Uint) return Boolean is
11544    begin
11545       return (U = 0);
11546    end Is_False;
11547
11548    ---------------------------
11549    -- Is_Fixed_Model_Number --
11550    ---------------------------
11551
11552    function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
11553       S : constant Ureal := Small_Value (T);
11554       M : Urealp.Save_Mark;
11555       R : Boolean;
11556    begin
11557       M := Urealp.Mark;
11558       R := (U = UR_Trunc (U / S) * S);
11559       Urealp.Release (M);
11560       return R;
11561    end Is_Fixed_Model_Number;
11562
11563    -------------------------------
11564    -- Is_Fully_Initialized_Type --
11565    -------------------------------
11566
11567    function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
11568    begin
11569       --  Scalar types
11570
11571       if Is_Scalar_Type (Typ) then
11572
11573          --  A scalar type with an aspect Default_Value is fully initialized
11574
11575          --  Note: Iniitalize/Normalize_Scalars also ensure full initialization
11576          --  of a scalar type, but we don't take that into account here, since
11577          --  we don't want these to affect warnings.
11578
11579          return Has_Default_Aspect (Typ);
11580
11581       elsif Is_Access_Type (Typ) then
11582          return True;
11583
11584       elsif Is_Array_Type (Typ) then
11585          if Is_Fully_Initialized_Type (Component_Type (Typ))
11586            or else (Ada_Version >= Ada_2012 and then Has_Default_Aspect (Typ))
11587          then
11588             return True;
11589          end if;
11590
11591          --  An interesting case, if we have a constrained type one of whose
11592          --  bounds is known to be null, then there are no elements to be
11593          --  initialized, so all the elements are initialized.
11594
11595          if Is_Constrained (Typ) then
11596             declare
11597                Indx     : Node_Id;
11598                Indx_Typ : Entity_Id;
11599                Lbd, Hbd : Node_Id;
11600
11601             begin
11602                Indx := First_Index (Typ);
11603                while Present (Indx) loop
11604                   if Etype (Indx) = Any_Type then
11605                      return False;
11606
11607                   --  If index is a range, use directly
11608
11609                   elsif Nkind (Indx) = N_Range then
11610                      Lbd := Low_Bound  (Indx);
11611                      Hbd := High_Bound (Indx);
11612
11613                   else
11614                      Indx_Typ := Etype (Indx);
11615
11616                      if Is_Private_Type (Indx_Typ)  then
11617                         Indx_Typ := Full_View (Indx_Typ);
11618                      end if;
11619
11620                      if No (Indx_Typ) or else Etype (Indx_Typ) = Any_Type then
11621                         return False;
11622                      else
11623                         Lbd := Type_Low_Bound  (Indx_Typ);
11624                         Hbd := Type_High_Bound (Indx_Typ);
11625                      end if;
11626                   end if;
11627
11628                   if Compile_Time_Known_Value (Lbd)
11629                        and then
11630                      Compile_Time_Known_Value (Hbd)
11631                   then
11632                      if Expr_Value (Hbd) < Expr_Value (Lbd) then
11633                         return True;
11634                      end if;
11635                   end if;
11636
11637                   Next_Index (Indx);
11638                end loop;
11639             end;
11640          end if;
11641
11642          --  If no null indexes, then type is not fully initialized
11643
11644          return False;
11645
11646       --  Record types
11647
11648       elsif Is_Record_Type (Typ) then
11649          if Has_Discriminants (Typ)
11650            and then
11651              Present (Discriminant_Default_Value (First_Discriminant (Typ)))
11652            and then Is_Fully_Initialized_Variant (Typ)
11653          then
11654             return True;
11655          end if;
11656
11657          --  We consider bounded string types to be fully initialized, because
11658          --  otherwise we get false alarms when the Data component is not
11659          --  default-initialized.
11660
11661          if Is_Bounded_String (Typ) then
11662             return True;
11663          end if;
11664
11665          --  Controlled records are considered to be fully initialized if
11666          --  there is a user defined Initialize routine. This may not be
11667          --  entirely correct, but as the spec notes, we are guessing here
11668          --  what is best from the point of view of issuing warnings.
11669
11670          if Is_Controlled (Typ) then
11671             declare
11672                Utyp : constant Entity_Id := Underlying_Type (Typ);
11673
11674             begin
11675                if Present (Utyp) then
11676                   declare
11677                      Init : constant Entity_Id :=
11678                               (Find_Optional_Prim_Op
11679                                  (Underlying_Type (Typ), Name_Initialize));
11680
11681                   begin
11682                      if Present (Init)
11683                        and then Comes_From_Source (Init)
11684                        and then not
11685                          Is_Predefined_File_Name
11686                            (File_Name (Get_Source_File_Index (Sloc (Init))))
11687                      then
11688                         return True;
11689
11690                      elsif Has_Null_Extension (Typ)
11691                         and then
11692                           Is_Fully_Initialized_Type
11693                             (Etype (Base_Type (Typ)))
11694                      then
11695                         return True;
11696                      end if;
11697                   end;
11698                end if;
11699             end;
11700          end if;
11701
11702          --  Otherwise see if all record components are initialized
11703
11704          declare
11705             Ent : Entity_Id;
11706
11707          begin
11708             Ent := First_Entity (Typ);
11709             while Present (Ent) loop
11710                if Ekind (Ent) = E_Component
11711                  and then (No (Parent (Ent))
11712                             or else No (Expression (Parent (Ent))))
11713                  and then not Is_Fully_Initialized_Type (Etype (Ent))
11714
11715                   --  Special VM case for tag components, which need to be
11716                   --  defined in this case, but are never initialized as VMs
11717                   --  are using other dispatching mechanisms. Ignore this
11718                   --  uninitialized case. Note that this applies both to the
11719                   --  uTag entry and the main vtable pointer (CPP_Class case).
11720
11721                  and then (Tagged_Type_Expansion or else not Is_Tag (Ent))
11722                then
11723                   return False;
11724                end if;
11725
11726                Next_Entity (Ent);
11727             end loop;
11728          end;
11729
11730          --  No uninitialized components, so type is fully initialized.
11731          --  Note that this catches the case of no components as well.
11732
11733          return True;
11734
11735       elsif Is_Concurrent_Type (Typ) then
11736          return True;
11737
11738       elsif Is_Private_Type (Typ) then
11739          declare
11740             U : constant Entity_Id := Underlying_Type (Typ);
11741
11742          begin
11743             if No (U) then
11744                return False;
11745             else
11746                return Is_Fully_Initialized_Type (U);
11747             end if;
11748          end;
11749
11750       else
11751          return False;
11752       end if;
11753    end Is_Fully_Initialized_Type;
11754
11755    ----------------------------------
11756    -- Is_Fully_Initialized_Variant --
11757    ----------------------------------
11758
11759    function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
11760       Loc           : constant Source_Ptr := Sloc (Typ);
11761       Constraints   : constant List_Id    := New_List;
11762       Components    : constant Elist_Id   := New_Elmt_List;
11763       Comp_Elmt     : Elmt_Id;
11764       Comp_Id       : Node_Id;
11765       Comp_List     : Node_Id;
11766       Discr         : Entity_Id;
11767       Discr_Val     : Node_Id;
11768
11769       Report_Errors : Boolean;
11770       pragma Warnings (Off, Report_Errors);
11771
11772    begin
11773       if Serious_Errors_Detected > 0 then
11774          return False;
11775       end if;
11776
11777       if Is_Record_Type (Typ)
11778         and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
11779         and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
11780       then
11781          Comp_List := Component_List (Type_Definition (Parent (Typ)));
11782
11783          Discr := First_Discriminant (Typ);
11784          while Present (Discr) loop
11785             if Nkind (Parent (Discr)) = N_Discriminant_Specification then
11786                Discr_Val := Expression (Parent (Discr));
11787
11788                if Present (Discr_Val)
11789                  and then Is_OK_Static_Expression (Discr_Val)
11790                then
11791                   Append_To (Constraints,
11792                     Make_Component_Association (Loc,
11793                       Choices    => New_List (New_Occurrence_Of (Discr, Loc)),
11794                       Expression => New_Copy (Discr_Val)));
11795                else
11796                   return False;
11797                end if;
11798             else
11799                return False;
11800             end if;
11801
11802             Next_Discriminant (Discr);
11803          end loop;
11804
11805          Gather_Components
11806            (Typ           => Typ,
11807             Comp_List     => Comp_List,
11808             Governed_By   => Constraints,
11809             Into          => Components,
11810             Report_Errors => Report_Errors);
11811
11812          --  Check that each component present is fully initialized
11813
11814          Comp_Elmt := First_Elmt (Components);
11815          while Present (Comp_Elmt) loop
11816             Comp_Id := Node (Comp_Elmt);
11817
11818             if Ekind (Comp_Id) = E_Component
11819               and then (No (Parent (Comp_Id))
11820                          or else No (Expression (Parent (Comp_Id))))
11821               and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
11822             then
11823                return False;
11824             end if;
11825
11826             Next_Elmt (Comp_Elmt);
11827          end loop;
11828
11829          return True;
11830
11831       elsif Is_Private_Type (Typ) then
11832          declare
11833             U : constant Entity_Id := Underlying_Type (Typ);
11834
11835          begin
11836             if No (U) then
11837                return False;
11838             else
11839                return Is_Fully_Initialized_Variant (U);
11840             end if;
11841          end;
11842
11843       else
11844          return False;
11845       end if;
11846    end Is_Fully_Initialized_Variant;
11847
11848    ------------------------------------
11849    -- Is_Generic_Declaration_Or_Body --
11850    ------------------------------------
11851
11852    function Is_Generic_Declaration_Or_Body (Decl : Node_Id) return Boolean is
11853       Spec_Decl : Node_Id;
11854
11855    begin
11856       --  Package/subprogram body
11857
11858       if Nkind_In (Decl, N_Package_Body, N_Subprogram_Body)
11859         and then Present (Corresponding_Spec (Decl))
11860       then
11861          Spec_Decl := Unit_Declaration_Node (Corresponding_Spec (Decl));
11862
11863       --  Package/subprogram body stub
11864
11865       elsif Nkind_In (Decl, N_Package_Body_Stub, N_Subprogram_Body_Stub)
11866         and then Present (Corresponding_Spec_Of_Stub (Decl))
11867       then
11868          Spec_Decl :=
11869            Unit_Declaration_Node (Corresponding_Spec_Of_Stub (Decl));
11870
11871       --  All other cases
11872
11873       else
11874          Spec_Decl := Decl;
11875       end if;
11876
11877       --  Rather than inspecting the defining entity of the spec declaration,
11878       --  look at its Nkind. This takes care of the case where the analysis of
11879       --  a generic body modifies the Ekind of its spec to allow for recursive
11880       --  calls.
11881
11882       return
11883         Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
11884                              N_Generic_Subprogram_Declaration);
11885    end Is_Generic_Declaration_Or_Body;
11886
11887    ----------------------------
11888    -- Is_Inherited_Operation --
11889    ----------------------------
11890
11891    function Is_Inherited_Operation (E : Entity_Id) return Boolean is
11892       pragma Assert (Is_Overloadable (E));
11893       Kind : constant Node_Kind := Nkind (Parent (E));
11894    begin
11895       return Kind = N_Full_Type_Declaration
11896         or else Kind = N_Private_Extension_Declaration
11897         or else Kind = N_Subtype_Declaration
11898         or else (Ekind (E) = E_Enumeration_Literal
11899                   and then Is_Derived_Type (Etype (E)));
11900    end Is_Inherited_Operation;
11901
11902    -------------------------------------
11903    -- Is_Inherited_Operation_For_Type --
11904    -------------------------------------
11905
11906    function Is_Inherited_Operation_For_Type
11907      (E   : Entity_Id;
11908       Typ : Entity_Id) return Boolean
11909    is
11910    begin
11911       --  Check that the operation has been created by the type declaration
11912
11913       return Is_Inherited_Operation (E)
11914         and then Defining_Identifier (Parent (E)) = Typ;
11915    end Is_Inherited_Operation_For_Type;
11916
11917    -----------------
11918    -- Is_Iterator --
11919    -----------------
11920
11921    function Is_Iterator (Typ : Entity_Id) return Boolean is
11922       function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean;
11923       --  Determine whether type Iter_Typ is a predefined forward or reversible
11924       --  iterator.
11925
11926       ----------------------
11927       -- Denotes_Iterator --
11928       ----------------------
11929
11930       function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is
11931       begin
11932          return
11933            Nam_In (Chars (Iter_Typ), Name_Forward_Iterator,
11934                                      Name_Reversible_Iterator)
11935              and then Is_Predefined_File_Name
11936                         (Unit_File_Name (Get_Source_Unit (Iter_Typ)));
11937       end Denotes_Iterator;
11938
11939       --  Local variables
11940
11941       Iface_Elmt : Elmt_Id;
11942       Ifaces     : Elist_Id;
11943
11944    --  Start of processing for Is_Iterator
11945
11946    begin
11947       --  The type may be a subtype of a descendant of the proper instance of
11948       --  the predefined interface type, so we must use the root type of the
11949       --  given type. The same is done for Is_Reversible_Iterator.
11950
11951       if Is_Class_Wide_Type (Typ)
11952         and then Denotes_Iterator (Root_Type (Typ))
11953       then
11954          return True;
11955
11956       elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
11957          return False;
11958
11959       elsif Present (Find_Value_Of_Aspect (Typ, Aspect_Iterable)) then
11960          return True;
11961
11962       else
11963          Collect_Interfaces (Typ, Ifaces);
11964
11965          Iface_Elmt := First_Elmt (Ifaces);
11966          while Present (Iface_Elmt) loop
11967             if Denotes_Iterator (Node (Iface_Elmt)) then
11968                return True;
11969             end if;
11970
11971             Next_Elmt (Iface_Elmt);
11972          end loop;
11973
11974          return False;
11975       end if;
11976    end Is_Iterator;
11977
11978    ----------------------------
11979    -- Is_Iterator_Over_Array --
11980    ----------------------------
11981
11982    function Is_Iterator_Over_Array (N : Node_Id) return Boolean is
11983       Container     : constant Node_Id   := Name (N);
11984       Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
11985    begin
11986       return Is_Array_Type (Container_Typ);
11987    end Is_Iterator_Over_Array;
11988
11989    ------------
11990    -- Is_LHS --
11991    ------------
11992
11993    --  We seem to have a lot of overlapping functions that do similar things
11994    --  (testing for left hand sides or lvalues???).
11995
11996    function Is_LHS (N : Node_Id) return Is_LHS_Result is
11997       P : constant Node_Id := Parent (N);
11998
11999    begin
12000       --  Return True if we are the left hand side of an assignment statement
12001
12002       if Nkind (P) = N_Assignment_Statement then
12003          if Name (P) = N then
12004             return Yes;
12005          else
12006             return No;
12007          end if;
12008
12009       --  Case of prefix of indexed or selected component or slice
12010
12011       elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component, N_Slice)
12012         and then N = Prefix (P)
12013       then
12014          --  Here we have the case where the parent P is N.Q or N(Q .. R).
12015          --  If P is an LHS, then N is also effectively an LHS, but there
12016          --  is an important exception. If N is of an access type, then
12017          --  what we really have is N.all.Q (or N.all(Q .. R)). In either
12018          --  case this makes N.all a left hand side but not N itself.
12019
12020          --  If we don't know the type yet, this is the case where we return
12021          --  Unknown, since the answer depends on the type which is unknown.
12022
12023          if No (Etype (N)) then
12024             return Unknown;
12025
12026          --  We have an Etype set, so we can check it
12027
12028          elsif Is_Access_Type (Etype (N)) then
12029             return No;
12030
12031          --  OK, not access type case, so just test whole expression
12032
12033          else
12034             return Is_LHS (P);
12035          end if;
12036
12037       --  All other cases are not left hand sides
12038
12039       else
12040          return No;
12041       end if;
12042    end Is_LHS;
12043
12044    -----------------------------
12045    -- Is_Library_Level_Entity --
12046    -----------------------------
12047
12048    function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
12049    begin
12050       --  The following is a small optimization, and it also properly handles
12051       --  discriminals, which in task bodies might appear in expressions before
12052       --  the corresponding procedure has been created, and which therefore do
12053       --  not have an assigned scope.
12054
12055       if Is_Formal (E) then
12056          return False;
12057       end if;
12058
12059       --  Normal test is simply that the enclosing dynamic scope is Standard
12060
12061       return Enclosing_Dynamic_Scope (E) = Standard_Standard;
12062    end Is_Library_Level_Entity;
12063
12064    --------------------------------
12065    -- Is_Limited_Class_Wide_Type --
12066    --------------------------------
12067
12068    function Is_Limited_Class_Wide_Type (Typ : Entity_Id) return Boolean is
12069    begin
12070       return
12071         Is_Class_Wide_Type (Typ)
12072           and then (Is_Limited_Type (Typ) or else From_Limited_With (Typ));
12073    end Is_Limited_Class_Wide_Type;
12074
12075    ---------------------------------
12076    -- Is_Local_Variable_Reference --
12077    ---------------------------------
12078
12079    function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
12080    begin
12081       if not Is_Entity_Name (Expr) then
12082          return False;
12083
12084       else
12085          declare
12086             Ent : constant Entity_Id := Entity (Expr);
12087             Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
12088          begin
12089             if not Ekind_In (Ent, E_Variable, E_In_Out_Parameter) then
12090                return False;
12091             else
12092                return Present (Sub) and then Sub = Current_Subprogram;
12093             end if;
12094          end;
12095       end if;
12096    end Is_Local_Variable_Reference;
12097
12098    -------------------------
12099    -- Is_Object_Reference --
12100    -------------------------
12101
12102    function Is_Object_Reference (N : Node_Id) return Boolean is
12103
12104       function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean;
12105       --  Determine whether N is the name of an internally-generated renaming
12106
12107       --------------------------------------
12108       -- Is_Internally_Generated_Renaming --
12109       --------------------------------------
12110
12111       function Is_Internally_Generated_Renaming (N : Node_Id) return Boolean is
12112          P : Node_Id;
12113
12114       begin
12115          P := N;
12116          while Present (P) loop
12117             if Nkind (P) = N_Object_Renaming_Declaration then
12118                return not Comes_From_Source (P);
12119             elsif Is_List_Member (P) then
12120                return False;
12121             end if;
12122
12123             P := Parent (P);
12124          end loop;
12125
12126          return False;
12127       end Is_Internally_Generated_Renaming;
12128
12129    --  Start of processing for Is_Object_Reference
12130
12131    begin
12132       if Is_Entity_Name (N) then
12133          return Present (Entity (N)) and then Is_Object (Entity (N));
12134
12135       else
12136          case Nkind (N) is
12137             when N_Indexed_Component | N_Slice =>
12138                return
12139                  Is_Object_Reference (Prefix (N))
12140                    or else Is_Access_Type (Etype (Prefix (N)));
12141
12142             --  In Ada 95, a function call is a constant object; a procedure
12143             --  call is not.
12144
12145             when N_Function_Call =>
12146                return Etype (N) /= Standard_Void_Type;
12147
12148             --  Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce
12149             --  objects.
12150
12151             when N_Attribute_Reference =>
12152                return
12153                  Nam_In (Attribute_Name (N), Name_Input,
12154                                              Name_Loop_Entry,
12155                                              Name_Old,
12156                                              Name_Result);
12157
12158             when N_Selected_Component =>
12159                return
12160                  Is_Object_Reference (Selector_Name (N))
12161                    and then
12162                      (Is_Object_Reference (Prefix (N))
12163                        or else Is_Access_Type (Etype (Prefix (N))));
12164
12165             when N_Explicit_Dereference =>
12166                return True;
12167
12168             --  A view conversion of a tagged object is an object reference
12169
12170             when N_Type_Conversion =>
12171                return Is_Tagged_Type (Etype (Subtype_Mark (N)))
12172                  and then Is_Tagged_Type (Etype (Expression (N)))
12173                  and then Is_Object_Reference (Expression (N));
12174
12175             --  An unchecked type conversion is considered to be an object if
12176             --  the operand is an object (this construction arises only as a
12177             --  result of expansion activities).
12178
12179             when N_Unchecked_Type_Conversion =>
12180                return True;
12181
12182             --  Allow string literals to act as objects as long as they appear
12183             --  in internally-generated renamings. The expansion of iterators
12184             --  may generate such renamings when the range involves a string
12185             --  literal.
12186
12187             when N_String_Literal =>
12188                return Is_Internally_Generated_Renaming (Parent (N));
12189
12190             --  AI05-0003: In Ada 2012 a qualified expression is a name.
12191             --  This allows disambiguation of function calls and the use
12192             --  of aggregates in more contexts.
12193
12194             when N_Qualified_Expression =>
12195                if Ada_Version <  Ada_2012 then
12196                   return False;
12197                else
12198                   return Is_Object_Reference (Expression (N))
12199                     or else Nkind (Expression (N)) = N_Aggregate;
12200                end if;
12201
12202             when others =>
12203                return False;
12204          end case;
12205       end if;
12206    end Is_Object_Reference;
12207
12208    -----------------------------------
12209    -- Is_OK_Variable_For_Out_Formal --
12210    -----------------------------------
12211
12212    function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
12213    begin
12214       Note_Possible_Modification (AV, Sure => True);
12215
12216       --  We must reject parenthesized variable names. Comes_From_Source is
12217       --  checked because there are currently cases where the compiler violates
12218       --  this rule (e.g. passing a task object to its controlled Initialize
12219       --  routine). This should be properly documented in sinfo???
12220
12221       if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
12222          return False;
12223
12224       --  A variable is always allowed
12225
12226       elsif Is_Variable (AV) then
12227          return True;
12228
12229       --  Generalized indexing operations are rewritten as explicit
12230       --  dereferences, and it is only during resolution that we can
12231       --  check whether the context requires an access_to_variable type.
12232
12233       elsif Nkind (AV) = N_Explicit_Dereference
12234         and then Ada_Version >= Ada_2012
12235         and then Nkind (Original_Node (AV)) = N_Indexed_Component
12236         and then Present (Etype (Original_Node (AV)))
12237         and then Has_Implicit_Dereference (Etype (Original_Node (AV)))
12238       then
12239          return not Is_Access_Constant (Etype (Prefix (AV)));
12240
12241       --  Unchecked conversions are allowed only if they come from the
12242       --  generated code, which sometimes uses unchecked conversions for out
12243       --  parameters in cases where code generation is unaffected. We tell
12244       --  source unchecked conversions by seeing if they are rewrites of
12245       --  an original Unchecked_Conversion function call, or of an explicit
12246       --  conversion of a function call or an aggregate (as may happen in the
12247       --  expansion of a packed array aggregate).
12248
12249       elsif Nkind (AV) = N_Unchecked_Type_Conversion then
12250          if Nkind_In (Original_Node (AV), N_Function_Call, N_Aggregate) then
12251             return False;
12252
12253          elsif Comes_From_Source (AV)
12254            and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
12255          then
12256             return False;
12257
12258          elsif Nkind (Original_Node (AV)) = N_Type_Conversion then
12259             return Is_OK_Variable_For_Out_Formal (Expression (AV));
12260
12261          else
12262             return True;
12263          end if;
12264
12265       --  Normal type conversions are allowed if argument is a variable
12266
12267       elsif Nkind (AV) = N_Type_Conversion then
12268          if Is_Variable (Expression (AV))
12269            and then Paren_Count (Expression (AV)) = 0
12270          then
12271             Note_Possible_Modification (Expression (AV), Sure => True);
12272             return True;
12273
12274          --  We also allow a non-parenthesized expression that raises
12275          --  constraint error if it rewrites what used to be a variable
12276
12277          elsif Raises_Constraint_Error (Expression (AV))
12278             and then Paren_Count (Expression (AV)) = 0
12279             and then Is_Variable (Original_Node (Expression (AV)))
12280          then
12281             return True;
12282
12283          --  Type conversion of something other than a variable
12284
12285          else
12286             return False;
12287          end if;
12288
12289       --  If this node is rewritten, then test the original form, if that is
12290       --  OK, then we consider the rewritten node OK (for example, if the
12291       --  original node is a conversion, then Is_Variable will not be true
12292       --  but we still want to allow the conversion if it converts a variable).
12293
12294       elsif Original_Node (AV) /= AV then
12295
12296          --  In Ada 2012, the explicit dereference may be a rewritten call to a
12297          --  Reference function.
12298
12299          if Ada_Version >= Ada_2012
12300            and then Nkind (Original_Node (AV)) = N_Function_Call
12301            and then
12302              Has_Implicit_Dereference (Etype (Name (Original_Node (AV))))
12303          then
12304
12305             --  Check that this is not a constant reference.
12306
12307             return not Is_Access_Constant (Etype (Prefix (AV)));
12308
12309          elsif Has_Implicit_Dereference (Etype (Original_Node (AV))) then
12310             return
12311               not Is_Access_Constant (Etype
12312                 (Get_Reference_Discriminant (Etype (Original_Node (AV)))));
12313
12314          else
12315             return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
12316          end if;
12317
12318       --  All other non-variables are rejected
12319
12320       else
12321          return False;
12322       end if;
12323    end Is_OK_Variable_For_Out_Formal;
12324
12325    ------------------------------------
12326    -- Is_Package_Contract_Annotation --
12327    ------------------------------------
12328
12329    function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean is
12330       Nam : Name_Id;
12331
12332    begin
12333       if Nkind (Item) = N_Aspect_Specification then
12334          Nam := Chars (Identifier (Item));
12335
12336       else pragma Assert (Nkind (Item) = N_Pragma);
12337          Nam := Pragma_Name (Item);
12338       end if;
12339
12340       return    Nam = Name_Abstract_State
12341         or else Nam = Name_Initial_Condition
12342         or else Nam = Name_Initializes
12343         or else Nam = Name_Refined_State;
12344    end Is_Package_Contract_Annotation;
12345
12346    -----------------------------------
12347    -- Is_Partially_Initialized_Type --
12348    -----------------------------------
12349
12350    function Is_Partially_Initialized_Type
12351      (Typ              : Entity_Id;
12352       Include_Implicit : Boolean := True) return Boolean
12353    is
12354    begin
12355       if Is_Scalar_Type (Typ) then
12356          return False;
12357
12358       elsif Is_Access_Type (Typ) then
12359          return Include_Implicit;
12360
12361       elsif Is_Array_Type (Typ) then
12362
12363          --  If component type is partially initialized, so is array type
12364
12365          if Is_Partially_Initialized_Type
12366               (Component_Type (Typ), Include_Implicit)
12367          then
12368             return True;
12369
12370          --  Otherwise we are only partially initialized if we are fully
12371          --  initialized (this is the empty array case, no point in us
12372          --  duplicating that code here).
12373
12374          else
12375             return Is_Fully_Initialized_Type (Typ);
12376          end if;
12377
12378       elsif Is_Record_Type (Typ) then
12379
12380          --  A discriminated type is always partially initialized if in
12381          --  all mode
12382
12383          if Has_Discriminants (Typ) and then Include_Implicit then
12384             return True;
12385
12386          --  A tagged type is always partially initialized
12387
12388          elsif Is_Tagged_Type (Typ) then
12389             return True;
12390
12391          --  Case of non-discriminated record
12392
12393          else
12394             declare
12395                Ent : Entity_Id;
12396
12397                Component_Present : Boolean := False;
12398                --  Set True if at least one component is present. If no
12399                --  components are present, then record type is fully
12400                --  initialized (another odd case, like the null array).
12401
12402             begin
12403                --  Loop through components
12404
12405                Ent := First_Entity (Typ);
12406                while Present (Ent) loop
12407                   if Ekind (Ent) = E_Component then
12408                      Component_Present := True;
12409
12410                      --  If a component has an initialization expression then
12411                      --  the enclosing record type is partially initialized
12412
12413                      if Present (Parent (Ent))
12414                        and then Present (Expression (Parent (Ent)))
12415                      then
12416                         return True;
12417
12418                      --  If a component is of a type which is itself partially
12419                      --  initialized, then the enclosing record type is also.
12420
12421                      elsif Is_Partially_Initialized_Type
12422                              (Etype (Ent), Include_Implicit)
12423                      then
12424                         return True;
12425                      end if;
12426                   end if;
12427
12428                   Next_Entity (Ent);
12429                end loop;
12430
12431                --  No initialized components found. If we found any components
12432                --  they were all uninitialized so the result is false.
12433
12434                if Component_Present then
12435                   return False;
12436
12437                --  But if we found no components, then all the components are
12438                --  initialized so we consider the type to be initialized.
12439
12440                else
12441                   return True;
12442                end if;
12443             end;
12444          end if;
12445
12446       --  Concurrent types are always fully initialized
12447
12448       elsif Is_Concurrent_Type (Typ) then
12449          return True;
12450
12451       --  For a private type, go to underlying type. If there is no underlying
12452       --  type then just assume this partially initialized. Not clear if this
12453       --  can happen in a non-error case, but no harm in testing for this.
12454
12455       elsif Is_Private_Type (Typ) then
12456          declare
12457             U : constant Entity_Id := Underlying_Type (Typ);
12458          begin
12459             if No (U) then
12460                return True;
12461             else
12462                return Is_Partially_Initialized_Type (U, Include_Implicit);
12463             end if;
12464          end;
12465
12466       --  For any other type (are there any?) assume partially initialized
12467
12468       else
12469          return True;
12470       end if;
12471    end Is_Partially_Initialized_Type;
12472
12473    ------------------------------------
12474    -- Is_Potentially_Persistent_Type --
12475    ------------------------------------
12476
12477    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean is
12478       Comp : Entity_Id;
12479       Indx : Node_Id;
12480
12481    begin
12482       --  For private type, test corresponding full type
12483
12484       if Is_Private_Type (T) then
12485          return Is_Potentially_Persistent_Type (Full_View (T));
12486
12487       --  Scalar types are potentially persistent
12488
12489       elsif Is_Scalar_Type (T) then
12490          return True;
12491
12492       --  Record type is potentially persistent if not tagged and the types of
12493       --  all it components are potentially persistent, and no component has
12494       --  an initialization expression.
12495
12496       elsif Is_Record_Type (T)
12497         and then not Is_Tagged_Type (T)
12498         and then not Is_Partially_Initialized_Type (T)
12499       then
12500          Comp := First_Component (T);
12501          while Present (Comp) loop
12502             if not Is_Potentially_Persistent_Type (Etype (Comp)) then
12503                return False;
12504             else
12505                Next_Entity (Comp);
12506             end if;
12507          end loop;
12508
12509          return True;
12510
12511       --  Array type is potentially persistent if its component type is
12512       --  potentially persistent and if all its constraints are static.
12513
12514       elsif Is_Array_Type (T) then
12515          if not Is_Potentially_Persistent_Type (Component_Type (T)) then
12516             return False;
12517          end if;
12518
12519          Indx := First_Index (T);
12520          while Present (Indx) loop
12521             if not Is_OK_Static_Subtype (Etype (Indx)) then
12522                return False;
12523             else
12524                Next_Index (Indx);
12525             end if;
12526          end loop;
12527
12528          return True;
12529
12530       --  All other types are not potentially persistent
12531
12532       else
12533          return False;
12534       end if;
12535    end Is_Potentially_Persistent_Type;
12536
12537    --------------------------------
12538    -- Is_Potentially_Unevaluated --
12539    --------------------------------
12540
12541    function Is_Potentially_Unevaluated (N : Node_Id) return Boolean is
12542       Par  : Node_Id;
12543       Expr : Node_Id;
12544
12545    begin
12546       Expr := N;
12547       Par  := Parent (N);
12548
12549       --  A postcondition whose expression is a short-circuit is broken down
12550       --  into individual aspects for better exception reporting. The original
12551       --  short-circuit expression is rewritten as the second operand, and an
12552       --  occurrence of 'Old in that operand is potentially unevaluated.
12553       --  See Sem_ch13.adb for details of this transformation.
12554
12555       if Nkind (Original_Node (Par)) = N_And_Then then
12556          return True;
12557       end if;
12558
12559       while not Nkind_In (Par, N_If_Expression,
12560                                N_Case_Expression,
12561                                N_And_Then,
12562                                N_Or_Else,
12563                                N_In,
12564                                N_Not_In)
12565       loop
12566          Expr := Par;
12567          Par  := Parent (Par);
12568
12569          --  If the context is not an expression, or if is the result of
12570          --  expansion of an enclosing construct (such as another attribute)
12571          --  the predicate does not apply.
12572
12573          if Nkind (Par) not in N_Subexpr
12574            or else not Comes_From_Source (Par)
12575          then
12576             return False;
12577          end if;
12578       end loop;
12579
12580       if Nkind (Par) = N_If_Expression then
12581          return Is_Elsif (Par) or else Expr /= First (Expressions (Par));
12582
12583       elsif Nkind (Par) = N_Case_Expression then
12584          return Expr /= Expression (Par);
12585
12586       elsif Nkind_In (Par, N_And_Then, N_Or_Else) then
12587          return Expr = Right_Opnd (Par);
12588
12589       elsif Nkind_In (Par, N_In, N_Not_In) then
12590          return Expr /= Left_Opnd (Par);
12591
12592       else
12593          return False;
12594       end if;
12595    end Is_Potentially_Unevaluated;
12596
12597    ---------------------------------
12598    -- Is_Protected_Self_Reference --
12599    ---------------------------------
12600
12601    function Is_Protected_Self_Reference (N : Node_Id) return Boolean is
12602
12603       function In_Access_Definition (N : Node_Id) return Boolean;
12604       --  Returns true if N belongs to an access definition
12605
12606       --------------------------
12607       -- In_Access_Definition --
12608       --------------------------
12609
12610       function In_Access_Definition (N : Node_Id) return Boolean is
12611          P : Node_Id;
12612
12613       begin
12614          P := Parent (N);
12615          while Present (P) loop
12616             if Nkind (P) = N_Access_Definition then
12617                return True;
12618             end if;
12619
12620             P := Parent (P);
12621          end loop;
12622
12623          return False;
12624       end In_Access_Definition;
12625
12626    --  Start of processing for Is_Protected_Self_Reference
12627
12628    begin
12629       --  Verify that prefix is analyzed and has the proper form. Note that
12630       --  the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also
12631       --  produce the address of an entity, do not analyze their prefix
12632       --  because they denote entities that are not necessarily visible.
12633       --  Neither of them can apply to a protected type.
12634
12635       return Ada_Version >= Ada_2005
12636         and then Is_Entity_Name (N)
12637         and then Present (Entity (N))
12638         and then Is_Protected_Type (Entity (N))
12639         and then In_Open_Scopes (Entity (N))
12640         and then not In_Access_Definition (N);
12641    end Is_Protected_Self_Reference;
12642
12643    -----------------------------
12644    -- Is_RCI_Pkg_Spec_Or_Body --
12645    -----------------------------
12646
12647    function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
12648
12649       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
12650       --  Return True if the unit of Cunit is an RCI package declaration
12651
12652       ---------------------------
12653       -- Is_RCI_Pkg_Decl_Cunit --
12654       ---------------------------
12655
12656       function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
12657          The_Unit : constant Node_Id := Unit (Cunit);
12658
12659       begin
12660          if Nkind (The_Unit) /= N_Package_Declaration then
12661             return False;
12662          end if;
12663
12664          return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
12665       end Is_RCI_Pkg_Decl_Cunit;
12666
12667    --  Start of processing for Is_RCI_Pkg_Spec_Or_Body
12668
12669    begin
12670       return Is_RCI_Pkg_Decl_Cunit (Cunit)
12671         or else
12672          (Nkind (Unit (Cunit)) = N_Package_Body
12673            and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
12674    end Is_RCI_Pkg_Spec_Or_Body;
12675
12676    -----------------------------------------
12677    -- Is_Remote_Access_To_Class_Wide_Type --
12678    -----------------------------------------
12679
12680    function Is_Remote_Access_To_Class_Wide_Type
12681      (E : Entity_Id) return Boolean
12682    is
12683    begin
12684       --  A remote access to class-wide type is a general access to object type
12685       --  declared in the visible part of a Remote_Types or Remote_Call_
12686       --  Interface unit.
12687
12688       return Ekind (E) = E_General_Access_Type
12689         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
12690    end Is_Remote_Access_To_Class_Wide_Type;
12691
12692    -----------------------------------------
12693    -- Is_Remote_Access_To_Subprogram_Type --
12694    -----------------------------------------
12695
12696    function Is_Remote_Access_To_Subprogram_Type
12697      (E : Entity_Id) return Boolean
12698    is
12699    begin
12700       return (Ekind (E) = E_Access_Subprogram_Type
12701                 or else (Ekind (E) = E_Record_Type
12702                           and then Present (Corresponding_Remote_Type (E))))
12703         and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E));
12704    end Is_Remote_Access_To_Subprogram_Type;
12705
12706    --------------------
12707    -- Is_Remote_Call --
12708    --------------------
12709
12710    function Is_Remote_Call (N : Node_Id) return Boolean is
12711    begin
12712       if Nkind (N) not in N_Subprogram_Call then
12713
12714          --  An entry call cannot be remote
12715
12716          return False;
12717
12718       elsif Nkind (Name (N)) in N_Has_Entity
12719         and then Is_Remote_Call_Interface (Entity (Name (N)))
12720       then
12721          --  A subprogram declared in the spec of a RCI package is remote
12722
12723          return True;
12724
12725       elsif Nkind (Name (N)) = N_Explicit_Dereference
12726         and then Is_Remote_Access_To_Subprogram_Type
12727                    (Etype (Prefix (Name (N))))
12728       then
12729          --  The dereference of a RAS is a remote call
12730
12731          return True;
12732
12733       elsif Present (Controlling_Argument (N))
12734         and then Is_Remote_Access_To_Class_Wide_Type
12735                    (Etype (Controlling_Argument (N)))
12736       then
12737          --  Any primitive operation call with a controlling argument of
12738          --  a RACW type is a remote call.
12739
12740          return True;
12741       end if;
12742
12743       --  All other calls are local calls
12744
12745       return False;
12746    end Is_Remote_Call;
12747
12748    ----------------------
12749    -- Is_Renamed_Entry --
12750    ----------------------
12751
12752    function Is_Renamed_Entry (Proc_Nam : Entity_Id) return Boolean is
12753       Orig_Node : Node_Id := Empty;
12754       Subp_Decl : Node_Id := Parent (Parent (Proc_Nam));
12755
12756       function Is_Entry (Nam : Node_Id) return Boolean;
12757       --  Determine whether Nam is an entry. Traverse selectors if there are
12758       --  nested selected components.
12759
12760       --------------
12761       -- Is_Entry --
12762       --------------
12763
12764       function Is_Entry (Nam : Node_Id) return Boolean is
12765       begin
12766          if Nkind (Nam) = N_Selected_Component then
12767             return Is_Entry (Selector_Name (Nam));
12768          end if;
12769
12770          return Ekind (Entity (Nam)) = E_Entry;
12771       end Is_Entry;
12772
12773    --  Start of processing for Is_Renamed_Entry
12774
12775    begin
12776       if Present (Alias (Proc_Nam)) then
12777          Subp_Decl := Parent (Parent (Alias (Proc_Nam)));
12778       end if;
12779
12780       --  Look for a rewritten subprogram renaming declaration
12781
12782       if Nkind (Subp_Decl) = N_Subprogram_Declaration
12783         and then Present (Original_Node (Subp_Decl))
12784       then
12785          Orig_Node := Original_Node (Subp_Decl);
12786       end if;
12787
12788       --  The rewritten subprogram is actually an entry
12789
12790       if Present (Orig_Node)
12791         and then Nkind (Orig_Node) = N_Subprogram_Renaming_Declaration
12792         and then Is_Entry (Name (Orig_Node))
12793       then
12794          return True;
12795       end if;
12796
12797       return False;
12798    end Is_Renamed_Entry;
12799
12800    -----------------------------
12801    -- Is_Renaming_Declaration --
12802    -----------------------------
12803
12804    function Is_Renaming_Declaration (N : Node_Id) return Boolean is
12805    begin
12806       case Nkind (N) is
12807          when N_Exception_Renaming_Declaration         |
12808               N_Generic_Function_Renaming_Declaration  |
12809               N_Generic_Package_Renaming_Declaration   |
12810               N_Generic_Procedure_Renaming_Declaration |
12811               N_Object_Renaming_Declaration            |
12812               N_Package_Renaming_Declaration           |
12813               N_Subprogram_Renaming_Declaration        =>
12814             return True;
12815
12816          when others                                   =>
12817             return False;
12818       end case;
12819    end Is_Renaming_Declaration;
12820
12821    ----------------------------
12822    -- Is_Reversible_Iterator --
12823    ----------------------------
12824
12825    function Is_Reversible_Iterator (Typ : Entity_Id) return Boolean is
12826       Ifaces_List : Elist_Id;
12827       Iface_Elmt  : Elmt_Id;
12828       Iface       : Entity_Id;
12829
12830    begin
12831       if Is_Class_Wide_Type (Typ)
12832         and then Chars (Root_Type (Typ)) = Name_Reversible_Iterator
12833         and then Is_Predefined_File_Name
12834                    (Unit_File_Name (Get_Source_Unit (Root_Type (Typ))))
12835       then
12836          return True;
12837
12838       elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then
12839          return False;
12840
12841       else
12842          Collect_Interfaces (Typ, Ifaces_List);
12843
12844          Iface_Elmt := First_Elmt (Ifaces_List);
12845          while Present (Iface_Elmt) loop
12846             Iface := Node (Iface_Elmt);
12847             if Chars (Iface) = Name_Reversible_Iterator
12848               and then
12849                 Is_Predefined_File_Name
12850                   (Unit_File_Name (Get_Source_Unit (Iface)))
12851             then
12852                return True;
12853             end if;
12854
12855             Next_Elmt (Iface_Elmt);
12856          end loop;
12857       end if;
12858
12859       return False;
12860    end Is_Reversible_Iterator;
12861
12862    ----------------------
12863    -- Is_Selector_Name --
12864    ----------------------
12865
12866    function Is_Selector_Name (N : Node_Id) return Boolean is
12867    begin
12868       if not Is_List_Member (N) then
12869          declare
12870             P : constant Node_Id   := Parent (N);
12871          begin
12872             return Nkind_In (P, N_Expanded_Name,
12873                                 N_Generic_Association,
12874                                 N_Parameter_Association,
12875                                 N_Selected_Component)
12876               and then Selector_Name (P) = N;
12877          end;
12878
12879       else
12880          declare
12881             L : constant List_Id := List_Containing (N);
12882             P : constant Node_Id := Parent (L);
12883          begin
12884             return (Nkind (P) = N_Discriminant_Association
12885                      and then Selector_Names (P) = L)
12886               or else
12887                    (Nkind (P) = N_Component_Association
12888                      and then Choices (P) = L);
12889          end;
12890       end if;
12891    end Is_Selector_Name;
12892
12893    ---------------------------------------------
12894    -- Is_Single_Precision_Floating_Point_Type --
12895    ---------------------------------------------
12896
12897    function Is_Single_Precision_Floating_Point_Type
12898      (E : Entity_Id) return Boolean is
12899    begin
12900       return Is_Floating_Point_Type (E)
12901         and then Machine_Radix_Value (E) = Uint_2
12902         and then Machine_Mantissa_Value (E) = Uint_24
12903         and then Machine_Emax_Value (E) = Uint_2 ** Uint_7
12904         and then Machine_Emin_Value (E) = Uint_3 - (Uint_2 ** Uint_7);
12905    end Is_Single_Precision_Floating_Point_Type;
12906
12907    -------------------------------------
12908    -- Is_SPARK_05_Initialization_Expr --
12909    -------------------------------------
12910
12911    function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is
12912       Is_Ok     : Boolean;
12913       Expr      : Node_Id;
12914       Comp_Assn : Node_Id;
12915       Orig_N    : constant Node_Id := Original_Node (N);
12916
12917    begin
12918       Is_Ok := True;
12919
12920       if not Comes_From_Source (Orig_N) then
12921          goto Done;
12922       end if;
12923
12924       pragma Assert (Nkind (Orig_N) in N_Subexpr);
12925
12926       case Nkind (Orig_N) is
12927          when N_Character_Literal |
12928               N_Integer_Literal   |
12929               N_Real_Literal      |
12930               N_String_Literal    =>
12931             null;
12932
12933          when N_Identifier    |
12934               N_Expanded_Name =>
12935             if Is_Entity_Name (Orig_N)
12936               and then Present (Entity (Orig_N))  --  needed in some cases
12937             then
12938                case Ekind (Entity (Orig_N)) is
12939                   when E_Constant            |
12940                        E_Enumeration_Literal |
12941                        E_Named_Integer       |
12942                        E_Named_Real          =>
12943                      null;
12944                   when others =>
12945                      if Is_Type (Entity (Orig_N)) then
12946                         null;
12947                      else
12948                         Is_Ok := False;
12949                      end if;
12950                end case;
12951             end if;
12952
12953          when N_Qualified_Expression |
12954               N_Type_Conversion      =>
12955             Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
12956
12957          when N_Unary_Op =>
12958             Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
12959
12960          when N_Binary_Op       |
12961               N_Short_Circuit   |
12962               N_Membership_Test =>
12963             Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
12964                        and then
12965                          Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
12966
12967          when N_Aggregate           |
12968               N_Extension_Aggregate =>
12969             if Nkind (Orig_N) = N_Extension_Aggregate then
12970                Is_Ok :=
12971                  Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
12972             end if;
12973
12974             Expr := First (Expressions (Orig_N));
12975             while Present (Expr) loop
12976                if not Is_SPARK_05_Initialization_Expr (Expr) then
12977                   Is_Ok := False;
12978                   goto Done;
12979                end if;
12980
12981                Next (Expr);
12982             end loop;
12983
12984             Comp_Assn := First (Component_Associations (Orig_N));
12985             while Present (Comp_Assn) loop
12986                Expr := Expression (Comp_Assn);
12987
12988                --  Note: test for Present here needed for box assocation
12989
12990                if Present (Expr)
12991                  and then not Is_SPARK_05_Initialization_Expr (Expr)
12992                then
12993                   Is_Ok := False;
12994                   goto Done;
12995                end if;
12996
12997                Next (Comp_Assn);
12998             end loop;
12999
13000          when N_Attribute_Reference =>
13001             if Nkind (Prefix (Orig_N)) in N_Subexpr then
13002                Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N));
13003             end if;
13004
13005             Expr := First (Expressions (Orig_N));
13006             while Present (Expr) loop
13007                if not Is_SPARK_05_Initialization_Expr (Expr) then
13008                   Is_Ok := False;
13009                   goto Done;
13010                end if;
13011
13012                Next (Expr);
13013             end loop;
13014
13015          --  Selected components might be expanded named not yet resolved, so
13016          --  default on the safe side. (Eg on sparklex.ads)
13017
13018          when N_Selected_Component =>
13019             null;
13020
13021          when others =>
13022             Is_Ok := False;
13023       end case;
13024
13025    <<Done>>
13026       return Is_Ok;
13027    end Is_SPARK_05_Initialization_Expr;
13028
13029    ----------------------------------
13030    -- Is_SPARK_05_Object_Reference --
13031    ----------------------------------
13032
13033    function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is
13034    begin
13035       if Is_Entity_Name (N) then
13036          return Present (Entity (N))
13037            and then
13038              (Ekind_In (Entity (N), E_Constant, E_Variable)
13039                or else Ekind (Entity (N)) in Formal_Kind);
13040
13041       else
13042          case Nkind (N) is
13043             when N_Selected_Component =>
13044                return Is_SPARK_05_Object_Reference (Prefix (N));
13045
13046             when others =>
13047                return False;
13048          end case;
13049       end if;
13050    end Is_SPARK_05_Object_Reference;
13051
13052    -----------------------------
13053    -- Is_Specific_Tagged_Type --
13054    -----------------------------
13055
13056    function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is
13057       Full_Typ : Entity_Id;
13058
13059    begin
13060       --  Handle private types
13061
13062       if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
13063          Full_Typ := Full_View (Typ);
13064       else
13065          Full_Typ := Typ;
13066       end if;
13067
13068       --  A specific tagged type is a non-class-wide tagged type
13069
13070       return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ);
13071    end Is_Specific_Tagged_Type;
13072
13073    ------------------
13074    -- Is_Statement --
13075    ------------------
13076
13077    function Is_Statement (N : Node_Id) return Boolean is
13078    begin
13079       return
13080         Nkind (N) in N_Statement_Other_Than_Procedure_Call
13081           or else Nkind (N) = N_Procedure_Call_Statement;
13082    end Is_Statement;
13083
13084    ---------------------------------------
13085    -- Is_Subprogram_Contract_Annotation --
13086    ---------------------------------------
13087
13088    function Is_Subprogram_Contract_Annotation
13089      (Item : Node_Id) return Boolean
13090    is
13091       Nam : Name_Id;
13092
13093    begin
13094       if Nkind (Item) = N_Aspect_Specification then
13095          Nam := Chars (Identifier (Item));
13096
13097       else pragma Assert (Nkind (Item) = N_Pragma);
13098          Nam := Pragma_Name (Item);
13099       end if;
13100
13101       return    Nam = Name_Contract_Cases
13102         or else Nam = Name_Depends
13103         or else Nam = Name_Extensions_Visible
13104         or else Nam = Name_Global
13105         or else Nam = Name_Post
13106         or else Nam = Name_Post_Class
13107         or else Nam = Name_Postcondition
13108         or else Nam = Name_Pre
13109         or else Nam = Name_Pre_Class
13110         or else Nam = Name_Precondition
13111         or else Nam = Name_Refined_Depends
13112         or else Nam = Name_Refined_Global
13113         or else Nam = Name_Refined_Post
13114         or else Nam = Name_Test_Case;
13115    end Is_Subprogram_Contract_Annotation;
13116
13117    --------------------------------------------------
13118    -- Is_Subprogram_Stub_Without_Prior_Declaration --
13119    --------------------------------------------------
13120
13121    function Is_Subprogram_Stub_Without_Prior_Declaration
13122      (N : Node_Id) return Boolean
13123    is
13124    begin
13125       --  A subprogram stub without prior declaration serves as declaration for
13126       --  the actual subprogram body. As such, it has an attached defining
13127       --  entity of E_[Generic_]Function or E_[Generic_]Procedure.
13128
13129       return Nkind (N) = N_Subprogram_Body_Stub
13130         and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body;
13131    end Is_Subprogram_Stub_Without_Prior_Declaration;
13132
13133    --------------------------
13134    -- Is_Suspension_Object --
13135    --------------------------
13136
13137    function Is_Suspension_Object (Id : Entity_Id) return Boolean is
13138    begin
13139       --  This approach does an exact name match rather than to rely on
13140       --  RTSfind. Routine Is_Effectively_Volatile is used by clients of the
13141       --  front end at point where all auxiliary tables are locked and any
13142       --  modifications to them are treated as violations. Do not tamper with
13143       --  the tables, instead examine the Chars fields of all the scopes of Id.
13144
13145       return
13146         Chars (Id) = Name_Suspension_Object
13147           and then Present (Scope (Id))
13148           and then Chars (Scope (Id)) = Name_Synchronous_Task_Control
13149           and then Present (Scope (Scope (Id)))
13150           and then Chars (Scope (Scope (Id))) = Name_Ada
13151           and then Present (Scope (Scope (Scope (Id))))
13152           and then Scope (Scope (Scope (Id))) = Standard_Standard;
13153    end Is_Suspension_Object;
13154
13155    ---------------------------------
13156    -- Is_Synchronized_Tagged_Type --
13157    ---------------------------------
13158
13159    function Is_Synchronized_Tagged_Type (E : Entity_Id) return Boolean is
13160       Kind : constant Entity_Kind := Ekind (Base_Type (E));
13161
13162    begin
13163       --  A task or protected type derived from an interface is a tagged type.
13164       --  Such a tagged type is called a synchronized tagged type, as are
13165       --  synchronized interfaces and private extensions whose declaration
13166       --  includes the reserved word synchronized.
13167
13168       return (Is_Tagged_Type (E)
13169                 and then (Kind = E_Task_Type
13170                             or else
13171                           Kind = E_Protected_Type))
13172             or else
13173              (Is_Interface (E)
13174                 and then Is_Synchronized_Interface (E))
13175             or else
13176              (Ekind (E) = E_Record_Type_With_Private
13177                 and then Nkind (Parent (E)) = N_Private_Extension_Declaration
13178                 and then (Synchronized_Present (Parent (E))
13179                            or else Is_Synchronized_Interface (Etype (E))));
13180    end Is_Synchronized_Tagged_Type;
13181
13182    -----------------
13183    -- Is_Transfer --
13184    -----------------
13185
13186    function Is_Transfer (N : Node_Id) return Boolean is
13187       Kind : constant Node_Kind := Nkind (N);
13188
13189    begin
13190       if Kind = N_Simple_Return_Statement
13191            or else
13192          Kind = N_Extended_Return_Statement
13193            or else
13194          Kind = N_Goto_Statement
13195            or else
13196          Kind = N_Raise_Statement
13197            or else
13198          Kind = N_Requeue_Statement
13199       then
13200          return True;
13201
13202       elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
13203         and then No (Condition (N))
13204       then
13205          return True;
13206
13207       elsif Kind = N_Procedure_Call_Statement
13208         and then Is_Entity_Name (Name (N))
13209         and then Present (Entity (Name (N)))
13210         and then No_Return (Entity (Name (N)))
13211       then
13212          return True;
13213
13214       elsif Nkind (Original_Node (N)) = N_Raise_Statement then
13215          return True;
13216
13217       else
13218          return False;
13219       end if;
13220    end Is_Transfer;
13221
13222    -------------
13223    -- Is_True --
13224    -------------
13225
13226    function Is_True (U : Uint) return Boolean is
13227    begin
13228       return (U /= 0);
13229    end Is_True;
13230
13231    --------------------------------------
13232    -- Is_Unchecked_Conversion_Instance --
13233    --------------------------------------
13234
13235    function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
13236       Gen_Par : Entity_Id;
13237
13238    begin
13239       --  Look for a function whose generic parent is the predefined intrinsic
13240       --  function Unchecked_Conversion.
13241
13242       if Ekind (Id) = E_Function then
13243          Gen_Par := Generic_Parent (Parent (Id));
13244
13245          return
13246            Present (Gen_Par)
13247              and then Chars (Gen_Par) = Name_Unchecked_Conversion
13248              and then Is_Intrinsic_Subprogram (Gen_Par)
13249              and then Is_Predefined_File_Name
13250                         (Unit_File_Name (Get_Source_Unit (Gen_Par)));
13251       end if;
13252
13253       return False;
13254    end Is_Unchecked_Conversion_Instance;
13255
13256    -------------------------------
13257    -- Is_Universal_Numeric_Type --
13258    -------------------------------
13259
13260    function Is_Universal_Numeric_Type (T : Entity_Id) return Boolean is
13261    begin
13262       return T = Universal_Integer or else T = Universal_Real;
13263    end Is_Universal_Numeric_Type;
13264
13265    ----------------------------
13266    -- Is_Variable_Size_Array --
13267    ----------------------------
13268
13269    function Is_Variable_Size_Array (E : Entity_Id) return Boolean is
13270       Idx : Node_Id;
13271
13272    begin
13273       pragma Assert (Is_Array_Type (E));
13274
13275       --  Check if some index is initialized with a non-constant value
13276
13277       Idx := First_Index (E);
13278       while Present (Idx) loop
13279          if Nkind (Idx) = N_Range then
13280             if not Is_Constant_Bound (Low_Bound (Idx))
13281               or else not Is_Constant_Bound (High_Bound (Idx))
13282             then
13283                return True;
13284             end if;
13285          end if;
13286
13287          Idx := Next_Index (Idx);
13288       end loop;
13289
13290       return False;
13291    end Is_Variable_Size_Array;
13292
13293    -----------------------------
13294    -- Is_Variable_Size_Record --
13295    -----------------------------
13296
13297    function Is_Variable_Size_Record (E : Entity_Id) return Boolean is
13298       Comp     : Entity_Id;
13299       Comp_Typ : Entity_Id;
13300
13301    begin
13302       pragma Assert (Is_Record_Type (E));
13303
13304       Comp := First_Entity (E);
13305       while Present (Comp) loop
13306          Comp_Typ := Etype (Comp);
13307
13308          --  Recursive call if the record type has discriminants
13309
13310          if Is_Record_Type (Comp_Typ)
13311            and then Has_Discriminants (Comp_Typ)
13312            and then Is_Variable_Size_Record (Comp_Typ)
13313          then
13314             return True;
13315
13316          elsif Is_Array_Type (Comp_Typ)
13317            and then Is_Variable_Size_Array (Comp_Typ)
13318          then
13319             return True;
13320          end if;
13321
13322          Next_Entity (Comp);
13323       end loop;
13324
13325       return False;
13326    end Is_Variable_Size_Record;
13327
13328    -----------------
13329    -- Is_Variable --
13330    -----------------
13331
13332    function Is_Variable
13333      (N                 : Node_Id;
13334       Use_Original_Node : Boolean := True) return Boolean
13335    is
13336       Orig_Node : Node_Id;
13337
13338       function In_Protected_Function (E : Entity_Id) return Boolean;
13339       --  Within a protected function, the private components of the enclosing
13340       --  protected type are constants. A function nested within a (protected)
13341       --  procedure is not itself protected. Within the body of a protected
13342       --  function the current instance of the protected type is a constant.
13343
13344       function Is_Variable_Prefix (P : Node_Id) return Boolean;
13345       --  Prefixes can involve implicit dereferences, in which case we must
13346       --  test for the case of a reference of a constant access type, which can
13347       --  can never be a variable.
13348
13349       ---------------------------
13350       -- In_Protected_Function --
13351       ---------------------------
13352
13353       function In_Protected_Function (E : Entity_Id) return Boolean is
13354          Prot : Entity_Id;
13355          S    : Entity_Id;
13356
13357       begin
13358          --  E is the current instance of a type
13359
13360          if Is_Type (E) then
13361             Prot := E;
13362
13363          --  E is an object
13364
13365          else
13366             Prot := Scope (E);
13367          end if;
13368
13369          if not Is_Protected_Type (Prot) then
13370             return False;
13371
13372          else
13373             S := Current_Scope;
13374             while Present (S) and then S /= Prot loop
13375                if Ekind (S) = E_Function and then Scope (S) = Prot then
13376                   return True;
13377                end if;
13378
13379                S := Scope (S);
13380             end loop;
13381
13382             return False;
13383          end if;
13384       end In_Protected_Function;
13385
13386       ------------------------
13387       -- Is_Variable_Prefix --
13388       ------------------------
13389
13390       function Is_Variable_Prefix (P : Node_Id) return Boolean is
13391       begin
13392          if Is_Access_Type (Etype (P)) then
13393             return not Is_Access_Constant (Root_Type (Etype (P)));
13394
13395          --  For the case of an indexed component whose prefix has a packed
13396          --  array type, the prefix has been rewritten into a type conversion.
13397          --  Determine variable-ness from the converted expression.
13398
13399          elsif Nkind (P) = N_Type_Conversion
13400            and then not Comes_From_Source (P)
13401            and then Is_Array_Type (Etype (P))
13402            and then Is_Packed (Etype (P))
13403          then
13404             return Is_Variable (Expression (P));
13405
13406          else
13407             return Is_Variable (P);
13408          end if;
13409       end Is_Variable_Prefix;
13410
13411    --  Start of processing for Is_Variable
13412
13413    begin
13414       --  Special check, allow x'Deref(expr) as a variable
13415
13416       if Nkind (N) = N_Attribute_Reference
13417         and then Attribute_Name (N) = Name_Deref
13418       then
13419          return True;
13420       end if;
13421
13422       --  Check if we perform the test on the original node since this may be a
13423       --  test of syntactic categories which must not be disturbed by whatever
13424       --  rewriting might have occurred. For example, an aggregate, which is
13425       --  certainly NOT a variable, could be turned into a variable by
13426       --  expansion.
13427
13428       if Use_Original_Node then
13429          Orig_Node := Original_Node (N);
13430       else
13431          Orig_Node := N;
13432       end if;
13433
13434       --  Definitely OK if Assignment_OK is set. Since this is something that
13435       --  only gets set for expanded nodes, the test is on N, not Orig_Node.
13436
13437       if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
13438          return True;
13439
13440       --  Normally we go to the original node, but there is one exception where
13441       --  we use the rewritten node, namely when it is an explicit dereference.
13442       --  The generated code may rewrite a prefix which is an access type with
13443       --  an explicit dereference. The dereference is a variable, even though
13444       --  the original node may not be (since it could be a constant of the
13445       --  access type).
13446
13447       --  In Ada 2005 we have a further case to consider: the prefix may be a
13448       --  function call given in prefix notation. The original node appears to
13449       --  be a selected component, but we need to examine the call.
13450
13451       elsif Nkind (N) = N_Explicit_Dereference
13452         and then Nkind (Orig_Node) /= N_Explicit_Dereference
13453         and then Present (Etype (Orig_Node))
13454         and then Is_Access_Type (Etype (Orig_Node))
13455       then
13456          --  Note that if the prefix is an explicit dereference that does not
13457          --  come from source, we must check for a rewritten function call in
13458          --  prefixed notation before other forms of rewriting, to prevent a
13459          --  compiler crash.
13460
13461          return
13462            (Nkind (Orig_Node) = N_Function_Call
13463              and then not Is_Access_Constant (Etype (Prefix (N))))
13464            or else
13465              Is_Variable_Prefix (Original_Node (Prefix (N)));
13466
13467       --  in Ada 2012, the dereference may have been added for a type with
13468       --  a declared implicit dereference aspect. Check that it is not an
13469       --  access to constant.
13470
13471       elsif Nkind (N) = N_Explicit_Dereference
13472         and then Present (Etype (Orig_Node))
13473         and then Ada_Version >= Ada_2012
13474         and then Has_Implicit_Dereference (Etype (Orig_Node))
13475       then
13476          return not Is_Access_Constant (Etype (Prefix (N)));
13477
13478       --  A function call is never a variable
13479
13480       elsif Nkind (N) = N_Function_Call then
13481          return False;
13482
13483       --  All remaining checks use the original node
13484
13485       elsif Is_Entity_Name (Orig_Node)
13486         and then Present (Entity (Orig_Node))
13487       then
13488          declare
13489             E : constant Entity_Id := Entity (Orig_Node);
13490             K : constant Entity_Kind := Ekind (E);
13491
13492          begin
13493             return    (K = E_Variable
13494                         and then Nkind (Parent (E)) /= N_Exception_Handler)
13495               or else (K = E_Component
13496                         and then not In_Protected_Function (E))
13497               or else K = E_Out_Parameter
13498               or else K = E_In_Out_Parameter
13499               or else K = E_Generic_In_Out_Parameter
13500
13501               --  Current instance of type. If this is a protected type, check
13502               --  we are not within the body of one of its protected functions.
13503
13504               or else (Is_Type (E)
13505                         and then In_Open_Scopes (E)
13506                         and then not In_Protected_Function (E))
13507
13508               or else (Is_Incomplete_Or_Private_Type (E)
13509                         and then In_Open_Scopes (Full_View (E)));
13510          end;
13511
13512       else
13513          case Nkind (Orig_Node) is
13514             when N_Indexed_Component | N_Slice =>
13515                return Is_Variable_Prefix (Prefix (Orig_Node));
13516
13517             when N_Selected_Component =>
13518                return (Is_Variable (Selector_Name (Orig_Node))
13519                         and then Is_Variable_Prefix (Prefix (Orig_Node)))
13520                  or else
13521                    (Nkind (N) = N_Expanded_Name
13522                      and then Scope (Entity (N)) = Entity (Prefix (N)));
13523
13524             --  For an explicit dereference, the type of the prefix cannot
13525             --  be an access to constant or an access to subprogram.
13526
13527             when N_Explicit_Dereference =>
13528                declare
13529                   Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
13530                begin
13531                   return Is_Access_Type (Typ)
13532                     and then not Is_Access_Constant (Root_Type (Typ))
13533                     and then Ekind (Typ) /= E_Access_Subprogram_Type;
13534                end;
13535
13536             --  The type conversion is the case where we do not deal with the
13537             --  context dependent special case of an actual parameter. Thus
13538             --  the type conversion is only considered a variable for the
13539             --  purposes of this routine if the target type is tagged. However,
13540             --  a type conversion is considered to be a variable if it does not
13541             --  come from source (this deals for example with the conversions
13542             --  of expressions to their actual subtypes).
13543
13544             when N_Type_Conversion =>
13545                return Is_Variable (Expression (Orig_Node))
13546                  and then
13547                    (not Comes_From_Source (Orig_Node)
13548                      or else
13549                        (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
13550                          and then
13551                         Is_Tagged_Type (Etype (Expression (Orig_Node)))));
13552
13553             --  GNAT allows an unchecked type conversion as a variable. This
13554             --  only affects the generation of internal expanded code, since
13555             --  calls to instantiations of Unchecked_Conversion are never
13556             --  considered variables (since they are function calls).
13557
13558             when N_Unchecked_Type_Conversion =>
13559                return Is_Variable (Expression (Orig_Node));
13560
13561             when others =>
13562                return False;
13563          end case;
13564       end if;
13565    end Is_Variable;
13566
13567    ---------------------------
13568    -- Is_Visibly_Controlled --
13569    ---------------------------
13570
13571    function Is_Visibly_Controlled (T : Entity_Id) return Boolean is
13572       Root : constant Entity_Id := Root_Type (T);
13573    begin
13574       return Chars (Scope (Root)) = Name_Finalization
13575         and then Chars (Scope (Scope (Root))) = Name_Ada
13576         and then Scope (Scope (Scope (Root))) = Standard_Standard;
13577    end Is_Visibly_Controlled;
13578
13579    --------------------------
13580    -- Is_Volatile_Function --
13581    --------------------------
13582
13583    function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is
13584    begin
13585       --  The caller must ensure that Func_Id denotes a function
13586
13587       pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function));
13588
13589       --  A protected function is automatically volatile
13590
13591       if Is_Primitive (Func_Id)
13592         and then Present (First_Formal (Func_Id))
13593         and then Is_Protected_Type (Etype (First_Formal (Func_Id)))
13594       then
13595          return True;
13596
13597       --  An instance of Ada.Unchecked_Conversion is a volatile function if
13598       --  either the source or the target are effectively volatile.
13599
13600       elsif Is_Unchecked_Conversion_Instance (Func_Id)
13601         and then Has_Effectively_Volatile_Profile (Func_Id)
13602       then
13603          return True;
13604
13605       --  Otherwise the function is treated as volatile if it is subject to
13606       --  enabled pragma Volatile_Function.
13607
13608       else
13609          return
13610            Is_Enabled_Pragma (Get_Pragma (Func_Id, Pragma_Volatile_Function));
13611       end if;
13612    end Is_Volatile_Function;
13613
13614    ------------------------
13615    -- Is_Volatile_Object --
13616    ------------------------
13617
13618    function Is_Volatile_Object (N : Node_Id) return Boolean is
13619
13620       function Is_Volatile_Prefix (N : Node_Id) return Boolean;
13621       --  If prefix is an implicit dereference, examine designated type
13622
13623       function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
13624       --  Determines if given object has volatile components
13625
13626       ------------------------
13627       -- Is_Volatile_Prefix --
13628       ------------------------
13629
13630       function Is_Volatile_Prefix (N : Node_Id) return Boolean is
13631          Typ  : constant Entity_Id := Etype (N);
13632
13633       begin
13634          if Is_Access_Type (Typ) then
13635             declare
13636                Dtyp : constant Entity_Id := Designated_Type (Typ);
13637
13638             begin
13639                return Is_Volatile (Dtyp)
13640                  or else Has_Volatile_Components (Dtyp);
13641             end;
13642
13643          else
13644             return Object_Has_Volatile_Components (N);
13645          end if;
13646       end Is_Volatile_Prefix;
13647
13648       ------------------------------------
13649       -- Object_Has_Volatile_Components --
13650       ------------------------------------
13651
13652       function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
13653          Typ : constant Entity_Id := Etype (N);
13654
13655       begin
13656          if Is_Volatile (Typ)
13657            or else Has_Volatile_Components (Typ)
13658          then
13659             return True;
13660
13661          elsif Is_Entity_Name (N)
13662            and then (Has_Volatile_Components (Entity (N))
13663                       or else Is_Volatile (Entity (N)))
13664          then
13665             return True;
13666
13667          elsif Nkind (N) = N_Indexed_Component
13668            or else Nkind (N) = N_Selected_Component
13669          then
13670             return Is_Volatile_Prefix (Prefix (N));
13671
13672          else
13673             return False;
13674          end if;
13675       end Object_Has_Volatile_Components;
13676
13677    --  Start of processing for Is_Volatile_Object
13678
13679    begin
13680       if Nkind (N) = N_Defining_Identifier then
13681          return Is_Volatile (N) or else Is_Volatile (Etype (N));
13682
13683       elsif Nkind (N) = N_Expanded_Name then
13684          return Is_Volatile_Object (Entity (N));
13685
13686       elsif Is_Volatile (Etype (N))
13687         or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
13688       then
13689          return True;
13690
13691       elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component)
13692         and then Is_Volatile_Prefix (Prefix (N))
13693       then
13694          return True;
13695
13696       elsif Nkind (N) = N_Selected_Component
13697         and then Is_Volatile (Entity (Selector_Name (N)))
13698       then
13699          return True;
13700
13701       else
13702          return False;
13703       end if;
13704    end Is_Volatile_Object;
13705
13706    ---------------------------
13707    -- Itype_Has_Declaration --
13708    ---------------------------
13709
13710    function Itype_Has_Declaration (Id : Entity_Id) return Boolean is
13711    begin
13712       pragma Assert (Is_Itype (Id));
13713       return Present (Parent (Id))
13714         and then Nkind_In (Parent (Id), N_Full_Type_Declaration,
13715                                         N_Subtype_Declaration)
13716         and then Defining_Entity (Parent (Id)) = Id;
13717    end Itype_Has_Declaration;
13718
13719    -------------------------
13720    -- Kill_Current_Values --
13721    -------------------------
13722
13723    procedure Kill_Current_Values
13724      (Ent                  : Entity_Id;
13725       Last_Assignment_Only : Boolean := False)
13726    is
13727    begin
13728       if Is_Assignable (Ent) then
13729          Set_Last_Assignment (Ent, Empty);
13730       end if;
13731
13732       if Is_Object (Ent) then
13733          if not Last_Assignment_Only then
13734             Kill_Checks (Ent);
13735             Set_Current_Value (Ent, Empty);
13736
13737             --  Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
13738             --  for a constant. Once the constant is elaborated, its value is
13739             --  not changed, therefore the associated flags that describe the
13740             --  value should not be modified either.
13741
13742             if Ekind (Ent) = E_Constant then
13743                null;
13744
13745             --  Non-constant entities
13746
13747             else
13748                if not Can_Never_Be_Null (Ent) then
13749                   Set_Is_Known_Non_Null (Ent, False);
13750                end if;
13751
13752                Set_Is_Known_Null (Ent, False);
13753
13754                --  Reset the Is_Known_Valid flag unless the type is always
13755                --  valid. This does not apply to a loop parameter because its
13756                --  bounds are defined by the loop header and therefore always
13757                --  valid.
13758
13759                if not Is_Known_Valid (Etype (Ent))
13760                  and then Ekind (Ent) /= E_Loop_Parameter
13761                then
13762                   Set_Is_Known_Valid (Ent, False);
13763                end if;
13764             end if;
13765          end if;
13766       end if;
13767    end Kill_Current_Values;
13768
13769    procedure Kill_Current_Values (Last_Assignment_Only : Boolean := False) is
13770       S : Entity_Id;
13771
13772       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
13773       --  Clear current value for entity E and all entities chained to E
13774
13775       ------------------------------------------
13776       -- Kill_Current_Values_For_Entity_Chain --
13777       ------------------------------------------
13778
13779       procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
13780          Ent : Entity_Id;
13781       begin
13782          Ent := E;
13783          while Present (Ent) loop
13784             Kill_Current_Values (Ent, Last_Assignment_Only);
13785             Next_Entity (Ent);
13786          end loop;
13787       end Kill_Current_Values_For_Entity_Chain;
13788
13789    --  Start of processing for Kill_Current_Values
13790
13791    begin
13792       --  Kill all saved checks, a special case of killing saved values
13793
13794       if not Last_Assignment_Only then
13795          Kill_All_Checks;
13796       end if;
13797
13798       --  Loop through relevant scopes, which includes the current scope and
13799       --  any parent scopes if the current scope is a block or a package.
13800
13801       S := Current_Scope;
13802       Scope_Loop : loop
13803
13804          --  Clear current values of all entities in current scope
13805
13806          Kill_Current_Values_For_Entity_Chain (First_Entity (S));
13807
13808          --  If scope is a package, also clear current values of all private
13809          --  entities in the scope.
13810
13811          if Is_Package_Or_Generic_Package (S)
13812            or else Is_Concurrent_Type (S)
13813          then
13814             Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
13815          end if;
13816
13817          --  If this is a not a subprogram, deal with parents
13818
13819          if not Is_Subprogram (S) then
13820             S := Scope (S);
13821             exit Scope_Loop when S = Standard_Standard;
13822          else
13823             exit Scope_Loop;
13824          end if;
13825       end loop Scope_Loop;
13826    end Kill_Current_Values;
13827
13828    --------------------------
13829    -- Kill_Size_Check_Code --
13830    --------------------------
13831
13832    procedure Kill_Size_Check_Code (E : Entity_Id) is
13833    begin
13834       if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
13835         and then Present (Size_Check_Code (E))
13836       then
13837          Remove (Size_Check_Code (E));
13838          Set_Size_Check_Code (E, Empty);
13839       end if;
13840    end Kill_Size_Check_Code;
13841
13842    --------------------------
13843    -- Known_To_Be_Assigned --
13844    --------------------------
13845
13846    function Known_To_Be_Assigned (N : Node_Id) return Boolean is
13847       P : constant Node_Id := Parent (N);
13848
13849    begin
13850       case Nkind (P) is
13851
13852          --  Test left side of assignment
13853
13854          when N_Assignment_Statement =>
13855             return N = Name (P);
13856
13857             --  Function call arguments are never lvalues
13858
13859          when N_Function_Call =>
13860             return False;
13861
13862          --  Positional parameter for procedure or accept call
13863
13864          when N_Procedure_Call_Statement |
13865               N_Accept_Statement
13866           =>
13867             declare
13868                Proc : Entity_Id;
13869                Form : Entity_Id;
13870                Act  : Node_Id;
13871
13872             begin
13873                Proc := Get_Subprogram_Entity (P);
13874
13875                if No (Proc) then
13876                   return False;
13877                end if;
13878
13879                --  If we are not a list member, something is strange, so
13880                --  be conservative and return False.
13881
13882                if not Is_List_Member (N) then
13883                   return False;
13884                end if;
13885
13886                --  We are going to find the right formal by stepping forward
13887                --  through the formals, as we step backwards in the actuals.
13888
13889                Form := First_Formal (Proc);
13890                Act  := N;
13891                loop
13892                   --  If no formal, something is weird, so be conservative
13893                   --  and return False.
13894
13895                   if No (Form) then
13896                      return False;
13897                   end if;
13898
13899                   Prev (Act);
13900                   exit when No (Act);
13901                   Next_Formal (Form);
13902                end loop;
13903
13904                return Ekind (Form) /= E_In_Parameter;
13905             end;
13906
13907          --  Named parameter for procedure or accept call
13908
13909          when N_Parameter_Association =>
13910             declare
13911                Proc : Entity_Id;
13912                Form : Entity_Id;
13913
13914             begin
13915                Proc := Get_Subprogram_Entity (Parent (P));
13916
13917                if No (Proc) then
13918                   return False;
13919                end if;
13920
13921                --  Loop through formals to find the one that matches
13922
13923                Form := First_Formal (Proc);
13924                loop
13925                   --  If no matching formal, that's peculiar, some kind of
13926                   --  previous error, so return False to be conservative.
13927                   --  Actually this also happens in legal code in the case
13928                   --  where P is a parameter association for an Extra_Formal???
13929
13930                   if No (Form) then
13931                      return False;
13932                   end if;
13933
13934                   --  Else test for match
13935
13936                   if Chars (Form) = Chars (Selector_Name (P)) then
13937                      return Ekind (Form) /= E_In_Parameter;
13938                   end if;
13939
13940                   Next_Formal (Form);
13941                end loop;
13942             end;
13943
13944          --  Test for appearing in a conversion that itself appears
13945          --  in an lvalue context, since this should be an lvalue.
13946
13947          when N_Type_Conversion =>
13948             return Known_To_Be_Assigned (P);
13949
13950          --  All other references are definitely not known to be modifications
13951
13952          when others =>
13953             return False;
13954
13955       end case;
13956    end Known_To_Be_Assigned;
13957
13958    ---------------------------
13959    -- Last_Source_Statement --
13960    ---------------------------
13961
13962    function Last_Source_Statement (HSS : Node_Id) return Node_Id is
13963       N : Node_Id;
13964
13965    begin
13966       N := Last (Statements (HSS));
13967       while Present (N) loop
13968          exit when Comes_From_Source (N);
13969          Prev (N);
13970       end loop;
13971
13972       return N;
13973    end Last_Source_Statement;
13974
13975    ----------------------------------
13976    -- Matching_Static_Array_Bounds --
13977    ----------------------------------
13978
13979    function Matching_Static_Array_Bounds
13980      (L_Typ : Node_Id;
13981       R_Typ : Node_Id) return Boolean
13982    is
13983       L_Ndims : constant Nat := Number_Dimensions (L_Typ);
13984       R_Ndims : constant Nat := Number_Dimensions (R_Typ);
13985
13986       L_Index : Node_Id;
13987       R_Index : Node_Id;
13988       L_Low   : Node_Id;
13989       L_High  : Node_Id;
13990       L_Len   : Uint;
13991       R_Low   : Node_Id;
13992       R_High  : Node_Id;
13993       R_Len   : Uint;
13994
13995    begin
13996       if L_Ndims /= R_Ndims then
13997          return False;
13998       end if;
13999
14000       --  Unconstrained types do not have static bounds
14001
14002       if not Is_Constrained (L_Typ) or else not Is_Constrained (R_Typ) then
14003          return False;
14004       end if;
14005
14006       --  First treat specially the first dimension, as the lower bound and
14007       --  length of string literals are not stored like those of arrays.
14008
14009       if Ekind (L_Typ) = E_String_Literal_Subtype then
14010          L_Low := String_Literal_Low_Bound (L_Typ);
14011          L_Len := String_Literal_Length (L_Typ);
14012       else
14013          L_Index := First_Index (L_Typ);
14014          Get_Index_Bounds (L_Index, L_Low, L_High);
14015
14016          if Is_OK_Static_Expression (L_Low)
14017               and then
14018             Is_OK_Static_Expression (L_High)
14019          then
14020             if Expr_Value (L_High) < Expr_Value (L_Low) then
14021                L_Len := Uint_0;
14022             else
14023                L_Len := (Expr_Value (L_High) - Expr_Value (L_Low)) + 1;
14024             end if;
14025          else
14026             return False;
14027          end if;
14028       end if;
14029
14030       if Ekind (R_Typ) = E_String_Literal_Subtype then
14031          R_Low := String_Literal_Low_Bound (R_Typ);
14032          R_Len := String_Literal_Length (R_Typ);
14033       else
14034          R_Index := First_Index (R_Typ);
14035          Get_Index_Bounds (R_Index, R_Low, R_High);
14036
14037          if Is_OK_Static_Expression (R_Low)
14038               and then
14039             Is_OK_Static_Expression (R_High)
14040          then
14041             if Expr_Value (R_High) < Expr_Value (R_Low) then
14042                R_Len := Uint_0;
14043             else
14044                R_Len := (Expr_Value (R_High) - Expr_Value (R_Low)) + 1;
14045             end if;
14046          else
14047             return False;
14048          end if;
14049       end if;
14050
14051       if (Is_OK_Static_Expression (L_Low)
14052             and then
14053           Is_OK_Static_Expression (R_Low))
14054         and then Expr_Value (L_Low) = Expr_Value (R_Low)
14055         and then L_Len = R_Len
14056       then
14057          null;
14058       else
14059          return False;
14060       end if;
14061
14062       --  Then treat all other dimensions
14063
14064       for Indx in 2 .. L_Ndims loop
14065          Next (L_Index);
14066          Next (R_Index);
14067
14068          Get_Index_Bounds (L_Index, L_Low, L_High);
14069          Get_Index_Bounds (R_Index, R_Low, R_High);
14070
14071          if (Is_OK_Static_Expression (L_Low)  and then
14072              Is_OK_Static_Expression (L_High) and then
14073              Is_OK_Static_Expression (R_Low)  and then
14074              Is_OK_Static_Expression (R_High))
14075            and then (Expr_Value (L_Low)  = Expr_Value (R_Low)
14076                        and then
14077                      Expr_Value (L_High) = Expr_Value (R_High))
14078          then
14079             null;
14080          else
14081             return False;
14082          end if;
14083       end loop;
14084
14085       --  If we fall through the loop, all indexes matched
14086
14087       return True;
14088    end Matching_Static_Array_Bounds;
14089
14090    -------------------
14091    -- May_Be_Lvalue --
14092    -------------------
14093
14094    function May_Be_Lvalue (N : Node_Id) return Boolean is
14095       P : constant Node_Id := Parent (N);
14096
14097    begin
14098       case Nkind (P) is
14099
14100          --  Test left side of assignment
14101
14102          when N_Assignment_Statement =>
14103             return N = Name (P);
14104
14105          --  Test prefix of component or attribute. Note that the prefix of an
14106          --  explicit or implicit dereference cannot be an l-value.
14107
14108          when N_Attribute_Reference =>
14109             return N = Prefix (P)
14110               and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
14111
14112          --  For an expanded name, the name is an lvalue if the expanded name
14113          --  is an lvalue, but the prefix is never an lvalue, since it is just
14114          --  the scope where the name is found.
14115
14116          when N_Expanded_Name =>
14117             if N = Prefix (P) then
14118                return May_Be_Lvalue (P);
14119             else
14120                return False;
14121             end if;
14122
14123          --  For a selected component A.B, A is certainly an lvalue if A.B is.
14124          --  B is a little interesting, if we have A.B := 3, there is some
14125          --  discussion as to whether B is an lvalue or not, we choose to say
14126          --  it is. Note however that A is not an lvalue if it is of an access
14127          --  type since this is an implicit dereference.
14128
14129          when N_Selected_Component =>
14130             if N = Prefix (P)
14131               and then Present (Etype (N))
14132               and then Is_Access_Type (Etype (N))
14133             then
14134                return False;
14135             else
14136                return May_Be_Lvalue (P);
14137             end if;
14138
14139          --  For an indexed component or slice, the index or slice bounds is
14140          --  never an lvalue. The prefix is an lvalue if the indexed component
14141          --  or slice is an lvalue, except if it is an access type, where we
14142          --  have an implicit dereference.
14143
14144          when N_Indexed_Component | N_Slice =>
14145             if N /= Prefix (P)
14146               or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
14147             then
14148                return False;
14149             else
14150                return May_Be_Lvalue (P);
14151             end if;
14152
14153          --  Prefix of a reference is an lvalue if the reference is an lvalue
14154
14155          when N_Reference =>
14156             return May_Be_Lvalue (P);
14157
14158          --  Prefix of explicit dereference is never an lvalue
14159
14160          when N_Explicit_Dereference =>
14161             return False;
14162
14163          --  Positional parameter for subprogram, entry, or accept call.
14164          --  In older versions of Ada function call arguments are never
14165          --  lvalues. In Ada 2012 functions can have in-out parameters.
14166
14167          when N_Subprogram_Call      |
14168               N_Entry_Call_Statement |
14169               N_Accept_Statement
14170          =>
14171             if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
14172                return False;
14173             end if;
14174
14175             --  The following mechanism is clumsy and fragile. A single flag
14176             --  set in Resolve_Actuals would be preferable ???
14177
14178             declare
14179                Proc : Entity_Id;
14180                Form : Entity_Id;
14181                Act  : Node_Id;
14182
14183             begin
14184                Proc := Get_Subprogram_Entity (P);
14185
14186                if No (Proc) then
14187                   return True;
14188                end if;
14189
14190                --  If we are not a list member, something is strange, so be
14191                --  conservative and return True.
14192
14193                if not Is_List_Member (N) then
14194                   return True;
14195                end if;
14196
14197                --  We are going to find the right formal by stepping forward
14198                --  through the formals, as we step backwards in the actuals.
14199
14200                Form := First_Formal (Proc);
14201                Act  := N;
14202                loop
14203                   --  If no formal, something is weird, so be conservative and
14204                   --  return True.
14205
14206                   if No (Form) then
14207                      return True;
14208                   end if;
14209
14210                   Prev (Act);
14211                   exit when No (Act);
14212                   Next_Formal (Form);
14213                end loop;
14214
14215                return Ekind (Form) /= E_In_Parameter;
14216             end;
14217
14218          --  Named parameter for procedure or accept call
14219
14220          when N_Parameter_Association =>
14221             declare
14222                Proc : Entity_Id;
14223                Form : Entity_Id;
14224
14225             begin
14226                Proc := Get_Subprogram_Entity (Parent (P));
14227
14228                if No (Proc) then
14229                   return True;
14230                end if;
14231
14232                --  Loop through formals to find the one that matches
14233
14234                Form := First_Formal (Proc);
14235                loop
14236                   --  If no matching formal, that's peculiar, some kind of
14237                   --  previous error, so return True to be conservative.
14238                   --  Actually happens with legal code for an unresolved call
14239                   --  where we may get the wrong homonym???
14240
14241                   if No (Form) then
14242                      return True;
14243                   end if;
14244
14245                   --  Else test for match
14246
14247                   if Chars (Form) = Chars (Selector_Name (P)) then
14248                      return Ekind (Form) /= E_In_Parameter;
14249                   end if;
14250
14251                   Next_Formal (Form);
14252                end loop;
14253             end;
14254
14255          --  Test for appearing in a conversion that itself appears in an
14256          --  lvalue context, since this should be an lvalue.
14257
14258          when N_Type_Conversion =>
14259             return May_Be_Lvalue (P);
14260
14261          --  Test for appearance in object renaming declaration
14262
14263          when N_Object_Renaming_Declaration =>
14264             return True;
14265
14266          --  All other references are definitely not lvalues
14267
14268          when others =>
14269             return False;
14270
14271       end case;
14272    end May_Be_Lvalue;
14273
14274    -----------------------
14275    -- Mark_Coextensions --
14276    -----------------------
14277
14278    procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is
14279       Is_Dynamic : Boolean;
14280       --  Indicates whether the context causes nested coextensions to be
14281       --  dynamic or static
14282
14283       function Mark_Allocator (N : Node_Id) return Traverse_Result;
14284       --  Recognize an allocator node and label it as a dynamic coextension
14285
14286       --------------------
14287       -- Mark_Allocator --
14288       --------------------
14289
14290       function Mark_Allocator (N : Node_Id) return Traverse_Result is
14291       begin
14292          if Nkind (N) = N_Allocator then
14293             if Is_Dynamic then
14294                Set_Is_Dynamic_Coextension (N);
14295
14296             --  If the allocator expression is potentially dynamic, it may
14297             --  be expanded out of order and require dynamic allocation
14298             --  anyway, so we treat the coextension itself as dynamic.
14299             --  Potential optimization ???
14300
14301             elsif Nkind (Expression (N)) = N_Qualified_Expression
14302               and then Nkind (Expression (Expression (N))) = N_Op_Concat
14303             then
14304                Set_Is_Dynamic_Coextension (N);
14305             else
14306                Set_Is_Static_Coextension (N);
14307             end if;
14308          end if;
14309
14310          return OK;
14311       end Mark_Allocator;
14312
14313       procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator);
14314
14315    --  Start of processing for Mark_Coextensions
14316
14317    begin
14318       --  An allocator that appears on the right-hand side of an assignment is
14319       --  treated as a potentially dynamic coextension when the right-hand side
14320       --  is an allocator or a qualified expression.
14321
14322       --    Obj := new ...'(new Coextension ...);
14323
14324       if Nkind (Context_Nod) = N_Assignment_Statement then
14325          Is_Dynamic :=
14326            Nkind_In (Expression (Context_Nod), N_Allocator,
14327                                                N_Qualified_Expression);
14328
14329       --  An allocator that appears within the expression of a simple return
14330       --  statement is treated as a potentially dynamic coextension when the
14331       --  expression is either aggregate, allocator, or qualified expression.
14332
14333       --    return (new Coextension ...);
14334       --    return new ...'(new Coextension ...);
14335
14336       elsif Nkind (Context_Nod) = N_Simple_Return_Statement then
14337          Is_Dynamic :=
14338            Nkind_In (Expression (Context_Nod), N_Aggregate,
14339                                                N_Allocator,
14340                                                N_Qualified_Expression);
14341
14342       --  An alloctor that appears within the initialization expression of an
14343       --  object declaration is considered a potentially dynamic coextension
14344       --  when the initialization expression is an allocator or a qualified
14345       --  expression.
14346
14347       --    Obj : ... := new ...'(new Coextension ...);
14348
14349       --  A similar case arises when the object declaration is part of an
14350       --  extended return statement.
14351
14352       --    return Obj : ... := new ...'(new Coextension ...);
14353       --    return Obj : ... := (new Coextension ...);
14354
14355       elsif Nkind (Context_Nod) = N_Object_Declaration then
14356          Is_Dynamic :=
14357            Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression)
14358              or else
14359                Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement;
14360
14361       --  This routine should not be called with constructs that cannot contain
14362       --  coextensions.
14363
14364       else
14365          raise Program_Error;
14366       end if;
14367
14368       Mark_Allocators (Root_Nod);
14369    end Mark_Coextensions;
14370
14371    ----------------------
14372    -- Needs_One_Actual --
14373    ----------------------
14374
14375    function Needs_One_Actual (E : Entity_Id) return Boolean is
14376       Formal : Entity_Id;
14377
14378    begin
14379       --  Ada 2005 or later, and formals present
14380
14381       if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
14382          Formal := Next_Formal (First_Formal (E));
14383          while Present (Formal) loop
14384             if No (Default_Value (Formal)) then
14385                return False;
14386             end if;
14387
14388             Next_Formal (Formal);
14389          end loop;
14390
14391          return True;
14392
14393       --  Ada 83/95 or no formals
14394
14395       else
14396          return False;
14397       end if;
14398    end Needs_One_Actual;
14399
14400    ------------------------
14401    -- New_Copy_List_Tree --
14402    ------------------------
14403
14404    function New_Copy_List_Tree (List : List_Id) return List_Id is
14405       NL : List_Id;
14406       E  : Node_Id;
14407
14408    begin
14409       if List = No_List then
14410          return No_List;
14411
14412       else
14413          NL := New_List;
14414          E := First (List);
14415
14416          while Present (E) loop
14417             Append (New_Copy_Tree (E), NL);
14418             E := Next (E);
14419          end loop;
14420
14421          return NL;
14422       end if;
14423    end New_Copy_List_Tree;
14424
14425    --------------------------------------------------
14426    -- New_Copy_Tree Auxiliary Data and Subprograms --
14427    --------------------------------------------------
14428
14429    use Atree.Unchecked_Access;
14430    use Atree_Private_Part;
14431
14432    --  Our approach here requires a two pass traversal of the tree. The
14433    --  first pass visits all nodes that eventually will be copied looking
14434    --  for defining Itypes. If any defining Itypes are found, then they are
14435    --  copied, and an entry is added to the replacement map. In the second
14436    --  phase, the tree is copied, using the replacement map to replace any
14437    --  Itype references within the copied tree.
14438
14439    --  The following hash tables are used if the Map supplied has more
14440    --  than hash threshold entries to speed up access to the map. If
14441    --  there are fewer entries, then the map is searched sequentially
14442    --  (because setting up a hash table for only a few entries takes
14443    --  more time than it saves.
14444
14445    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
14446    --  Hash function used for hash operations
14447
14448    -------------------
14449    -- New_Copy_Hash --
14450    -------------------
14451
14452    function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
14453    begin
14454       return Nat (E) mod (NCT_Header_Num'Last + 1);
14455    end New_Copy_Hash;
14456
14457    ---------------
14458    -- NCT_Assoc --
14459    ---------------
14460
14461    --  The hash table NCT_Assoc associates old entities in the table
14462    --  with their corresponding new entities (i.e. the pairs of entries
14463    --  presented in the original Map argument are Key-Element pairs).
14464
14465    package NCT_Assoc is new Simple_HTable (
14466      Header_Num => NCT_Header_Num,
14467      Element    => Entity_Id,
14468      No_Element => Empty,
14469      Key        => Entity_Id,
14470      Hash       => New_Copy_Hash,
14471      Equal      => Types."=");
14472
14473    ---------------------
14474    -- NCT_Itype_Assoc --
14475    ---------------------
14476
14477    --  The hash table NCT_Itype_Assoc contains entries only for those
14478    --  old nodes which have a non-empty Associated_Node_For_Itype set.
14479    --  The key is the associated node, and the element is the new node
14480    --  itself (NOT the associated node for the new node).
14481
14482    package NCT_Itype_Assoc is new Simple_HTable (
14483      Header_Num => NCT_Header_Num,
14484      Element    => Entity_Id,
14485      No_Element => Empty,
14486      Key        => Entity_Id,
14487      Hash       => New_Copy_Hash,
14488      Equal      => Types."=");
14489
14490    -------------------
14491    -- New_Copy_Tree --
14492    -------------------
14493
14494    function New_Copy_Tree
14495      (Source    : Node_Id;
14496       Map       : Elist_Id := No_Elist;
14497       New_Sloc  : Source_Ptr := No_Location;
14498       New_Scope : Entity_Id := Empty) return Node_Id
14499    is
14500       Actual_Map : Elist_Id := Map;
14501       --  This is the actual map for the copy. It is initialized with the
14502       --  given elements, and then enlarged as required for Itypes that are
14503       --  copied during the first phase of the copy operation. The visit
14504       --  procedures add elements to this map as Itypes are encountered.
14505       --  The reason we cannot use Map directly, is that it may well be
14506       --  (and normally is) initialized to No_Elist, and if we have mapped
14507       --  entities, we have to reset it to point to a real Elist.
14508
14509       function Assoc (N : Node_Or_Entity_Id) return Node_Id;
14510       --  Called during second phase to map entities into their corresponding
14511       --  copies using Actual_Map. If the argument is not an entity, or is not
14512       --  in Actual_Map, then it is returned unchanged.
14513
14514       procedure Build_NCT_Hash_Tables;
14515       --  Builds hash tables (number of elements >= threshold value)
14516
14517       function Copy_Elist_With_Replacement
14518         (Old_Elist : Elist_Id) return Elist_Id;
14519       --  Called during second phase to copy element list doing replacements
14520
14521       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
14522       --  Called during the second phase to process a copied Itype. The actual
14523       --  copy happened during the first phase (so that we could make the entry
14524       --  in the mapping), but we still have to deal with the descendents of
14525       --  the copied Itype and copy them where necessary.
14526
14527       function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
14528       --  Called during second phase to copy list doing replacements
14529
14530       function Copy_Node_With_Replacement (Old_Node : Node_Id) return Node_Id;
14531       --  Called during second phase to copy node doing replacements
14532
14533       procedure Visit_Elist (E : Elist_Id);
14534       --  Called during first phase to visit all elements of an Elist
14535
14536       procedure Visit_Field (F : Union_Id; N : Node_Id);
14537       --  Visit a single field, recursing to call Visit_Node or Visit_List
14538       --  if the field is a syntactic descendent of the current node (i.e.
14539       --  its parent is Node N).
14540
14541       procedure Visit_Itype (Old_Itype : Entity_Id);
14542       --  Called during first phase to visit subsidiary fields of a defining
14543       --  Itype, and also create a copy and make an entry in the replacement
14544       --  map for the new copy.
14545
14546       procedure Visit_List (L : List_Id);
14547       --  Called during first phase to visit all elements of a List
14548
14549       procedure Visit_Node (N : Node_Or_Entity_Id);
14550       --  Called during first phase to visit a node and all its subtrees
14551
14552       -----------
14553       -- Assoc --
14554       -----------
14555
14556       function Assoc (N : Node_Or_Entity_Id) return Node_Id is
14557          E   : Elmt_Id;
14558          Ent : Entity_Id;
14559
14560       begin
14561          if not Has_Extension (N) or else No (Actual_Map) then
14562             return N;
14563
14564          elsif NCT_Hash_Tables_Used then
14565             Ent := NCT_Assoc.Get (Entity_Id (N));
14566
14567             if Present (Ent) then
14568                return Ent;
14569             else
14570                return N;
14571             end if;
14572
14573          --  No hash table used, do serial search
14574
14575          else
14576             E := First_Elmt (Actual_Map);
14577             while Present (E) loop
14578                if Node (E) = N then
14579                   return Node (Next_Elmt (E));
14580                else
14581                   E := Next_Elmt (Next_Elmt (E));
14582                end if;
14583             end loop;
14584          end if;
14585
14586          return N;
14587       end Assoc;
14588
14589       ---------------------------
14590       -- Build_NCT_Hash_Tables --
14591       ---------------------------
14592
14593       procedure Build_NCT_Hash_Tables is
14594          Elmt : Elmt_Id;
14595          Ent  : Entity_Id;
14596       begin
14597          if NCT_Hash_Table_Setup then
14598             NCT_Assoc.Reset;
14599             NCT_Itype_Assoc.Reset;
14600          end if;
14601
14602          Elmt := First_Elmt (Actual_Map);
14603          while Present (Elmt) loop
14604             Ent := Node (Elmt);
14605
14606             --  Get new entity, and associate old and new
14607
14608             Next_Elmt (Elmt);
14609             NCT_Assoc.Set (Ent, Node (Elmt));
14610
14611             if Is_Type (Ent) then
14612                declare
14613                   Anode : constant Entity_Id :=
14614                             Associated_Node_For_Itype (Ent);
14615
14616                begin
14617                   if Present (Anode) then
14618
14619                      --  Enter a link between the associated node of the
14620                      --  old Itype and the new Itype, for updating later
14621                      --  when node is copied.
14622
14623                      NCT_Itype_Assoc.Set (Anode, Node (Elmt));
14624                   end if;
14625                end;
14626             end if;
14627
14628             Next_Elmt (Elmt);
14629          end loop;
14630
14631          NCT_Hash_Tables_Used := True;
14632          NCT_Hash_Table_Setup := True;
14633       end Build_NCT_Hash_Tables;
14634
14635       ---------------------------------
14636       -- Copy_Elist_With_Replacement --
14637       ---------------------------------
14638
14639       function Copy_Elist_With_Replacement
14640         (Old_Elist : Elist_Id) return Elist_Id
14641       is
14642          M         : Elmt_Id;
14643          New_Elist : Elist_Id;
14644
14645       begin
14646          if No (Old_Elist) then
14647             return No_Elist;
14648
14649          else
14650             New_Elist := New_Elmt_List;
14651
14652             M := First_Elmt (Old_Elist);
14653             while Present (M) loop
14654                Append_Elmt (Copy_Node_With_Replacement (Node (M)), New_Elist);
14655                Next_Elmt (M);
14656             end loop;
14657          end if;
14658
14659          return New_Elist;
14660       end Copy_Elist_With_Replacement;
14661
14662       ---------------------------------
14663       -- Copy_Itype_With_Replacement --
14664       ---------------------------------
14665
14666       --  This routine exactly parallels its phase one analog Visit_Itype,
14667
14668       procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
14669       begin
14670          --  Translate Next_Entity, Scope and Etype fields, in case they
14671          --  reference entities that have been mapped into copies.
14672
14673          Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
14674          Set_Etype       (New_Itype, Assoc (Etype       (New_Itype)));
14675
14676          if Present (New_Scope) then
14677             Set_Scope    (New_Itype, New_Scope);
14678          else
14679             Set_Scope    (New_Itype, Assoc (Scope       (New_Itype)));
14680          end if;
14681
14682          --  Copy referenced fields
14683
14684          if Is_Discrete_Type (New_Itype) then
14685             Set_Scalar_Range (New_Itype,
14686               Copy_Node_With_Replacement (Scalar_Range (New_Itype)));
14687
14688          elsif Has_Discriminants (Base_Type (New_Itype)) then
14689             Set_Discriminant_Constraint (New_Itype,
14690               Copy_Elist_With_Replacement
14691                 (Discriminant_Constraint (New_Itype)));
14692
14693          elsif Is_Array_Type (New_Itype) then
14694             if Present (First_Index (New_Itype)) then
14695                Set_First_Index (New_Itype,
14696                  First (Copy_List_With_Replacement
14697                          (List_Containing (First_Index (New_Itype)))));
14698             end if;
14699
14700             if Is_Packed (New_Itype) then
14701                Set_Packed_Array_Impl_Type (New_Itype,
14702                  Copy_Node_With_Replacement
14703                    (Packed_Array_Impl_Type (New_Itype)));
14704             end if;
14705          end if;
14706       end Copy_Itype_With_Replacement;
14707
14708       --------------------------------
14709       -- Copy_List_With_Replacement --
14710       --------------------------------
14711
14712       function Copy_List_With_Replacement
14713         (Old_List : List_Id) return List_Id
14714       is
14715          New_List : List_Id;
14716          E        : Node_Id;
14717
14718       begin
14719          if Old_List = No_List then
14720             return No_List;
14721
14722          else
14723             New_List := Empty_List;
14724
14725             E := First (Old_List);
14726             while Present (E) loop
14727                Append (Copy_Node_With_Replacement (E), New_List);
14728                Next (E);
14729             end loop;
14730
14731             return New_List;
14732          end if;
14733       end Copy_List_With_Replacement;
14734
14735       --------------------------------
14736       -- Copy_Node_With_Replacement --
14737       --------------------------------
14738
14739       function Copy_Node_With_Replacement
14740         (Old_Node : Node_Id) return Node_Id
14741       is
14742          New_Node : Node_Id;
14743
14744          procedure Adjust_Named_Associations
14745            (Old_Node : Node_Id;
14746             New_Node : Node_Id);
14747          --  If a call node has named associations, these are chained through
14748          --  the First_Named_Actual, Next_Named_Actual links. These must be
14749          --  propagated separately to the new parameter list, because these
14750          --  are not syntactic fields.
14751
14752          function Copy_Field_With_Replacement
14753            (Field : Union_Id) return Union_Id;
14754          --  Given Field, which is a field of Old_Node, return a copy of it
14755          --  if it is a syntactic field (i.e. its parent is Node), setting
14756          --  the parent of the copy to poit to New_Node. Otherwise returns
14757          --  the field (possibly mapped if it is an entity).
14758
14759          -------------------------------
14760          -- Adjust_Named_Associations --
14761          -------------------------------
14762
14763          procedure Adjust_Named_Associations
14764            (Old_Node : Node_Id;
14765             New_Node : Node_Id)
14766          is
14767             Old_E : Node_Id;
14768             New_E : Node_Id;
14769
14770             Old_Next : Node_Id;
14771             New_Next : Node_Id;
14772
14773          begin
14774             Old_E := First (Parameter_Associations (Old_Node));
14775             New_E := First (Parameter_Associations (New_Node));
14776             while Present (Old_E) loop
14777                if Nkind (Old_E) = N_Parameter_Association
14778                  and then Present (Next_Named_Actual (Old_E))
14779                then
14780                   if First_Named_Actual (Old_Node)
14781                     = Explicit_Actual_Parameter (Old_E)
14782                   then
14783                      Set_First_Named_Actual
14784                        (New_Node, Explicit_Actual_Parameter (New_E));
14785                   end if;
14786
14787                   --  Now scan parameter list from the beginning,to locate
14788                   --  next named actual, which can be out of order.
14789
14790                   Old_Next := First (Parameter_Associations (Old_Node));
14791                   New_Next := First (Parameter_Associations (New_Node));
14792
14793                   while Nkind (Old_Next) /= N_Parameter_Association
14794                     or else Explicit_Actual_Parameter (Old_Next) /=
14795                                               Next_Named_Actual (Old_E)
14796                   loop
14797                      Next (Old_Next);
14798                      Next (New_Next);
14799                   end loop;
14800
14801                   Set_Next_Named_Actual
14802                     (New_E, Explicit_Actual_Parameter (New_Next));
14803                end if;
14804
14805                Next (Old_E);
14806                Next (New_E);
14807             end loop;
14808          end Adjust_Named_Associations;
14809
14810          ---------------------------------
14811          -- Copy_Field_With_Replacement --
14812          ---------------------------------
14813
14814          function Copy_Field_With_Replacement
14815            (Field : Union_Id) return Union_Id
14816          is
14817          begin
14818             if Field = Union_Id (Empty) then
14819                return Field;
14820
14821             elsif Field in Node_Range then
14822                declare
14823                   Old_N : constant Node_Id := Node_Id (Field);
14824                   New_N : Node_Id;
14825
14826                begin
14827                   --  If syntactic field, as indicated by the parent pointer
14828                   --  being set, then copy the referenced node recursively.
14829
14830                   if Parent (Old_N) = Old_Node then
14831                      New_N := Copy_Node_With_Replacement (Old_N);
14832
14833                      if New_N /= Old_N then
14834                         Set_Parent (New_N, New_Node);
14835                      end if;
14836
14837                   --  For semantic fields, update possible entity reference
14838                   --  from the replacement map.
14839
14840                   else
14841                      New_N := Assoc (Old_N);
14842                   end if;
14843
14844                   return Union_Id (New_N);
14845                end;
14846
14847             elsif Field in List_Range then
14848                declare
14849                   Old_L : constant List_Id := List_Id (Field);
14850                   New_L : List_Id;
14851
14852                begin
14853                   --  If syntactic field, as indicated by the parent pointer,
14854                   --  then recursively copy the entire referenced list.
14855
14856                   if Parent (Old_L) = Old_Node then
14857                      New_L := Copy_List_With_Replacement (Old_L);
14858                      Set_Parent (New_L, New_Node);
14859
14860                   --  For semantic list, just returned unchanged
14861
14862                   else
14863                      New_L := Old_L;
14864                   end if;
14865
14866                   return Union_Id (New_L);
14867                end;
14868
14869             --  Anything other than a list or a node is returned unchanged
14870
14871             else
14872                return Field;
14873             end if;
14874          end Copy_Field_With_Replacement;
14875
14876       --  Start of processing for Copy_Node_With_Replacement
14877
14878       begin
14879          if Old_Node <= Empty_Or_Error then
14880             return Old_Node;
14881
14882          elsif Has_Extension (Old_Node) then
14883             return Assoc (Old_Node);
14884
14885          else
14886             New_Node := New_Copy (Old_Node);
14887
14888             --  If the node we are copying is the associated node of a
14889             --  previously copied Itype, then adjust the associated node
14890             --  of the copy of that Itype accordingly.
14891
14892             if Present (Actual_Map) then
14893                declare
14894                   E   : Elmt_Id;
14895                   Ent : Entity_Id;
14896
14897                begin
14898                   --  Case of hash table used
14899
14900                   if NCT_Hash_Tables_Used then
14901                      Ent := NCT_Itype_Assoc.Get (Old_Node);
14902
14903                      if Present (Ent) then
14904                         Set_Associated_Node_For_Itype (Ent, New_Node);
14905                      end if;
14906
14907                   --  Case of no hash table used
14908
14909                   else
14910                      E := First_Elmt (Actual_Map);
14911                      while Present (E) loop
14912                         if Is_Itype (Node (E))
14913                           and then
14914                             Old_Node = Associated_Node_For_Itype (Node (E))
14915                         then
14916                            Set_Associated_Node_For_Itype
14917                              (Node (Next_Elmt (E)), New_Node);
14918                         end if;
14919
14920                         E := Next_Elmt (Next_Elmt (E));
14921                      end loop;
14922                   end if;
14923                end;
14924             end if;
14925
14926             --  Recursively copy descendents
14927
14928             Set_Field1
14929               (New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
14930             Set_Field2
14931               (New_Node, Copy_Field_With_Replacement (Field2 (New_Node)));
14932             Set_Field3
14933               (New_Node, Copy_Field_With_Replacement (Field3 (New_Node)));
14934             Set_Field4
14935               (New_Node, Copy_Field_With_Replacement (Field4 (New_Node)));
14936             Set_Field5
14937               (New_Node, Copy_Field_With_Replacement (Field5 (New_Node)));
14938
14939             --  Adjust Sloc of new node if necessary
14940
14941             if New_Sloc /= No_Location then
14942                Set_Sloc (New_Node, New_Sloc);
14943
14944                --  If we adjust the Sloc, then we are essentially making
14945                --  a completely new node, so the Comes_From_Source flag
14946                --  should be reset to the proper default value.
14947
14948                Nodes.Table (New_Node).Comes_From_Source :=
14949                  Default_Node.Comes_From_Source;
14950             end if;
14951
14952             --  If the node is call and has named associations,
14953             --  set the corresponding links in the copy.
14954
14955             if (Nkind (Old_Node) = N_Function_Call
14956                  or else Nkind (Old_Node) = N_Entry_Call_Statement
14957                  or else
14958                    Nkind (Old_Node) = N_Procedure_Call_Statement)
14959               and then Present (First_Named_Actual (Old_Node))
14960             then
14961                Adjust_Named_Associations (Old_Node, New_Node);
14962             end if;
14963
14964             --  Reset First_Real_Statement for Handled_Sequence_Of_Statements.
14965             --  The replacement mechanism applies to entities, and is not used
14966             --  here. Eventually we may need a more general graph-copying
14967             --  routine. For now, do a sequential search to find desired node.
14968
14969             if Nkind (Old_Node) = N_Handled_Sequence_Of_Statements
14970               and then Present (First_Real_Statement (Old_Node))
14971             then
14972                declare
14973                   Old_F  : constant Node_Id := First_Real_Statement (Old_Node);
14974                   N1, N2 : Node_Id;
14975
14976                begin
14977                   N1 := First (Statements (Old_Node));
14978                   N2 := First (Statements (New_Node));
14979
14980                   while N1 /= Old_F loop
14981                      Next (N1);
14982                      Next (N2);
14983                   end loop;
14984
14985                   Set_First_Real_Statement (New_Node, N2);
14986                end;
14987             end if;
14988          end if;
14989
14990          --  All done, return copied node
14991
14992          return New_Node;
14993       end Copy_Node_With_Replacement;
14994
14995       -----------------
14996       -- Visit_Elist --
14997       -----------------
14998
14999       procedure Visit_Elist (E : Elist_Id) is
15000          Elmt : Elmt_Id;
15001       begin
15002          if Present (E) then
15003             Elmt := First_Elmt (E);
15004
15005             while Elmt /= No_Elmt loop
15006                Visit_Node (Node (Elmt));
15007                Next_Elmt (Elmt);
15008             end loop;
15009          end if;
15010       end Visit_Elist;
15011
15012       -----------------
15013       -- Visit_Field --
15014       -----------------
15015
15016       procedure Visit_Field (F : Union_Id; N : Node_Id) is
15017       begin
15018          if F = Union_Id (Empty) then
15019             return;
15020
15021          elsif F in Node_Range then
15022
15023             --  Copy node if it is syntactic, i.e. its parent pointer is
15024             --  set to point to the field that referenced it (certain
15025             --  Itypes will also meet this criterion, which is fine, since
15026             --  these are clearly Itypes that do need to be copied, since
15027             --  we are copying their parent.)
15028
15029             if Parent (Node_Id (F)) = N then
15030                Visit_Node (Node_Id (F));
15031                return;
15032
15033             --  Another case, if we are pointing to an Itype, then we want
15034             --  to copy it if its associated node is somewhere in the tree
15035             --  being copied.
15036
15037             --  Note: the exclusion of self-referential copies is just an
15038             --  optimization, since the search of the already copied list
15039             --  would catch it, but it is a common case (Etype pointing
15040             --  to itself for an Itype that is a base type).
15041
15042             elsif Has_Extension (Node_Id (F))
15043               and then Is_Itype (Entity_Id (F))
15044               and then Node_Id (F) /= N
15045             then
15046                declare
15047                   P : Node_Id;
15048
15049                begin
15050                   P := Associated_Node_For_Itype (Node_Id (F));
15051                   while Present (P) loop
15052                      if P = Source then
15053                         Visit_Node (Node_Id (F));
15054                         return;
15055                      else
15056                         P := Parent (P);
15057                      end if;
15058                   end loop;
15059
15060                   --  An Itype whose parent is not being copied definitely
15061                   --  should NOT be copied, since it does not belong in any
15062                   --  sense to the copied subtree.
15063
15064                   return;
15065                end;
15066             end if;
15067
15068          elsif F in List_Range and then Parent (List_Id (F)) = N then
15069             Visit_List (List_Id (F));
15070             return;
15071          end if;
15072       end Visit_Field;
15073
15074       -----------------
15075       -- Visit_Itype --
15076       -----------------
15077
15078       procedure Visit_Itype (Old_Itype : Entity_Id) is
15079          New_Itype : Entity_Id;
15080          E         : Elmt_Id;
15081          Ent       : Entity_Id;
15082
15083       begin
15084          --  Itypes that describe the designated type of access to subprograms
15085          --  have the structure of subprogram declarations, with signatures,
15086          --  etc. Either we duplicate the signatures completely, or choose to
15087          --  share such itypes, which is fine because their elaboration will
15088          --  have no side effects.
15089
15090          if Ekind (Old_Itype) = E_Subprogram_Type then
15091             return;
15092          end if;
15093
15094          New_Itype := New_Copy (Old_Itype);
15095
15096          --  The new Itype has all the attributes of the old one, and
15097          --  we just copy the contents of the entity. However, the back-end
15098          --  needs different names for debugging purposes, so we create a
15099          --  new internal name for it in all cases.
15100
15101          Set_Chars (New_Itype, New_Internal_Name ('T'));
15102
15103          --  If our associated node is an entity that has already been copied,
15104          --  then set the associated node of the copy to point to the right
15105          --  copy. If we have copied an Itype that is itself the associated
15106          --  node of some previously copied Itype, then we set the right
15107          --  pointer in the other direction.
15108
15109          if Present (Actual_Map) then
15110
15111             --  Case of hash tables used
15112
15113             if NCT_Hash_Tables_Used then
15114
15115                Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
15116
15117                if Present (Ent) then
15118                   Set_Associated_Node_For_Itype (New_Itype, Ent);
15119                end if;
15120
15121                Ent := NCT_Itype_Assoc.Get (Old_Itype);
15122                if Present (Ent) then
15123                   Set_Associated_Node_For_Itype (Ent, New_Itype);
15124
15125                --  If the hash table has no association for this Itype and
15126                --  its associated node, enter one now.
15127
15128                else
15129                   NCT_Itype_Assoc.Set
15130                     (Associated_Node_For_Itype (Old_Itype), New_Itype);
15131                end if;
15132
15133             --  Case of hash tables not used
15134
15135             else
15136                E := First_Elmt (Actual_Map);
15137                while Present (E) loop
15138                   if Associated_Node_For_Itype (Old_Itype) = Node (E) then
15139                      Set_Associated_Node_For_Itype
15140                        (New_Itype, Node (Next_Elmt (E)));
15141                   end if;
15142
15143                   if Is_Type (Node (E))
15144                     and then Old_Itype = Associated_Node_For_Itype (Node (E))
15145                   then
15146                      Set_Associated_Node_For_Itype
15147                        (Node (Next_Elmt (E)), New_Itype);
15148                   end if;
15149
15150                   E := Next_Elmt (Next_Elmt (E));
15151                end loop;
15152             end if;
15153          end if;
15154
15155          if Present (Freeze_Node (New_Itype)) then
15156             Set_Is_Frozen (New_Itype, False);
15157             Set_Freeze_Node (New_Itype, Empty);
15158          end if;
15159
15160          --  Add new association to map
15161
15162          if No (Actual_Map) then
15163             Actual_Map := New_Elmt_List;
15164          end if;
15165
15166          Append_Elmt (Old_Itype, Actual_Map);
15167          Append_Elmt (New_Itype, Actual_Map);
15168
15169          if NCT_Hash_Tables_Used then
15170             NCT_Assoc.Set (Old_Itype, New_Itype);
15171
15172          else
15173             NCT_Table_Entries := NCT_Table_Entries + 1;
15174
15175             if NCT_Table_Entries > NCT_Hash_Threshold then
15176                Build_NCT_Hash_Tables;
15177             end if;
15178          end if;
15179
15180          --  If a record subtype is simply copied, the entity list will be
15181          --  shared. Thus cloned_Subtype must be set to indicate the sharing.
15182
15183          if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
15184             Set_Cloned_Subtype (New_Itype, Old_Itype);
15185          end if;
15186
15187          --  Visit descendents that eventually get copied
15188
15189          Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
15190
15191          if Is_Discrete_Type (Old_Itype) then
15192             Visit_Field (Union_Id (Scalar_Range (Old_Itype)), Old_Itype);
15193
15194          elsif Has_Discriminants (Base_Type (Old_Itype)) then
15195             --  ??? This should involve call to Visit_Field
15196             Visit_Elist (Discriminant_Constraint (Old_Itype));
15197
15198          elsif Is_Array_Type (Old_Itype) then
15199             if Present (First_Index (Old_Itype)) then
15200                Visit_Field (Union_Id (List_Containing
15201                                 (First_Index (Old_Itype))),
15202                             Old_Itype);
15203             end if;
15204
15205             if Is_Packed (Old_Itype) then
15206                Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)),
15207                             Old_Itype);
15208             end if;
15209          end if;
15210       end Visit_Itype;
15211
15212       ----------------
15213       -- Visit_List --
15214       ----------------
15215
15216       procedure Visit_List (L : List_Id) is
15217          N : Node_Id;
15218       begin
15219          if L /= No_List then
15220             N := First (L);
15221
15222             while Present (N) loop
15223                Visit_Node (N);
15224                Next (N);
15225             end loop;
15226          end if;
15227       end Visit_List;
15228
15229       ----------------
15230       -- Visit_Node --
15231       ----------------
15232
15233       procedure Visit_Node (N : Node_Or_Entity_Id) is
15234
15235       --  Start of processing for Visit_Node
15236
15237       begin
15238          --  Handle case of an Itype, which must be copied
15239
15240          if Has_Extension (N) and then Is_Itype (N) then
15241
15242             --  Nothing to do if already in the list. This can happen with an
15243             --  Itype entity that appears more than once in the tree.
15244             --  Note that we do not want to visit descendents in this case.
15245
15246             --  Test for already in list when hash table is used
15247
15248             if NCT_Hash_Tables_Used then
15249                if Present (NCT_Assoc.Get (Entity_Id (N))) then
15250                   return;
15251                end if;
15252
15253             --  Test for already in list when hash table not used
15254
15255             else
15256                declare
15257                   E : Elmt_Id;
15258                begin
15259                   if Present (Actual_Map) then
15260                      E := First_Elmt (Actual_Map);
15261                      while Present (E) loop
15262                         if Node (E) = N then
15263                            return;
15264                         else
15265                            E := Next_Elmt (Next_Elmt (E));
15266                         end if;
15267                      end loop;
15268                   end if;
15269                end;
15270             end if;
15271
15272             Visit_Itype (N);
15273          end if;
15274
15275          --  Visit descendents
15276
15277          Visit_Field (Field1 (N), N);
15278          Visit_Field (Field2 (N), N);
15279          Visit_Field (Field3 (N), N);
15280          Visit_Field (Field4 (N), N);
15281          Visit_Field (Field5 (N), N);
15282       end Visit_Node;
15283
15284    --  Start of processing for New_Copy_Tree
15285
15286    begin
15287       Actual_Map := Map;
15288
15289       --  See if we should use hash table
15290
15291       if No (Actual_Map) then
15292          NCT_Hash_Tables_Used := False;
15293
15294       else
15295          declare
15296             Elmt : Elmt_Id;
15297
15298          begin
15299             NCT_Table_Entries := 0;
15300
15301             Elmt := First_Elmt (Actual_Map);
15302             while Present (Elmt) loop
15303                NCT_Table_Entries := NCT_Table_Entries + 1;
15304                Next_Elmt (Elmt);
15305                Next_Elmt (Elmt);
15306             end loop;
15307
15308             if NCT_Table_Entries > NCT_Hash_Threshold then
15309                Build_NCT_Hash_Tables;
15310             else
15311                NCT_Hash_Tables_Used := False;
15312             end if;
15313          end;
15314       end if;
15315
15316       --  Hash table set up if required, now start phase one by visiting
15317       --  top node (we will recursively visit the descendents).
15318
15319       Visit_Node (Source);
15320
15321       --  Now the second phase of the copy can start. First we process
15322       --  all the mapped entities, copying their descendents.
15323
15324       if Present (Actual_Map) then
15325          declare
15326             Elmt      : Elmt_Id;
15327             New_Itype : Entity_Id;
15328          begin
15329             Elmt := First_Elmt (Actual_Map);
15330             while Present (Elmt) loop
15331                Next_Elmt (Elmt);
15332                New_Itype := Node (Elmt);
15333                Copy_Itype_With_Replacement (New_Itype);
15334                Next_Elmt (Elmt);
15335             end loop;
15336          end;
15337       end if;
15338
15339       --  Now we can copy the actual tree
15340
15341       return Copy_Node_With_Replacement (Source);
15342    end New_Copy_Tree;
15343
15344    -------------------------
15345    -- New_External_Entity --
15346    -------------------------
15347
15348    function New_External_Entity
15349      (Kind         : Entity_Kind;
15350       Scope_Id     : Entity_Id;
15351       Sloc_Value   : Source_Ptr;
15352       Related_Id   : Entity_Id;
15353       Suffix       : Character;
15354       Suffix_Index : Nat := 0;
15355       Prefix       : Character := ' ') return Entity_Id
15356    is
15357       N : constant Entity_Id :=
15358             Make_Defining_Identifier (Sloc_Value,
15359               New_External_Name
15360                 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
15361
15362    begin
15363       Set_Ekind          (N, Kind);
15364       Set_Is_Internal    (N, True);
15365       Append_Entity      (N, Scope_Id);
15366       Set_Public_Status  (N);
15367
15368       if Kind in Type_Kind then
15369          Init_Size_Align (N);
15370       end if;
15371
15372       return N;
15373    end New_External_Entity;
15374
15375    -------------------------
15376    -- New_Internal_Entity --
15377    -------------------------
15378
15379    function New_Internal_Entity
15380      (Kind       : Entity_Kind;
15381       Scope_Id   : Entity_Id;
15382       Sloc_Value : Source_Ptr;
15383       Id_Char    : Character) return Entity_Id
15384    is
15385       N : constant Entity_Id := Make_Temporary (Sloc_Value, Id_Char);
15386
15387    begin
15388       Set_Ekind          (N, Kind);
15389       Set_Is_Internal    (N, True);
15390       Append_Entity      (N, Scope_Id);
15391
15392       if Kind in Type_Kind then
15393          Init_Size_Align (N);
15394       end if;
15395
15396       return N;
15397    end New_Internal_Entity;
15398
15399    -----------------
15400    -- Next_Actual --
15401    -----------------
15402
15403    function Next_Actual (Actual_Id : Node_Id) return Node_Id is
15404       N  : Node_Id;
15405
15406    begin
15407       --  If we are pointing at a positional parameter, it is a member of a
15408       --  node list (the list of parameters), and the next parameter is the
15409       --  next node on the list, unless we hit a parameter association, then
15410       --  we shift to using the chain whose head is the First_Named_Actual in
15411       --  the parent, and then is threaded using the Next_Named_Actual of the
15412       --  Parameter_Association. All this fiddling is because the original node
15413       --  list is in the textual call order, and what we need is the
15414       --  declaration order.
15415
15416       if Is_List_Member (Actual_Id) then
15417          N := Next (Actual_Id);
15418
15419          if Nkind (N) = N_Parameter_Association then
15420             return First_Named_Actual (Parent (Actual_Id));
15421          else
15422             return N;
15423          end if;
15424
15425       else
15426          return Next_Named_Actual (Parent (Actual_Id));
15427       end if;
15428    end Next_Actual;
15429
15430    procedure Next_Actual (Actual_Id : in out Node_Id) is
15431    begin
15432       Actual_Id := Next_Actual (Actual_Id);
15433    end Next_Actual;
15434
15435    -----------------------
15436    -- Normalize_Actuals --
15437    -----------------------
15438
15439    --  Chain actuals according to formals of subprogram. If there are no named
15440    --  associations, the chain is simply the list of Parameter Associations,
15441    --  since the order is the same as the declaration order. If there are named
15442    --  associations, then the First_Named_Actual field in the N_Function_Call
15443    --  or N_Procedure_Call_Statement node points to the Parameter_Association
15444    --  node for the parameter that comes first in declaration order. The
15445    --  remaining named parameters are then chained in declaration order using
15446    --  Next_Named_Actual.
15447
15448    --  This routine also verifies that the number of actuals is compatible with
15449    --  the number and default values of formals, but performs no type checking
15450    --  (type checking is done by the caller).
15451
15452    --  If the matching succeeds, Success is set to True and the caller proceeds
15453    --  with type-checking. If the match is unsuccessful, then Success is set to
15454    --  False, and the caller attempts a different interpretation, if there is
15455    --  one.
15456
15457    --  If the flag Report is on, the call is not overloaded, and a failure to
15458    --  match can be reported here, rather than in the caller.
15459
15460    procedure Normalize_Actuals
15461      (N       : Node_Id;
15462       S       : Entity_Id;
15463       Report  : Boolean;
15464       Success : out Boolean)
15465    is
15466       Actuals     : constant List_Id := Parameter_Associations (N);
15467       Actual      : Node_Id := Empty;
15468       Formal      : Entity_Id;
15469       Last        : Node_Id := Empty;
15470       First_Named : Node_Id := Empty;
15471       Found       : Boolean;
15472
15473       Formals_To_Match : Integer := 0;
15474       Actuals_To_Match : Integer := 0;
15475
15476       procedure Chain (A : Node_Id);
15477       --  Add named actual at the proper place in the list, using the
15478       --  Next_Named_Actual link.
15479
15480       function Reporting return Boolean;
15481       --  Determines if an error is to be reported. To report an error, we
15482       --  need Report to be True, and also we do not report errors caused
15483       --  by calls to init procs that occur within other init procs. Such
15484       --  errors must always be cascaded errors, since if all the types are
15485       --  declared correctly, the compiler will certainly build decent calls.
15486
15487       -----------
15488       -- Chain --
15489       -----------
15490
15491       procedure Chain (A : Node_Id) is
15492       begin
15493          if No (Last) then
15494
15495             --  Call node points to first actual in list
15496
15497             Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
15498
15499          else
15500             Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
15501          end if;
15502
15503          Last := A;
15504          Set_Next_Named_Actual (Last, Empty);
15505       end Chain;
15506
15507       ---------------
15508       -- Reporting --
15509       ---------------
15510
15511       function Reporting return Boolean is
15512       begin
15513          if not Report then
15514             return False;
15515
15516          elsif not Within_Init_Proc then
15517             return True;
15518
15519          elsif Is_Init_Proc (Entity (Name (N))) then
15520             return False;
15521
15522          else
15523             return True;
15524          end if;
15525       end Reporting;
15526
15527    --  Start of processing for Normalize_Actuals
15528
15529    begin
15530       if Is_Access_Type (S) then
15531
15532          --  The name in the call is a function call that returns an access
15533          --  to subprogram. The designated type has the list of formals.
15534
15535          Formal := First_Formal (Designated_Type (S));
15536       else
15537          Formal := First_Formal (S);
15538       end if;
15539
15540       while Present (Formal) loop
15541          Formals_To_Match := Formals_To_Match + 1;
15542          Next_Formal (Formal);
15543       end loop;
15544
15545       --  Find if there is a named association, and verify that no positional
15546       --  associations appear after named ones.
15547
15548       if Present (Actuals) then
15549          Actual := First (Actuals);
15550       end if;
15551
15552       while Present (Actual)
15553         and then Nkind (Actual) /= N_Parameter_Association
15554       loop
15555          Actuals_To_Match := Actuals_To_Match + 1;
15556          Next (Actual);
15557       end loop;
15558
15559       if No (Actual) and Actuals_To_Match = Formals_To_Match then
15560
15561          --  Most common case: positional notation, no defaults
15562
15563          Success := True;
15564          return;
15565
15566       elsif Actuals_To_Match > Formals_To_Match then
15567
15568          --  Too many actuals: will not work
15569
15570          if Reporting then
15571             if Is_Entity_Name (Name (N)) then
15572                Error_Msg_N ("too many arguments in call to&", Name (N));
15573             else
15574                Error_Msg_N ("too many arguments in call", N);
15575             end if;
15576          end if;
15577
15578          Success := False;
15579          return;
15580       end if;
15581
15582       First_Named := Actual;
15583
15584       while Present (Actual) loop
15585          if Nkind (Actual) /= N_Parameter_Association then
15586             Error_Msg_N
15587               ("positional parameters not allowed after named ones", Actual);
15588             Success := False;
15589             return;
15590
15591          else
15592             Actuals_To_Match := Actuals_To_Match + 1;
15593          end if;
15594
15595          Next (Actual);
15596       end loop;
15597
15598       if Present (Actuals) then
15599          Actual := First (Actuals);
15600       end if;
15601
15602       Formal := First_Formal (S);
15603       while Present (Formal) loop
15604
15605          --  Match the formals in order. If the corresponding actual is
15606          --  positional, nothing to do. Else scan the list of named actuals
15607          --  to find the one with the right name.
15608
15609          if Present (Actual)
15610            and then Nkind (Actual) /= N_Parameter_Association
15611          then
15612             Next (Actual);
15613             Actuals_To_Match := Actuals_To_Match - 1;
15614             Formals_To_Match := Formals_To_Match - 1;
15615
15616          else
15617             --  For named parameters, search the list of actuals to find
15618             --  one that matches the next formal name.
15619
15620             Actual := First_Named;
15621             Found  := False;
15622             while Present (Actual) loop
15623                if Chars (Selector_Name (Actual)) = Chars (Formal) then
15624                   Found := True;
15625                   Chain (Actual);
15626                   Actuals_To_Match := Actuals_To_Match - 1;
15627                   Formals_To_Match := Formals_To_Match - 1;
15628                   exit;
15629                end if;
15630
15631                Next (Actual);
15632             end loop;
15633
15634             if not Found then
15635                if Ekind (Formal) /= E_In_Parameter
15636                  or else No (Default_Value (Formal))
15637                then
15638                   if Reporting then
15639                      if (Comes_From_Source (S)
15640                           or else Sloc (S) = Standard_Location)
15641                        and then Is_Overloadable (S)
15642                      then
15643                         if No (Actuals)
15644                           and then
15645                             Nkind_In (Parent (N), N_Procedure_Call_Statement,
15646                                                   N_Function_Call,
15647                                                   N_Parameter_Association)
15648                           and then Ekind (S) /= E_Function
15649                         then
15650                            Set_Etype (N, Etype (S));
15651
15652                         else
15653                            Error_Msg_Name_1 := Chars (S);
15654                            Error_Msg_Sloc := Sloc (S);
15655                            Error_Msg_NE
15656                              ("missing argument for parameter & "
15657                               & "in call to % declared #", N, Formal);
15658                         end if;
15659
15660                      elsif Is_Overloadable (S) then
15661                         Error_Msg_Name_1 := Chars (S);
15662
15663                         --  Point to type derivation that generated the
15664                         --  operation.
15665
15666                         Error_Msg_Sloc := Sloc (Parent (S));
15667
15668                         Error_Msg_NE
15669                           ("missing argument for parameter & "
15670                            & "in call to % (inherited) #", N, Formal);
15671
15672                      else
15673                         Error_Msg_NE
15674                           ("missing argument for parameter &", N, Formal);
15675                      end if;
15676                   end if;
15677
15678                   Success := False;
15679                   return;
15680
15681                else
15682                   Formals_To_Match := Formals_To_Match - 1;
15683                end if;
15684             end if;
15685          end if;
15686
15687          Next_Formal (Formal);
15688       end loop;
15689
15690       if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
15691          Success := True;
15692          return;
15693
15694       else
15695          if Reporting then
15696
15697             --  Find some superfluous named actual that did not get
15698             --  attached to the list of associations.
15699
15700             Actual := First (Actuals);
15701             while Present (Actual) loop
15702                if Nkind (Actual) = N_Parameter_Association
15703                  and then Actual /= Last
15704                  and then No (Next_Named_Actual (Actual))
15705                then
15706                   Error_Msg_N ("unmatched actual & in call",
15707                     Selector_Name (Actual));
15708                   exit;
15709                end if;
15710
15711                Next (Actual);
15712             end loop;
15713          end if;
15714
15715          Success := False;
15716          return;
15717       end if;
15718    end Normalize_Actuals;
15719
15720    --------------------------------
15721    -- Note_Possible_Modification --
15722    --------------------------------
15723
15724    procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is
15725       Modification_Comes_From_Source : constant Boolean :=
15726                                          Comes_From_Source (Parent (N));
15727
15728       Ent : Entity_Id;
15729       Exp : Node_Id;
15730
15731    begin
15732       --  Loop to find referenced entity, if there is one
15733
15734       Exp := N;
15735       loop
15736          Ent := Empty;
15737
15738          if Is_Entity_Name (Exp) then
15739             Ent := Entity (Exp);
15740
15741             --  If the entity is missing, it is an undeclared identifier,
15742             --  and there is nothing to annotate.
15743
15744             if No (Ent) then
15745                return;
15746             end if;
15747
15748          elsif Nkind (Exp) = N_Explicit_Dereference then
15749             declare
15750                P : constant Node_Id := Prefix (Exp);
15751
15752             begin
15753                --  In formal verification mode, keep track of all reads and
15754                --  writes through explicit dereferences.
15755
15756                if GNATprove_Mode then
15757                   SPARK_Specific.Generate_Dereference (N, 'm');
15758                end if;
15759
15760                if Nkind (P) = N_Selected_Component
15761                  and then Present (Entry_Formal (Entity (Selector_Name (P))))
15762                then
15763                   --  Case of a reference to an entry formal
15764
15765                   Ent := Entry_Formal (Entity (Selector_Name (P)));
15766
15767                elsif Nkind (P) = N_Identifier
15768                  and then Nkind (Parent (Entity (P))) = N_Object_Declaration
15769                  and then Present (Expression (Parent (Entity (P))))
15770                  and then Nkind (Expression (Parent (Entity (P)))) =
15771                                                                N_Reference
15772                then
15773                   --  Case of a reference to a value on which side effects have
15774                   --  been removed.
15775
15776                   Exp := Prefix (Expression (Parent (Entity (P))));
15777                   goto Continue;
15778
15779                else
15780                   return;
15781                end if;
15782             end;
15783
15784          elsif Nkind_In (Exp, N_Type_Conversion,
15785                               N_Unchecked_Type_Conversion)
15786          then
15787             Exp := Expression (Exp);
15788             goto Continue;
15789
15790          elsif Nkind_In (Exp, N_Slice,
15791                               N_Indexed_Component,
15792                               N_Selected_Component)
15793          then
15794             --  Special check, if the prefix is an access type, then return
15795             --  since we are modifying the thing pointed to, not the prefix.
15796             --  When we are expanding, most usually the prefix is replaced
15797             --  by an explicit dereference, and this test is not needed, but
15798             --  in some cases (notably -gnatc mode and generics) when we do
15799             --  not do full expansion, we need this special test.
15800
15801             if Is_Access_Type (Etype (Prefix (Exp))) then
15802                return;
15803
15804             --  Otherwise go to prefix and keep going
15805
15806             else
15807                Exp := Prefix (Exp);
15808                goto Continue;
15809             end if;
15810
15811          --  All other cases, not a modification
15812
15813          else
15814             return;
15815          end if;
15816
15817          --  Now look for entity being referenced
15818
15819          if Present (Ent) then
15820             if Is_Object (Ent) then
15821                if Comes_From_Source (Exp)
15822                  or else Modification_Comes_From_Source
15823                then
15824                   --  Give warning if pragma unmodified given and we are
15825                   --  sure this is a modification.
15826
15827                   if Has_Pragma_Unmodified (Ent) and then Sure then
15828                      Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent);
15829                   end if;
15830
15831                   Set_Never_Set_In_Source (Ent, False);
15832                end if;
15833
15834                Set_Is_True_Constant (Ent, False);
15835                Set_Current_Value    (Ent, Empty);
15836                Set_Is_Known_Null    (Ent, False);
15837
15838                if not Can_Never_Be_Null (Ent) then
15839                   Set_Is_Known_Non_Null (Ent, False);
15840                end if;
15841
15842                --  Follow renaming chain
15843
15844                if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
15845                  and then Present (Renamed_Object (Ent))
15846                then
15847                   Exp := Renamed_Object (Ent);
15848
15849                   --  If the entity is the loop variable in an iteration over
15850                   --  a container, retrieve container expression to indicate
15851                   --  possible modification.
15852
15853                   if Present (Related_Expression (Ent))
15854                     and then Nkind (Parent (Related_Expression (Ent))) =
15855                                                    N_Iterator_Specification
15856                   then
15857                      Exp := Original_Node (Related_Expression (Ent));
15858                   end if;
15859
15860                   goto Continue;
15861
15862                --  The expression may be the renaming of a subcomponent of an
15863                --  array or container. The assignment to the subcomponent is
15864                --  a modification of the container.
15865
15866                elsif Comes_From_Source (Original_Node (Exp))
15867                  and then Nkind_In (Original_Node (Exp), N_Selected_Component,
15868                                                          N_Indexed_Component)
15869                then
15870                   Exp := Prefix (Original_Node (Exp));
15871                   goto Continue;
15872                end if;
15873
15874                --  Generate a reference only if the assignment comes from
15875                --  source. This excludes, for example, calls to a dispatching
15876                --  assignment operation when the left-hand side is tagged. In
15877                --  GNATprove mode, we need those references also on generated
15878                --  code, as these are used to compute the local effects of
15879                --  subprograms.
15880
15881                if Modification_Comes_From_Source or GNATprove_Mode then
15882                   Generate_Reference (Ent, Exp, 'm');
15883
15884                   --  If the target of the assignment is the bound variable
15885                   --  in an iterator, indicate that the corresponding array
15886                   --  or container is also modified.
15887
15888                   if Ada_Version >= Ada_2012
15889                     and then Nkind (Parent (Ent)) = N_Iterator_Specification
15890                   then
15891                      declare
15892                         Domain : constant Node_Id := Name (Parent (Ent));
15893
15894                      begin
15895                         --  TBD : in the full version of the construct, the
15896                         --  domain of iteration can be given by an expression.
15897
15898                         if Is_Entity_Name (Domain) then
15899                            Generate_Reference      (Entity (Domain), Exp, 'm');
15900                            Set_Is_True_Constant    (Entity (Domain), False);
15901                            Set_Never_Set_In_Source (Entity (Domain), False);
15902                         end if;
15903                      end;
15904                   end if;
15905                end if;
15906             end if;
15907
15908             Kill_Checks (Ent);
15909
15910             --  If we are sure this is a modification from source, and we know
15911             --  this modifies a constant, then give an appropriate warning.
15912
15913             if Overlays_Constant (Ent)
15914               and then (Modification_Comes_From_Source and Sure)
15915             then
15916                declare
15917                   A : constant Node_Id := Address_Clause (Ent);
15918                begin
15919                   if Present (A) then
15920                      declare
15921                         Exp : constant Node_Id := Expression (A);
15922                      begin
15923                         if Nkind (Exp) = N_Attribute_Reference
15924                           and then Attribute_Name (Exp) = Name_Address
15925                           and then Is_Entity_Name (Prefix (Exp))
15926                         then
15927                            Error_Msg_Sloc := Sloc (A);
15928                            Error_Msg_NE
15929                              ("constant& may be modified via address "
15930                               & "clause#??", N, Entity (Prefix (Exp)));
15931                         end if;
15932                      end;
15933                   end if;
15934                end;
15935             end if;
15936
15937             return;
15938          end if;
15939
15940       <<Continue>>
15941          null;
15942       end loop;
15943    end Note_Possible_Modification;
15944
15945    -------------------------
15946    -- Object_Access_Level --
15947    -------------------------
15948
15949    --  Returns the static accessibility level of the view denoted by Obj. Note
15950    --  that the value returned is the result of a call to Scope_Depth. Only
15951    --  scope depths associated with dynamic scopes can actually be returned.
15952    --  Since only relative levels matter for accessibility checking, the fact
15953    --  that the distance between successive levels of accessibility is not
15954    --  always one is immaterial (invariant: if level(E2) is deeper than
15955    --  level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
15956
15957    function Object_Access_Level (Obj : Node_Id) return Uint is
15958       function Is_Interface_Conversion (N : Node_Id) return Boolean;
15959       --  Determine whether N is a construct of the form
15960       --    Some_Type (Operand._tag'Address)
15961       --  This construct appears in the context of dispatching calls.
15962
15963       function Reference_To (Obj : Node_Id) return Node_Id;
15964       --  An explicit dereference is created when removing side-effects from
15965       --  expressions for constraint checking purposes. In this case a local
15966       --  access type is created for it. The correct access level is that of
15967       --  the original source node. We detect this case by noting that the
15968       --  prefix of the dereference is created by an object declaration whose
15969       --  initial expression is a reference.
15970
15971       -----------------------------
15972       -- Is_Interface_Conversion --
15973       -----------------------------
15974
15975       function Is_Interface_Conversion (N : Node_Id) return Boolean is
15976       begin
15977          return Nkind (N) = N_Unchecked_Type_Conversion
15978            and then Nkind (Expression (N)) = N_Attribute_Reference
15979            and then Attribute_Name (Expression (N)) = Name_Address;
15980       end Is_Interface_Conversion;
15981
15982       ------------------
15983       -- Reference_To --
15984       ------------------
15985
15986       function Reference_To (Obj : Node_Id) return Node_Id is
15987          Pref : constant Node_Id := Prefix (Obj);
15988       begin
15989          if Is_Entity_Name (Pref)
15990            and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration
15991            and then Present (Expression (Parent (Entity (Pref))))
15992            and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference
15993          then
15994             return (Prefix (Expression (Parent (Entity (Pref)))));
15995          else
15996             return Empty;
15997          end if;
15998       end Reference_To;
15999
16000       --  Local variables
16001
16002       E : Entity_Id;
16003
16004    --  Start of processing for Object_Access_Level
16005
16006    begin
16007       if Nkind (Obj) = N_Defining_Identifier
16008         or else Is_Entity_Name (Obj)
16009       then
16010          if Nkind (Obj) = N_Defining_Identifier then
16011             E := Obj;
16012          else
16013             E := Entity (Obj);
16014          end if;
16015
16016          if Is_Prival (E) then
16017             E := Prival_Link (E);
16018          end if;
16019
16020          --  If E is a type then it denotes a current instance. For this case
16021          --  we add one to the normal accessibility level of the type to ensure
16022          --  that current instances are treated as always being deeper than
16023          --  than the level of any visible named access type (see 3.10.2(21)).
16024
16025          if Is_Type (E) then
16026             return Type_Access_Level (E) +  1;
16027
16028          elsif Present (Renamed_Object (E)) then
16029             return Object_Access_Level (Renamed_Object (E));
16030
16031          --  Similarly, if E is a component of the current instance of a
16032          --  protected type, any instance of it is assumed to be at a deeper
16033          --  level than the type. For a protected object (whose type is an
16034          --  anonymous protected type) its components are at the same level
16035          --  as the type itself.
16036
16037          elsif not Is_Overloadable (E)
16038            and then Ekind (Scope (E)) = E_Protected_Type
16039            and then Comes_From_Source (Scope (E))
16040          then
16041             return Type_Access_Level (Scope (E)) + 1;
16042
16043          else
16044             --  Aliased formals take their access level from the point of call.
16045             --  This is smaller than the level of the subprogram itself.
16046
16047             if Is_Formal (E) and then Is_Aliased (E) then
16048                return Type_Access_Level (Etype (E));
16049
16050             else
16051                return Scope_Depth (Enclosing_Dynamic_Scope (E));
16052             end if;
16053          end if;
16054
16055       elsif Nkind (Obj) = N_Selected_Component then
16056          if Is_Access_Type (Etype (Prefix (Obj))) then
16057             return Type_Access_Level (Etype (Prefix (Obj)));
16058          else
16059             return Object_Access_Level (Prefix (Obj));
16060          end if;
16061
16062       elsif Nkind (Obj) = N_Indexed_Component then
16063          if Is_Access_Type (Etype (Prefix (Obj))) then
16064             return Type_Access_Level (Etype (Prefix (Obj)));
16065          else
16066             return Object_Access_Level (Prefix (Obj));
16067          end if;
16068
16069       elsif Nkind (Obj) = N_Explicit_Dereference then
16070
16071          --  If the prefix is a selected access discriminant then we make a
16072          --  recursive call on the prefix, which will in turn check the level
16073          --  of the prefix object of the selected discriminant.
16074
16075          --  In Ada 2012, if the discriminant has implicit dereference and
16076          --  the context is a selected component, treat this as an object of
16077          --  unknown scope (see below). This is necessary in compile-only mode;
16078          --  otherwise expansion will already have transformed the prefix into
16079          --  a temporary.
16080
16081          if Nkind (Prefix (Obj)) = N_Selected_Component
16082            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
16083            and then
16084              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
16085            and then
16086              (not Has_Implicit_Dereference
16087                     (Entity (Selector_Name (Prefix (Obj))))
16088                or else Nkind (Parent (Obj)) /= N_Selected_Component)
16089          then
16090             return Object_Access_Level (Prefix (Obj));
16091
16092          --  Detect an interface conversion in the context of a dispatching
16093          --  call. Use the original form of the conversion to find the access
16094          --  level of the operand.
16095
16096          elsif Is_Interface (Etype (Obj))
16097            and then Is_Interface_Conversion (Prefix (Obj))
16098            and then Nkind (Original_Node (Obj)) = N_Type_Conversion
16099          then
16100             return Object_Access_Level (Original_Node (Obj));
16101
16102          elsif not Comes_From_Source (Obj) then
16103             declare
16104                Ref : constant Node_Id := Reference_To (Obj);
16105             begin
16106                if Present (Ref) then
16107                   return Object_Access_Level (Ref);
16108                else
16109                   return Type_Access_Level (Etype (Prefix (Obj)));
16110                end if;
16111             end;
16112
16113          else
16114             return Type_Access_Level (Etype (Prefix (Obj)));
16115          end if;
16116
16117       elsif Nkind_In (Obj, N_Type_Conversion, N_Unchecked_Type_Conversion) then
16118          return Object_Access_Level (Expression (Obj));
16119
16120       elsif Nkind (Obj) = N_Function_Call then
16121
16122          --  Function results are objects, so we get either the access level of
16123          --  the function or, in the case of an indirect call, the level of the
16124          --  access-to-subprogram type. (This code is used for Ada 95, but it
16125          --  looks wrong, because it seems that we should be checking the level
16126          --  of the call itself, even for Ada 95. However, using the Ada 2005
16127          --  version of the code causes regressions in several tests that are
16128          --  compiled with -gnat95. ???)
16129
16130          if Ada_Version < Ada_2005 then
16131             if Is_Entity_Name (Name (Obj)) then
16132                return Subprogram_Access_Level (Entity (Name (Obj)));
16133             else
16134                return Type_Access_Level (Etype (Prefix (Name (Obj))));
16135             end if;
16136
16137          --  For Ada 2005, the level of the result object of a function call is
16138          --  defined to be the level of the call's innermost enclosing master.
16139          --  We determine that by querying the depth of the innermost enclosing
16140          --  dynamic scope.
16141
16142          else
16143             Return_Master_Scope_Depth_Of_Call : declare
16144
16145                function Innermost_Master_Scope_Depth
16146                  (N : Node_Id) return Uint;
16147                --  Returns the scope depth of the given node's innermost
16148                --  enclosing dynamic scope (effectively the accessibility
16149                --  level of the innermost enclosing master).
16150
16151                ----------------------------------
16152                -- Innermost_Master_Scope_Depth --
16153                ----------------------------------
16154
16155                function Innermost_Master_Scope_Depth
16156                  (N : Node_Id) return Uint
16157                is
16158                   Node_Par : Node_Id := Parent (N);
16159
16160                begin
16161                   --  Locate the nearest enclosing node (by traversing Parents)
16162                   --  that Defining_Entity can be applied to, and return the
16163                   --  depth of that entity's nearest enclosing dynamic scope.
16164
16165                   while Present (Node_Par) loop
16166                      case Nkind (Node_Par) is
16167                         when N_Component_Declaration           |
16168                              N_Entry_Declaration               |
16169                              N_Formal_Object_Declaration       |
16170                              N_Formal_Type_Declaration         |
16171                              N_Full_Type_Declaration           |
16172                              N_Incomplete_Type_Declaration     |
16173                              N_Loop_Parameter_Specification    |
16174                              N_Object_Declaration              |
16175                              N_Protected_Type_Declaration      |
16176                              N_Private_Extension_Declaration   |
16177                              N_Private_Type_Declaration        |
16178                              N_Subtype_Declaration             |
16179                              N_Function_Specification          |
16180                              N_Procedure_Specification         |
16181                              N_Task_Type_Declaration           |
16182                              N_Body_Stub                       |
16183                              N_Generic_Instantiation           |
16184                              N_Proper_Body                     |
16185                              N_Implicit_Label_Declaration      |
16186                              N_Package_Declaration             |
16187                              N_Single_Task_Declaration         |
16188                              N_Subprogram_Declaration          |
16189                              N_Generic_Declaration             |
16190                              N_Renaming_Declaration            |
16191                              N_Block_Statement                 |
16192                              N_Formal_Subprogram_Declaration   |
16193                              N_Abstract_Subprogram_Declaration |
16194                              N_Entry_Body                      |
16195                              N_Exception_Declaration           |
16196                              N_Formal_Package_Declaration      |
16197                              N_Number_Declaration              |
16198                              N_Package_Specification           |
16199                              N_Parameter_Specification         |
16200                              N_Single_Protected_Declaration    |
16201                              N_Subunit                         =>
16202
16203                            return Scope_Depth
16204                                     (Nearest_Dynamic_Scope
16205                                        (Defining_Entity (Node_Par)));
16206
16207                         when others =>
16208                            null;
16209                      end case;
16210
16211                      Node_Par := Parent (Node_Par);
16212                   end loop;
16213
16214                   pragma Assert (False);
16215
16216                   --  Should never reach the following return
16217
16218                   return Scope_Depth (Current_Scope) + 1;
16219                end Innermost_Master_Scope_Depth;
16220
16221             --  Start of processing for Return_Master_Scope_Depth_Of_Call
16222
16223             begin
16224                return Innermost_Master_Scope_Depth (Obj);
16225             end Return_Master_Scope_Depth_Of_Call;
16226          end if;
16227
16228       --  For convenience we handle qualified expressions, even though they
16229       --  aren't technically object names.
16230
16231       elsif Nkind (Obj) = N_Qualified_Expression then
16232          return Object_Access_Level (Expression (Obj));
16233
16234       --  Ditto for aggregates. They have the level of the temporary that
16235       --  will hold their value.
16236
16237       elsif Nkind (Obj) = N_Aggregate then
16238          return Object_Access_Level (Current_Scope);
16239
16240       --  Otherwise return the scope level of Standard. (If there are cases
16241       --  that fall through to this point they will be treated as having
16242       --  global accessibility for now. ???)
16243
16244       else
16245          return Scope_Depth (Standard_Standard);
16246       end if;
16247    end Object_Access_Level;
16248
16249    ---------------------------------
16250    -- Original_Aspect_Pragma_Name --
16251    ---------------------------------
16252
16253    function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is
16254       Item     : Node_Id;
16255       Item_Nam : Name_Id;
16256
16257    begin
16258       pragma Assert (Nkind_In (N, N_Aspect_Specification, N_Pragma));
16259
16260       Item := N;
16261
16262       --  The pragma was generated to emulate an aspect, use the original
16263       --  aspect specification.
16264
16265       if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then
16266          Item := Corresponding_Aspect (Item);
16267       end if;
16268
16269       --  Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class,
16270       --  Post and Post_Class rewrite their pragma identifier to preserve the
16271       --  original name.
16272       --  ??? this is kludgey
16273
16274       if Nkind (Item) = N_Pragma then
16275          Item_Nam := Chars (Original_Node (Pragma_Identifier (Item)));
16276
16277       else
16278          pragma Assert (Nkind (Item) = N_Aspect_Specification);
16279          Item_Nam := Chars (Identifier (Item));
16280       end if;
16281
16282       --  Deal with 'Class by converting the name to its _XXX form
16283
16284       if Class_Present (Item) then
16285          if Item_Nam = Name_Invariant then
16286             Item_Nam := Name_uInvariant;
16287
16288          elsif Item_Nam = Name_Post then
16289             Item_Nam := Name_uPost;
16290
16291          elsif Item_Nam = Name_Pre then
16292             Item_Nam := Name_uPre;
16293
16294          elsif Nam_In (Item_Nam, Name_Type_Invariant,
16295                                  Name_Type_Invariant_Class)
16296          then
16297             Item_Nam := Name_uType_Invariant;
16298
16299          --  Nothing to do for other cases (e.g. a Check that derived from
16300          --  Pre_Class and has the flag set). Also we do nothing if the name
16301          --  is already in special _xxx form.
16302
16303          end if;
16304       end if;
16305
16306       return Item_Nam;
16307    end Original_Aspect_Pragma_Name;
16308
16309    --------------------------------------
16310    -- Original_Corresponding_Operation --
16311    --------------------------------------
16312
16313    function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id
16314    is
16315       Typ : constant Entity_Id := Find_Dispatching_Type (S);
16316
16317    begin
16318       --  If S is an inherited primitive S2 the original corresponding
16319       --  operation of S is the original corresponding operation of S2
16320
16321       if Present (Alias (S))
16322         and then Find_Dispatching_Type (Alias (S)) /= Typ
16323       then
16324          return Original_Corresponding_Operation (Alias (S));
16325
16326       --  If S overrides an inherited subprogram S2 the original corresponding
16327       --  operation of S is the original corresponding operation of S2
16328
16329       elsif Present (Overridden_Operation (S)) then
16330          return Original_Corresponding_Operation (Overridden_Operation (S));
16331
16332       --  otherwise it is S itself
16333
16334       else
16335          return S;
16336       end if;
16337    end Original_Corresponding_Operation;
16338
16339    ----------------------
16340    -- Policy_In_Effect --
16341    ----------------------
16342
16343    function Policy_In_Effect (Policy : Name_Id) return Name_Id is
16344       function Policy_In_List (List : Node_Id) return Name_Id;
16345       --  Determine the mode of a policy in a N_Pragma list
16346
16347       --------------------
16348       -- Policy_In_List --
16349       --------------------
16350
16351       function Policy_In_List (List : Node_Id) return Name_Id is
16352          Arg1 : Node_Id;
16353          Arg2 : Node_Id;
16354          Prag : Node_Id;
16355
16356       begin
16357          Prag := List;
16358          while Present (Prag) loop
16359             Arg1 := First (Pragma_Argument_Associations (Prag));
16360             Arg2 := Next (Arg1);
16361
16362             Arg1 := Get_Pragma_Arg (Arg1);
16363             Arg2 := Get_Pragma_Arg (Arg2);
16364
16365             --  The current Check_Policy pragma matches the requested policy or
16366             --  appears in the single argument form (Assertion, policy_id).
16367
16368             if Nam_In (Chars (Arg1), Name_Assertion, Policy) then
16369                return Chars (Arg2);
16370             end if;
16371
16372             Prag := Next_Pragma (Prag);
16373          end loop;
16374
16375          return No_Name;
16376       end Policy_In_List;
16377
16378       --  Local variables
16379
16380       Kind : Name_Id;
16381
16382    --  Start of processing for Policy_In_Effect
16383
16384    begin
16385       if not Is_Valid_Assertion_Kind (Policy) then
16386          raise Program_Error;
16387       end if;
16388
16389       --  Inspect all policy pragmas that appear within scopes (if any)
16390
16391       Kind := Policy_In_List (Check_Policy_List);
16392
16393       --  Inspect all configuration policy pragmas (if any)
16394
16395       if Kind = No_Name then
16396          Kind := Policy_In_List (Check_Policy_List_Config);
16397       end if;
16398
16399       --  The context lacks policy pragmas, determine the mode based on whether
16400       --  assertions are enabled at the configuration level. This ensures that
16401       --  the policy is preserved when analyzing generics.
16402
16403       if Kind = No_Name then
16404          if Assertions_Enabled_Config then
16405             Kind := Name_Check;
16406          else
16407             Kind := Name_Ignore;
16408          end if;
16409       end if;
16410
16411       return Kind;
16412    end Policy_In_Effect;
16413
16414    ----------------------------------
16415    -- Predicate_Tests_On_Arguments --
16416    ----------------------------------
16417
16418    function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is
16419    begin
16420       --  Always test predicates on indirect call
16421
16422       if Ekind (Subp) = E_Subprogram_Type then
16423          return True;
16424
16425       --  Do not test predicates on call to generated default Finalize, since
16426       --  we are not interested in whether something we are finalizing (and
16427       --  typically destroying) satisfies its predicates.
16428
16429       elsif Chars (Subp) = Name_Finalize
16430         and then not Comes_From_Source (Subp)
16431       then
16432          return False;
16433
16434       --  Do not test predicates on any internally generated routines
16435
16436       elsif Is_Internal_Name (Chars (Subp)) then
16437          return False;
16438
16439       --  Do not test predicates on call to Init_Proc, since if needed the
16440       --  predicate test will occur at some other point.
16441
16442       elsif Is_Init_Proc (Subp) then
16443          return False;
16444
16445       --  Do not test predicates on call to predicate function, since this
16446       --  would cause infinite recursion.
16447
16448       elsif Ekind (Subp) = E_Function
16449         and then (Is_Predicate_Function   (Subp)
16450                     or else
16451                   Is_Predicate_Function_M (Subp))
16452       then
16453          return False;
16454
16455       --  For now, no other exceptions
16456
16457       else
16458          return True;
16459       end if;
16460    end Predicate_Tests_On_Arguments;
16461
16462    -----------------------
16463    -- Private_Component --
16464    -----------------------
16465
16466    function Private_Component (Type_Id : Entity_Id) return Entity_Id is
16467       Ancestor  : constant Entity_Id := Base_Type (Type_Id);
16468
16469       function Trace_Components
16470         (T     : Entity_Id;
16471          Check : Boolean) return Entity_Id;
16472       --  Recursive function that does the work, and checks against circular
16473       --  definition for each subcomponent type.
16474
16475       ----------------------
16476       -- Trace_Components --
16477       ----------------------
16478
16479       function Trace_Components
16480          (T     : Entity_Id;
16481           Check : Boolean) return Entity_Id
16482        is
16483          Btype     : constant Entity_Id := Base_Type (T);
16484          Component : Entity_Id;
16485          P         : Entity_Id;
16486          Candidate : Entity_Id := Empty;
16487
16488       begin
16489          if Check and then Btype = Ancestor then
16490             Error_Msg_N ("circular type definition", Type_Id);
16491             return Any_Type;
16492          end if;
16493
16494          if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then
16495             if Present (Full_View (Btype))
16496               and then Is_Record_Type (Full_View (Btype))
16497               and then not Is_Frozen (Btype)
16498             then
16499                --  To indicate that the ancestor depends on a private type, the
16500                --  current Btype is sufficient. However, to check for circular
16501                --  definition we must recurse on the full view.
16502
16503                Candidate := Trace_Components (Full_View (Btype), True);
16504
16505                if Candidate = Any_Type then
16506                   return Any_Type;
16507                else
16508                   return Btype;
16509                end if;
16510
16511             else
16512                return Btype;
16513             end if;
16514
16515          elsif Is_Array_Type (Btype) then
16516             return Trace_Components (Component_Type (Btype), True);
16517
16518          elsif Is_Record_Type (Btype) then
16519             Component := First_Entity (Btype);
16520             while Present (Component)
16521               and then Comes_From_Source (Component)
16522             loop
16523                --  Skip anonymous types generated by constrained components
16524
16525                if not Is_Type (Component) then
16526                   P := Trace_Components (Etype (Component), True);
16527
16528                   if Present (P) then
16529                      if P = Any_Type then
16530                         return P;
16531                      else
16532                         Candidate := P;
16533                      end if;
16534                   end if;
16535                end if;
16536
16537                Next_Entity (Component);
16538             end loop;
16539
16540             return Candidate;
16541
16542          else
16543             return Empty;
16544          end if;
16545       end Trace_Components;
16546
16547    --  Start of processing for Private_Component
16548
16549    begin
16550       return Trace_Components (Type_Id, False);
16551    end Private_Component;
16552
16553    ---------------------------
16554    -- Primitive_Names_Match --
16555    ---------------------------
16556
16557    function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
16558
16559       function Non_Internal_Name (E : Entity_Id) return Name_Id;
16560       --  Given an internal name, returns the corresponding non-internal name
16561
16562       ------------------------
16563       --  Non_Internal_Name --
16564       ------------------------
16565
16566       function Non_Internal_Name (E : Entity_Id) return Name_Id is
16567       begin
16568          Get_Name_String (Chars (E));
16569          Name_Len := Name_Len - 1;
16570          return Name_Find;
16571       end Non_Internal_Name;
16572
16573    --  Start of processing for Primitive_Names_Match
16574
16575    begin
16576       pragma Assert (Present (E1) and then Present (E2));
16577
16578       return Chars (E1) = Chars (E2)
16579         or else
16580            (not Is_Internal_Name (Chars (E1))
16581              and then Is_Internal_Name (Chars (E2))
16582              and then Non_Internal_Name (E2) = Chars (E1))
16583         or else
16584            (not Is_Internal_Name (Chars (E2))
16585              and then Is_Internal_Name (Chars (E1))
16586              and then Non_Internal_Name (E1) = Chars (E2))
16587         or else
16588            (Is_Predefined_Dispatching_Operation (E1)
16589              and then Is_Predefined_Dispatching_Operation (E2)
16590              and then Same_TSS (E1, E2))
16591         or else
16592            (Is_Init_Proc (E1) and then Is_Init_Proc (E2));
16593    end Primitive_Names_Match;
16594
16595    -----------------------
16596    -- Process_End_Label --
16597    -----------------------
16598
16599    procedure Process_End_Label
16600      (N   : Node_Id;
16601       Typ : Character;
16602       Ent : Entity_Id)
16603    is
16604       Loc  : Source_Ptr;
16605       Nam  : Node_Id;
16606       Scop : Entity_Id;
16607
16608       Label_Ref : Boolean;
16609       --  Set True if reference to end label itself is required
16610
16611       Endl : Node_Id;
16612       --  Gets set to the operator symbol or identifier that references the
16613       --  entity Ent. For the child unit case, this is the identifier from the
16614       --  designator. For other cases, this is simply Endl.
16615
16616       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id);
16617       --  N is an identifier node that appears as a parent unit reference in
16618       --  the case where Ent is a child unit. This procedure generates an
16619       --  appropriate cross-reference entry. E is the corresponding entity.
16620
16621       -------------------------
16622       -- Generate_Parent_Ref --
16623       -------------------------
16624
16625       procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is
16626       begin
16627          --  If names do not match, something weird, skip reference
16628
16629          if Chars (E) = Chars (N) then
16630
16631             --  Generate the reference. We do NOT consider this as a reference
16632             --  for unreferenced symbol purposes.
16633
16634             Generate_Reference (E, N, 'r', Set_Ref => False, Force => True);
16635
16636             if Style_Check then
16637                Style.Check_Identifier (N, E);
16638             end if;
16639          end if;
16640       end Generate_Parent_Ref;
16641
16642    --  Start of processing for Process_End_Label
16643
16644    begin
16645       --  If no node, ignore. This happens in some error situations, and
16646       --  also for some internally generated structures where no end label
16647       --  references are required in any case.
16648
16649       if No (N) then
16650          return;
16651       end if;
16652
16653       --  Nothing to do if no End_Label, happens for internally generated
16654       --  constructs where we don't want an end label reference anyway. Also
16655       --  nothing to do if Endl is a string literal, which means there was
16656       --  some prior error (bad operator symbol)
16657
16658       Endl := End_Label (N);
16659
16660       if No (Endl) or else Nkind (Endl) = N_String_Literal then
16661          return;
16662       end if;
16663
16664       --  Reference node is not in extended main source unit
16665
16666       if not In_Extended_Main_Source_Unit (N) then
16667
16668          --  Generally we do not collect references except for the extended
16669          --  main source unit. The one exception is the 'e' entry for a
16670          --  package spec, where it is useful for a client to have the
16671          --  ending information to define scopes.
16672
16673          if Typ /= 'e' then
16674             return;
16675
16676          else
16677             Label_Ref := False;
16678
16679             --  For this case, we can ignore any parent references, but we
16680             --  need the package name itself for the 'e' entry.
16681
16682             if Nkind (Endl) = N_Designator then
16683                Endl := Identifier (Endl);
16684             end if;
16685          end if;
16686
16687       --  Reference is in extended main source unit
16688
16689       else
16690          Label_Ref := True;
16691
16692          --  For designator, generate references for the parent entries
16693
16694          if Nkind (Endl) = N_Designator then
16695
16696             --  Generate references for the prefix if the END line comes from
16697             --  source (otherwise we do not need these references) We climb the
16698             --  scope stack to find the expected entities.
16699
16700             if Comes_From_Source (Endl) then
16701                Nam  := Name (Endl);
16702                Scop := Current_Scope;
16703                while Nkind (Nam) = N_Selected_Component loop
16704                   Scop := Scope (Scop);
16705                   exit when No (Scop);
16706                   Generate_Parent_Ref (Selector_Name (Nam), Scop);
16707                   Nam := Prefix (Nam);
16708                end loop;
16709
16710                if Present (Scop) then
16711                   Generate_Parent_Ref (Nam, Scope (Scop));
16712                end if;
16713             end if;
16714
16715             Endl := Identifier (Endl);
16716          end if;
16717       end if;
16718
16719       --  If the end label is not for the given entity, then either we have
16720       --  some previous error, or this is a generic instantiation for which
16721       --  we do not need to make a cross-reference in this case anyway. In
16722       --  either case we simply ignore the call.
16723
16724       if Chars (Ent) /= Chars (Endl) then
16725          return;
16726       end if;
16727
16728       --  If label was really there, then generate a normal reference and then
16729       --  adjust the location in the end label to point past the name (which
16730       --  should almost always be the semicolon).
16731
16732       Loc := Sloc (Endl);
16733
16734       if Comes_From_Source (Endl) then
16735
16736          --  If a label reference is required, then do the style check and
16737          --  generate an l-type cross-reference entry for the label
16738
16739          if Label_Ref then
16740             if Style_Check then
16741                Style.Check_Identifier (Endl, Ent);
16742             end if;
16743
16744             Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
16745          end if;
16746
16747          --  Set the location to point past the label (normally this will
16748          --  mean the semicolon immediately following the label). This is
16749          --  done for the sake of the 'e' or 't' entry generated below.
16750
16751          Get_Decoded_Name_String (Chars (Endl));
16752          Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
16753
16754       else
16755          --  In SPARK mode, no missing label is allowed for packages and
16756          --  subprogram bodies. Detect those cases by testing whether
16757          --  Process_End_Label was called for a body (Typ = 't') or a package.
16758
16759          if Restriction_Check_Required (SPARK_05)
16760            and then (Typ = 't' or else Ekind (Ent) = E_Package)
16761          then
16762             Error_Msg_Node_1 := Endl;
16763             Check_SPARK_05_Restriction
16764               ("`END &` required", Endl, Force => True);
16765          end if;
16766       end if;
16767
16768       --  Now generate the e/t reference
16769
16770       Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
16771
16772       --  Restore Sloc, in case modified above, since we have an identifier
16773       --  and the normal Sloc should be left set in the tree.
16774
16775       Set_Sloc (Endl, Loc);
16776    end Process_End_Label;
16777
16778    ----------------
16779    -- Referenced --
16780    ----------------
16781
16782    function Referenced (Id : Entity_Id; Expr : Node_Id) return Boolean is
16783       Seen : Boolean := False;
16784
16785       function Is_Reference (N : Node_Id) return Traverse_Result;
16786       --  Determine whether node N denotes a reference to Id. If this is the
16787       --  case, set global flag Seen to True and stop the traversal.
16788
16789       ------------------
16790       -- Is_Reference --
16791       ------------------
16792
16793       function Is_Reference (N : Node_Id) return Traverse_Result is
16794       begin
16795          if Is_Entity_Name (N)
16796            and then Present (Entity (N))
16797            and then Entity (N) = Id
16798          then
16799             Seen := True;
16800             return Abandon;
16801          else
16802             return OK;
16803          end if;
16804       end Is_Reference;
16805
16806       procedure Inspect_Expression is new Traverse_Proc (Is_Reference);
16807
16808    --  Start of processing for Referenced
16809
16810    begin
16811       Inspect_Expression (Expr);
16812       return Seen;
16813    end Referenced;
16814
16815    ------------------------------------
16816    -- References_Generic_Formal_Type --
16817    ------------------------------------
16818
16819    function References_Generic_Formal_Type (N : Node_Id) return Boolean is
16820
16821       function Process (N : Node_Id) return Traverse_Result;
16822       --  Process one node in search for generic formal type
16823
16824       -------------
16825       -- Process --
16826       -------------
16827
16828       function Process (N : Node_Id) return Traverse_Result is
16829       begin
16830          if Nkind (N) in N_Has_Entity then
16831             declare
16832                E : constant Entity_Id := Entity (N);
16833             begin
16834                if Present (E) then
16835                   if Is_Generic_Type (E) then
16836                      return Abandon;
16837                   elsif Present (Etype (E))
16838                     and then Is_Generic_Type (Etype (E))
16839                   then
16840                      return Abandon;
16841                   end if;
16842                end if;
16843             end;
16844          end if;
16845
16846          return Atree.OK;
16847       end Process;
16848
16849       function Traverse is new Traverse_Func (Process);
16850       --  Traverse tree to look for generic type
16851
16852    begin
16853       if Inside_A_Generic then
16854          return Traverse (N) = Abandon;
16855       else
16856          return False;
16857       end if;
16858    end References_Generic_Formal_Type;
16859
16860    --------------------
16861    -- Remove_Homonym --
16862    --------------------
16863
16864    procedure Remove_Homonym (E : Entity_Id) is
16865       Prev  : Entity_Id := Empty;
16866       H     : Entity_Id;
16867
16868    begin
16869       if E = Current_Entity (E) then
16870          if Present (Homonym (E)) then
16871             Set_Current_Entity (Homonym (E));
16872          else
16873             Set_Name_Entity_Id (Chars (E), Empty);
16874          end if;
16875
16876       else
16877          H := Current_Entity (E);
16878          while Present (H) and then H /= E loop
16879             Prev := H;
16880             H    := Homonym (H);
16881          end loop;
16882
16883          --  If E is not on the homonym chain, nothing to do
16884
16885          if Present (H) then
16886             Set_Homonym (Prev, Homonym (E));
16887          end if;
16888       end if;
16889    end Remove_Homonym;
16890
16891    ------------------------------
16892    -- Remove_Overloaded_Entity --
16893    ------------------------------
16894
16895    procedure Remove_Overloaded_Entity (Id : Entity_Id) is
16896       procedure Remove_Primitive_Of (Typ : Entity_Id);
16897       --  Remove primitive subprogram Id from the list of primitives that
16898       --  belong to type Typ.
16899
16900       -------------------------
16901       -- Remove_Primitive_Of --
16902       -------------------------
16903
16904       procedure Remove_Primitive_Of (Typ : Entity_Id) is
16905          Prims : Elist_Id;
16906
16907       begin
16908          if Is_Tagged_Type (Typ) then
16909             Prims := Direct_Primitive_Operations (Typ);
16910
16911             if Present (Prims) then
16912                Remove (Prims, Id);
16913             end if;
16914          end if;
16915       end Remove_Primitive_Of;
16916
16917       --  Local variables
16918
16919       Scop    : constant Entity_Id := Scope (Id);
16920       Formal  : Entity_Id;
16921       Prev_Id : Entity_Id;
16922
16923    --  Start of processing for Remove_Overloaded_Entity
16924
16925    begin
16926       --  Remove the entity from the homonym chain. When the entity is the
16927       --  head of the chain, associate the entry in the name table with its
16928       --  homonym effectively making it the new head of the chain.
16929
16930       if Current_Entity (Id) = Id then
16931          Set_Name_Entity_Id (Chars (Id), Homonym (Id));
16932
16933       --  Otherwise link the previous and next homonyms
16934
16935       else
16936          Prev_Id := Current_Entity (Id);
16937          while Present (Prev_Id) and then Homonym (Prev_Id) /= Id loop
16938             Prev_Id := Homonym (Prev_Id);
16939          end loop;
16940
16941          Set_Homonym (Prev_Id, Homonym (Id));
16942       end if;
16943
16944       --  Remove the entity from the scope entity chain. When the entity is
16945       --  the head of the chain, set the next entity as the new head of the
16946       --  chain.
16947
16948       if First_Entity (Scop) = Id then
16949          Prev_Id := Empty;
16950          Set_First_Entity (Scop, Next_Entity (Id));
16951
16952       --  Otherwise the entity is either in the middle of the chain or it acts
16953       --  as its tail. Traverse and link the previous and next entities.
16954
16955       else
16956          Prev_Id := First_Entity (Scop);
16957          while Present (Prev_Id) and then Next_Entity (Prev_Id) /= Id loop
16958             Next_Entity (Prev_Id);
16959          end loop;
16960
16961          Set_Next_Entity (Prev_Id, Next_Entity (Id));
16962       end if;
16963
16964       --  Handle the case where the entity acts as the tail of the scope entity
16965       --  chain.
16966
16967       if Last_Entity (Scop) = Id then
16968          Set_Last_Entity (Scop, Prev_Id);
16969       end if;
16970
16971       --  The entity denotes a primitive subprogram. Remove it from the list of
16972       --  primitives of the associated controlling type.
16973
16974       if Ekind_In (Id, E_Function, E_Procedure) and then Is_Primitive (Id) then
16975          Formal := First_Formal (Id);
16976          while Present (Formal) loop
16977             if Is_Controlling_Formal (Formal) then
16978                Remove_Primitive_Of (Etype (Formal));
16979                exit;
16980             end if;
16981
16982             Next_Formal (Formal);
16983          end loop;
16984
16985          if Ekind (Id) = E_Function and then Has_Controlling_Result (Id) then
16986             Remove_Primitive_Of (Etype (Id));
16987          end if;
16988       end if;
16989    end Remove_Overloaded_Entity;
16990
16991    ---------------------
16992    -- Rep_To_Pos_Flag --
16993    ---------------------
16994
16995    function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
16996    begin
16997       return New_Occurrence_Of
16998                (Boolean_Literals (not Range_Checks_Suppressed (E)), Loc);
16999    end Rep_To_Pos_Flag;
17000
17001    -------------------------------
17002    -- Report_Unused_Body_States --
17003    -------------------------------
17004
17005    procedure Report_Unused_Body_States
17006      (Body_Id : Entity_Id;
17007       States  : Elist_Id)
17008    is
17009       Posted     : Boolean := False;
17010       State_Elmt : Elmt_Id;
17011       State_Id   : Entity_Id;
17012
17013    begin
17014       if Present (States) then
17015          State_Elmt := First_Elmt (States);
17016          while Present (State_Elmt) loop
17017             State_Id := Node (State_Elmt);
17018
17019             --  Constants are part of the hidden state of a package, but the
17020             --  compiler cannot determine whether they have variable input
17021             --  (SPARK RM 7.1.1(2)) and cannot classify them properly as a
17022             --  hidden state. Do not emit an error when a constant does not
17023             --  participate in a state refinement, even though it acts as a
17024             --  hidden state.
17025
17026             if Ekind (State_Id) = E_Constant then
17027                null;
17028
17029             --  Generate an error message of the form:
17030
17031             --    body of package ... has unused hidden states
17032             --      abstract state ... defined at ...
17033             --      variable ... defined at ...
17034
17035             else
17036                if not Posted then
17037                   Posted := True;
17038                   SPARK_Msg_N
17039                     ("body of package & has unused hidden states", Body_Id);
17040                end if;
17041
17042                Error_Msg_Sloc := Sloc (State_Id);
17043
17044                if Ekind (State_Id) = E_Abstract_State then
17045                   SPARK_Msg_NE
17046                     ("\abstract state & defined #", Body_Id, State_Id);
17047
17048                else
17049                   SPARK_Msg_NE ("\variable & defined #", Body_Id, State_Id);
17050                end if;
17051             end if;
17052
17053             Next_Elmt (State_Elmt);
17054          end loop;
17055       end if;
17056    end Report_Unused_Body_States;
17057
17058    --------------------
17059    -- Require_Entity --
17060    --------------------
17061
17062    procedure Require_Entity (N : Node_Id) is
17063    begin
17064       if Is_Entity_Name (N) and then No (Entity (N)) then
17065          if Total_Errors_Detected /= 0 then
17066             Set_Entity (N, Any_Id);
17067          else
17068             raise Program_Error;
17069          end if;
17070       end if;
17071    end Require_Entity;
17072
17073    -------------------------------
17074    -- Requires_State_Refinement --
17075    -------------------------------
17076
17077    function Requires_State_Refinement
17078      (Spec_Id : Entity_Id;
17079       Body_Id : Entity_Id) return Boolean
17080    is
17081       function Mode_Is_Off (Prag : Node_Id) return Boolean;
17082       --  Given pragma SPARK_Mode, determine whether the mode is Off
17083
17084       -----------------
17085       -- Mode_Is_Off --
17086       -----------------
17087
17088       function Mode_Is_Off (Prag : Node_Id) return Boolean is
17089          Mode : Node_Id;
17090
17091       begin
17092          --  The default SPARK mode is On
17093
17094          if No (Prag) then
17095             return False;
17096          end if;
17097
17098          Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
17099
17100          --  Then the pragma lacks an argument, the default mode is On
17101
17102          if No (Mode) then
17103             return False;
17104          else
17105             return Chars (Mode) = Name_Off;
17106          end if;
17107       end Mode_Is_Off;
17108
17109    --  Start of processing for Requires_State_Refinement
17110
17111    begin
17112       --  A package that does not define at least one abstract state cannot
17113       --  possibly require refinement.
17114
17115       if No (Abstract_States (Spec_Id)) then
17116          return False;
17117
17118       --  The package instroduces a single null state which does not merit
17119       --  refinement.
17120
17121       elsif Has_Null_Abstract_State (Spec_Id) then
17122          return False;
17123
17124       --  Check whether the package body is subject to pragma SPARK_Mode. If
17125       --  it is and the mode is Off, the package body is considered to be in
17126       --  regular Ada and does not require refinement.
17127
17128       elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then
17129          return False;
17130
17131       --  The body's SPARK_Mode may be inherited from a similar pragma that
17132       --  appears in the private declarations of the spec. The pragma we are
17133       --  interested appears as the second entry in SPARK_Pragma.
17134
17135       elsif Present (SPARK_Pragma (Spec_Id))
17136         and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id)))
17137       then
17138          return False;
17139
17140       --  The spec defines at least one abstract state and the body has no way
17141       --  of circumventing the refinement.
17142
17143       else
17144          return True;
17145       end if;
17146    end Requires_State_Refinement;
17147
17148    ------------------------------
17149    -- Requires_Transient_Scope --
17150    ------------------------------
17151
17152    --  A transient scope is required when variable-sized temporaries are
17153    --  allocated on the secondary stack, or when finalization actions must be
17154    --  generated before the next instruction.
17155
17156    function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
17157    function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
17158    --  ???We retain the old and new algorithms for Requires_Transient_Scope for
17159    --  the time being. New_Requires_Transient_Scope is used by default; the
17160    --  debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
17161    --  instead. The intent is to use this temporarily to measure before/after
17162    --  efficiency. Note: when this temporary code is removed, the documentation
17163    --  of dQ in debug.adb should be removed.
17164
17165    procedure Results_Differ (Id : Entity_Id);
17166    --  ???Debugging code. Called when the Old_ and New_ results differ. Will be
17167    --  removed when New_Requires_Transient_Scope becomes
17168    --  Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated.
17169
17170    procedure Results_Differ (Id : Entity_Id) is
17171    begin
17172       if False then -- False to disable; True for debugging
17173          Treepr.Print_Tree_Node (Id);
17174
17175          if Old_Requires_Transient_Scope (Id) =
17176            New_Requires_Transient_Scope (Id)
17177          then
17178             raise Program_Error;
17179          end if;
17180       end if;
17181    end Results_Differ;
17182
17183    function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
17184       Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
17185
17186    begin
17187       if Debug_Flag_QQ then
17188          return Old_Result;
17189       end if;
17190
17191       declare
17192          New_Result : constant Boolean := New_Requires_Transient_Scope (Id);
17193
17194       begin
17195          --  Assert that we're not putting things on the secondary stack if we
17196          --  didn't before; we are trying to AVOID secondary stack when
17197          --  possible.
17198
17199          if not Old_Result then
17200             pragma Assert (not New_Result);
17201             null;
17202          end if;
17203
17204          if New_Result /= Old_Result then
17205             Results_Differ (Id);
17206          end if;
17207
17208          return New_Result;
17209       end;
17210    end Requires_Transient_Scope;
17211
17212    ----------------------------------
17213    -- Old_Requires_Transient_Scope --
17214    ----------------------------------
17215
17216    function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
17217       Typ : constant Entity_Id := Underlying_Type (Id);
17218
17219    begin
17220       --  This is a private type which is not completed yet. This can only
17221       --  happen in a default expression (of a formal parameter or of a
17222       --  record component). Do not expand transient scope in this case.
17223
17224       if No (Typ) then
17225          return False;
17226
17227       --  Do not expand transient scope for non-existent procedure return
17228
17229       elsif Typ = Standard_Void_Type then
17230          return False;
17231
17232       --  Elementary types do not require a transient scope
17233
17234       elsif Is_Elementary_Type (Typ) then
17235          return False;
17236
17237       --  Generally, indefinite subtypes require a transient scope, since the
17238       --  back end cannot generate temporaries, since this is not a valid type
17239       --  for declaring an object. It might be possible to relax this in the
17240       --  future, e.g. by declaring the maximum possible space for the type.
17241
17242       elsif not Is_Definite_Subtype (Typ) then
17243          return True;
17244
17245       --  Functions returning tagged types may dispatch on result so their
17246       --  returned value is allocated on the secondary stack. Controlled
17247       --  type temporaries need finalization.
17248
17249       elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
17250          return True;
17251
17252       --  Record type
17253
17254       elsif Is_Record_Type (Typ) then
17255          declare
17256             Comp : Entity_Id;
17257
17258          begin
17259             Comp := First_Entity (Typ);
17260             while Present (Comp) loop
17261                if Ekind (Comp) = E_Component then
17262
17263                   --  ???It's not clear we need a full recursive call to
17264                   --  Old_Requires_Transient_Scope here. Note that the
17265                   --  following can't happen.
17266
17267                   pragma Assert (Is_Definite_Subtype (Etype (Comp)));
17268                   pragma Assert (not Has_Controlled_Component (Etype (Comp)));
17269
17270                   if Old_Requires_Transient_Scope (Etype (Comp)) then
17271                      return True;
17272                   end if;
17273                end if;
17274
17275                Next_Entity (Comp);
17276             end loop;
17277          end;
17278
17279          return False;
17280
17281       --  String literal types never require transient scope
17282
17283       elsif Ekind (Typ) = E_String_Literal_Subtype then
17284          return False;
17285
17286       --  Array type. Note that we already know that this is a constrained
17287       --  array, since unconstrained arrays will fail the indefinite test.
17288
17289       elsif Is_Array_Type (Typ) then
17290
17291          --  If component type requires a transient scope, the array does too
17292
17293          if Old_Requires_Transient_Scope (Component_Type (Typ)) then
17294             return True;
17295
17296          --  Otherwise, we only need a transient scope if the size depends on
17297          --  the value of one or more discriminants.
17298
17299          else
17300             return Size_Depends_On_Discriminant (Typ);
17301          end if;
17302
17303       --  All other cases do not require a transient scope
17304
17305       else
17306          pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
17307          return False;
17308       end if;
17309    end Old_Requires_Transient_Scope;
17310
17311    ----------------------------------
17312    -- New_Requires_Transient_Scope --
17313    ----------------------------------
17314
17315    function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
17316
17317       function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
17318       --  This is called for untagged records and protected types, with
17319       --  nondefaulted discriminants. Returns True if the size of function
17320       --  results is known at the call site, False otherwise. Returns False
17321       --  if there is a variant part that depends on the discriminants of
17322       --  this type, or if there is an array constrained by the discriminants
17323       --  of this type. ???Currently, this is overly conservative (the array
17324       --  could be nested inside some other record that is constrained by
17325       --  nondiscriminants). That is, the recursive calls are too conservative.
17326
17327       function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
17328       --  Returns True if Typ is a nonlimited record with defaulted
17329       --  discriminants whose max size makes it unsuitable for allocating on
17330       --  the primary stack.
17331
17332       ------------------------------
17333       -- Caller_Known_Size_Record --
17334       ------------------------------
17335
17336       function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
17337          pragma Assert (Typ = Underlying_Type (Typ));
17338
17339       begin
17340          if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
17341             return False;
17342          end if;
17343
17344          declare
17345             Comp : Entity_Id;
17346
17347          begin
17348             Comp := First_Entity (Typ);
17349             while Present (Comp) loop
17350
17351                --  Only look at E_Component entities. No need to look at
17352                --  E_Discriminant entities, and we must ignore internal
17353                --  subtypes generated for constrained components.
17354
17355                if Ekind (Comp) = E_Component then
17356                   declare
17357                      Comp_Type : constant Entity_Id :=
17358                                    Underlying_Type (Etype (Comp));
17359
17360                   begin
17361                      if Is_Record_Type (Comp_Type)
17362                            or else
17363                         Is_Protected_Type (Comp_Type)
17364                      then
17365                         if not Caller_Known_Size_Record (Comp_Type) then
17366                            return False;
17367                         end if;
17368
17369                      elsif Is_Array_Type (Comp_Type) then
17370                         if Size_Depends_On_Discriminant (Comp_Type) then
17371                            return False;
17372                         end if;
17373                      end if;
17374                   end;
17375                end if;
17376
17377                Next_Entity (Comp);
17378             end loop;
17379          end;
17380
17381          return True;
17382       end Caller_Known_Size_Record;
17383
17384       ------------------------------
17385       -- Large_Max_Size_Mutable --
17386       ------------------------------
17387
17388       function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
17389          pragma Assert (Typ = Underlying_Type (Typ));
17390
17391          function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
17392          --  Returns true if the discrete type T has a large range
17393
17394          ----------------------------
17395          -- Is_Large_Discrete_Type --
17396          ----------------------------
17397
17398          function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
17399             Threshold : constant Int := 16;
17400             --  Arbitrary threshold above which we consider it "large". We want
17401             --  a fairly large threshold, because these large types really
17402             --  shouldn't have default discriminants in the first place, in
17403             --  most cases.
17404
17405          begin
17406             return UI_To_Int (RM_Size (T)) > Threshold;
17407          end Is_Large_Discrete_Type;
17408
17409       begin
17410          if Is_Record_Type (Typ)
17411            and then not Is_Limited_View (Typ)
17412            and then Has_Defaulted_Discriminants (Typ)
17413          then
17414             --  Loop through the components, looking for an array whose upper
17415             --  bound(s) depends on discriminants, where both the subtype of
17416             --  the discriminant and the index subtype are too large.
17417
17418             declare
17419                Comp : Entity_Id;
17420
17421             begin
17422                Comp := First_Entity (Typ);
17423                while Present (Comp) loop
17424                   if Ekind (Comp) = E_Component then
17425                      declare
17426                         Comp_Type : constant Entity_Id :=
17427                                       Underlying_Type (Etype (Comp));
17428                         Indx : Node_Id;
17429                         Ityp : Entity_Id;
17430                         Hi   : Node_Id;
17431
17432                      begin
17433                         if Is_Array_Type (Comp_Type) then
17434                            Indx := First_Index (Comp_Type);
17435
17436                            while Present (Indx) loop
17437                               Ityp := Etype (Indx);
17438                               Hi := Type_High_Bound (Ityp);
17439
17440                               if Nkind (Hi) = N_Identifier
17441                                 and then Ekind (Entity (Hi)) = E_Discriminant
17442                                 and then Is_Large_Discrete_Type (Ityp)
17443                                 and then Is_Large_Discrete_Type
17444                                            (Etype (Entity (Hi)))
17445                               then
17446                                  return True;
17447                               end if;
17448
17449                               Next_Index (Indx);
17450                            end loop;
17451                         end if;
17452                      end;
17453                   end if;
17454
17455                   Next_Entity (Comp);
17456                end loop;
17457             end;
17458          end if;
17459
17460          return False;
17461       end Large_Max_Size_Mutable;
17462
17463       --  Local declarations
17464
17465       Typ : constant Entity_Id := Underlying_Type (Id);
17466
17467    --  Start of processing for New_Requires_Transient_Scope
17468
17469    begin
17470       --  This is a private type which is not completed yet. This can only
17471       --  happen in a default expression (of a formal parameter or of a
17472       --  record component). Do not expand transient scope in this case.
17473
17474       if No (Typ) then
17475          return False;
17476
17477       --  Do not expand transient scope for non-existent procedure return or
17478       --  string literal types.
17479
17480       elsif Typ = Standard_Void_Type
17481         or else Ekind (Typ) = E_String_Literal_Subtype
17482       then
17483          return False;
17484
17485       --  If Typ is a generic formal incomplete type, then we want to look at
17486       --  the actual type.
17487
17488       elsif Ekind (Typ) = E_Record_Subtype
17489         and then Present (Cloned_Subtype (Typ))
17490       then
17491          return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
17492
17493       --  Functions returning specific tagged types may dispatch on result, so
17494       --  their returned value is allocated on the secondary stack, even in the
17495       --  definite case. We must treat nondispatching functions the same way,
17496       --  because access-to-function types can point at both, so the calling
17497       --  conventions must be compatible. Is_Tagged_Type includes controlled
17498       --  types and class-wide types. Controlled type temporaries need
17499       --  finalization.
17500
17501       --  ???It's not clear why we need to return noncontrolled types with
17502       --  controlled components on the secondary stack.
17503
17504       elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
17505          return True;
17506
17507       --  Untagged definite subtypes are known size. This includes all
17508       --  elementary [sub]types. Tasks are known size even if they have
17509       --  discriminants. So we return False here, with one exception:
17510       --  For a type like:
17511       --    type T (Last : Natural := 0) is
17512       --       X : String (1 .. Last);
17513       --    end record;
17514       --  we return True. That's because for "P(F(...));", where F returns T,
17515       --  we don't know the size of the result at the call site, so if we
17516       --  allocated it on the primary stack, we would have to allocate the
17517       --  maximum size, which is way too big.
17518
17519       elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
17520          return Large_Max_Size_Mutable (Typ);
17521
17522       --  Indefinite (discriminated) untagged record or protected type
17523
17524       elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
17525          return not Caller_Known_Size_Record (Typ);
17526
17527       --  Unconstrained array
17528
17529       else
17530          pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
17531          return True;
17532       end if;
17533    end New_Requires_Transient_Scope;
17534
17535    --------------------------
17536    -- Reset_Analyzed_Flags --
17537    --------------------------
17538
17539    procedure Reset_Analyzed_Flags (N : Node_Id) is
17540
17541       function Clear_Analyzed (N : Node_Id) return Traverse_Result;
17542       --  Function used to reset Analyzed flags in tree. Note that we do
17543       --  not reset Analyzed flags in entities, since there is no need to
17544       --  reanalyze entities, and indeed, it is wrong to do so, since it
17545       --  can result in generating auxiliary stuff more than once.
17546
17547       --------------------
17548       -- Clear_Analyzed --
17549       --------------------
17550
17551       function Clear_Analyzed (N : Node_Id) return Traverse_Result is
17552       begin
17553          if not Has_Extension (N) then
17554             Set_Analyzed (N, False);
17555          end if;
17556
17557          return OK;
17558       end Clear_Analyzed;
17559
17560       procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed);
17561
17562    --  Start of processing for Reset_Analyzed_Flags
17563
17564    begin
17565       Reset_Analyzed (N);
17566    end Reset_Analyzed_Flags;
17567
17568    ------------------------
17569    -- Restore_SPARK_Mode --
17570    ------------------------
17571
17572    procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type) is
17573    begin
17574       SPARK_Mode := Mode;
17575    end Restore_SPARK_Mode;
17576
17577    --------------------------------
17578    -- Returns_Unconstrained_Type --
17579    --------------------------------
17580
17581    function Returns_Unconstrained_Type (Subp : Entity_Id) return Boolean is
17582    begin
17583       return Ekind (Subp) = E_Function
17584         and then not Is_Scalar_Type (Etype (Subp))
17585         and then not Is_Access_Type (Etype (Subp))
17586         and then not Is_Constrained (Etype (Subp));
17587    end Returns_Unconstrained_Type;
17588
17589    ----------------------------
17590    -- Root_Type_Of_Full_View --
17591    ----------------------------
17592
17593    function Root_Type_Of_Full_View (T : Entity_Id) return Entity_Id is
17594       Rtyp : constant Entity_Id := Root_Type (T);
17595
17596    begin
17597       --  The root type of the full view may itself be a private type. Keep
17598       --  looking for the ultimate derivation parent.
17599
17600       if Is_Private_Type (Rtyp) and then Present (Full_View (Rtyp)) then
17601          return Root_Type_Of_Full_View (Full_View (Rtyp));
17602       else
17603          return Rtyp;
17604       end if;
17605    end Root_Type_Of_Full_View;
17606
17607    ---------------------------
17608    -- Safe_To_Capture_Value --
17609    ---------------------------
17610
17611    function Safe_To_Capture_Value
17612      (N    : Node_Id;
17613       Ent  : Entity_Id;
17614       Cond : Boolean := False) return Boolean
17615    is
17616    begin
17617       --  The only entities for which we track constant values are variables
17618       --  which are not renamings, constants, out parameters, and in out
17619       --  parameters, so check if we have this case.
17620
17621       --  Note: it may seem odd to track constant values for constants, but in
17622       --  fact this routine is used for other purposes than simply capturing
17623       --  the value. In particular, the setting of Known[_Non]_Null.
17624
17625       if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent)))
17626             or else
17627           Ekind_In (Ent, E_Constant, E_Out_Parameter, E_In_Out_Parameter)
17628       then
17629          null;
17630
17631       --  For conditionals, we also allow loop parameters and all formals,
17632       --  including in parameters.
17633
17634       elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then
17635          null;
17636
17637       --  For all other cases, not just unsafe, but impossible to capture
17638       --  Current_Value, since the above are the only entities which have
17639       --  Current_Value fields.
17640
17641       else
17642          return False;
17643       end if;
17644
17645       --  Skip if volatile or aliased, since funny things might be going on in
17646       --  these cases which we cannot necessarily track. Also skip any variable
17647       --  for which an address clause is given, or whose address is taken. Also
17648       --  never capture value of library level variables (an attempt to do so
17649       --  can occur in the case of package elaboration code).
17650
17651       if Treat_As_Volatile (Ent)
17652         or else Is_Aliased (Ent)
17653         or else Present (Address_Clause (Ent))
17654         or else Address_Taken (Ent)
17655         or else (Is_Library_Level_Entity (Ent)
17656                   and then Ekind (Ent) = E_Variable)
17657       then
17658          return False;
17659       end if;
17660
17661       --  OK, all above conditions are met. We also require that the scope of
17662       --  the reference be the same as the scope of the entity, not counting
17663       --  packages and blocks and loops.
17664
17665       declare
17666          E_Scope : constant Entity_Id := Scope (Ent);
17667          R_Scope : Entity_Id;
17668
17669       begin
17670          R_Scope := Current_Scope;
17671          while R_Scope /= Standard_Standard loop
17672             exit when R_Scope = E_Scope;
17673
17674             if not Ekind_In (R_Scope, E_Package, E_Block, E_Loop) then
17675                return False;
17676             else
17677                R_Scope := Scope (R_Scope);
17678             end if;
17679          end loop;
17680       end;
17681
17682       --  We also require that the reference does not appear in a context
17683       --  where it is not sure to be executed (i.e. a conditional context
17684       --  or an exception handler). We skip this if Cond is True, since the
17685       --  capturing of values from conditional tests handles this ok.
17686
17687       if Cond then
17688          return True;
17689       end if;
17690
17691       declare
17692          Desc : Node_Id;
17693          P    : Node_Id;
17694
17695       begin
17696          Desc := N;
17697
17698          --  Seems dubious that case expressions are not handled here ???
17699
17700          P := Parent (N);
17701          while Present (P) loop
17702             if         Nkind (P) = N_If_Statement
17703               or else  Nkind (P) = N_Case_Statement
17704               or else (Nkind (P) in N_Short_Circuit
17705                         and then Desc = Right_Opnd (P))
17706               or else (Nkind (P) = N_If_Expression
17707                         and then Desc /= First (Expressions (P)))
17708               or else  Nkind (P) = N_Exception_Handler
17709               or else  Nkind (P) = N_Selective_Accept
17710               or else  Nkind (P) = N_Conditional_Entry_Call
17711               or else  Nkind (P) = N_Timed_Entry_Call
17712               or else  Nkind (P) = N_Asynchronous_Select
17713             then
17714                return False;
17715
17716             else
17717                Desc := P;
17718                P := Parent (P);
17719
17720                --  A special Ada 2012 case: the original node may be part
17721                --  of the else_actions of a conditional expression, in which
17722                --  case it might not have been expanded yet, and appears in
17723                --  a non-syntactic list of actions. In that case it is clearly
17724                --  not safe to save a value.
17725
17726                if No (P)
17727                  and then Is_List_Member (Desc)
17728                  and then No (Parent (List_Containing (Desc)))
17729                then
17730                   return False;
17731                end if;
17732             end if;
17733          end loop;
17734       end;
17735
17736       --  OK, looks safe to set value
17737
17738       return True;
17739    end Safe_To_Capture_Value;
17740
17741    ---------------
17742    -- Same_Name --
17743    ---------------
17744
17745    function Same_Name (N1, N2 : Node_Id) return Boolean is
17746       K1 : constant Node_Kind := Nkind (N1);
17747       K2 : constant Node_Kind := Nkind (N2);
17748
17749    begin
17750       if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
17751         and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
17752       then
17753          return Chars (N1) = Chars (N2);
17754
17755       elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
17756         and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
17757       then
17758          return Same_Name (Selector_Name (N1), Selector_Name (N2))
17759            and then Same_Name (Prefix (N1), Prefix (N2));
17760
17761       else
17762          return False;
17763       end if;
17764    end Same_Name;
17765
17766    -----------------
17767    -- Same_Object --
17768    -----------------
17769
17770    function Same_Object (Node1, Node2 : Node_Id) return Boolean is
17771       N1 : constant Node_Id := Original_Node (Node1);
17772       N2 : constant Node_Id := Original_Node (Node2);
17773       --  We do the tests on original nodes, since we are most interested
17774       --  in the original source, not any expansion that got in the way.
17775
17776       K1 : constant Node_Kind := Nkind (N1);
17777       K2 : constant Node_Kind := Nkind (N2);
17778
17779    begin
17780       --  First case, both are entities with same entity
17781
17782       if K1 in N_Has_Entity and then K2 in N_Has_Entity then
17783          declare
17784             EN1 : constant Entity_Id := Entity (N1);
17785             EN2 : constant Entity_Id := Entity (N2);
17786          begin
17787             if Present (EN1) and then Present (EN2)
17788               and then (Ekind_In (EN1, E_Variable, E_Constant)
17789                          or else Is_Formal (EN1))
17790               and then EN1 = EN2
17791             then
17792                return True;
17793             end if;
17794          end;
17795       end if;
17796
17797       --  Second case, selected component with same selector, same record
17798
17799       if K1 = N_Selected_Component
17800         and then K2 = N_Selected_Component
17801         and then Chars (Selector_Name (N1)) = Chars (Selector_Name (N2))
17802       then
17803          return Same_Object (Prefix (N1), Prefix (N2));
17804
17805       --  Third case, indexed component with same subscripts, same array
17806
17807       elsif K1 = N_Indexed_Component
17808         and then K2 = N_Indexed_Component
17809         and then Same_Object (Prefix (N1), Prefix (N2))
17810       then
17811          declare
17812             E1, E2 : Node_Id;
17813          begin
17814             E1 := First (Expressions (N1));
17815             E2 := First (Expressions (N2));
17816             while Present (E1) loop
17817                if not Same_Value (E1, E2) then
17818                   return False;
17819                else
17820                   Next (E1);
17821                   Next (E2);
17822                end if;
17823             end loop;
17824
17825             return True;
17826          end;
17827
17828       --  Fourth case, slice of same array with same bounds
17829
17830       elsif K1 = N_Slice
17831         and then K2 = N_Slice
17832         and then Nkind (Discrete_Range (N1)) = N_Range
17833         and then Nkind (Discrete_Range (N2)) = N_Range
17834         and then Same_Value (Low_Bound (Discrete_Range (N1)),
17835                              Low_Bound (Discrete_Range (N2)))
17836         and then Same_Value (High_Bound (Discrete_Range (N1)),
17837                              High_Bound (Discrete_Range (N2)))
17838       then
17839          return Same_Name (Prefix (N1), Prefix (N2));
17840
17841       --  All other cases, not clearly the same object
17842
17843       else
17844          return False;
17845       end if;
17846    end Same_Object;
17847
17848    ---------------
17849    -- Same_Type --
17850    ---------------
17851
17852    function Same_Type (T1, T2 : Entity_Id) return Boolean is
17853    begin
17854       if T1 = T2 then
17855          return True;
17856
17857       elsif not Is_Constrained (T1)
17858         and then not Is_Constrained (T2)
17859         and then Base_Type (T1) = Base_Type (T2)
17860       then
17861          return True;
17862
17863       --  For now don't bother with case of identical constraints, to be
17864       --  fiddled with later on perhaps (this is only used for optimization
17865       --  purposes, so it is not critical to do a best possible job)
17866
17867       else
17868          return False;
17869       end if;
17870    end Same_Type;
17871
17872    ----------------
17873    -- Same_Value --
17874    ----------------
17875
17876    function Same_Value (Node1, Node2 : Node_Id) return Boolean is
17877    begin
17878       if Compile_Time_Known_Value (Node1)
17879         and then Compile_Time_Known_Value (Node2)
17880         and then Expr_Value (Node1) = Expr_Value (Node2)
17881       then
17882          return True;
17883       elsif Same_Object (Node1, Node2) then
17884          return True;
17885       else
17886          return False;
17887       end if;
17888    end Same_Value;
17889
17890    -----------------------------
17891    -- Save_SPARK_Mode_And_Set --
17892    -----------------------------
17893
17894    procedure Save_SPARK_Mode_And_Set
17895      (Context : Entity_Id;
17896       Mode    : out SPARK_Mode_Type)
17897    is
17898    begin
17899       --  Save the current mode in effect
17900
17901       Mode := SPARK_Mode;
17902
17903       --  Do not consider illegal or partially decorated constructs
17904
17905       if Ekind (Context) = E_Void or else Error_Posted (Context) then
17906          null;
17907
17908       elsif Present (SPARK_Pragma (Context)) then
17909          SPARK_Mode := Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Context));
17910       end if;
17911    end Save_SPARK_Mode_And_Set;
17912
17913    -------------------------
17914    -- Scalar_Part_Present --
17915    -------------------------
17916
17917    function Scalar_Part_Present (T : Entity_Id) return Boolean is
17918       C : Entity_Id;
17919
17920    begin
17921       if Is_Scalar_Type (T) then
17922          return True;
17923
17924       elsif Is_Array_Type (T) then
17925          return Scalar_Part_Present (Component_Type (T));
17926
17927       elsif Is_Record_Type (T) or else Has_Discriminants (T) then
17928          C := First_Component_Or_Discriminant (T);
17929          while Present (C) loop
17930             if Scalar_Part_Present (Etype (C)) then
17931                return True;
17932             else
17933                Next_Component_Or_Discriminant (C);
17934             end if;
17935          end loop;
17936       end if;
17937
17938       return False;
17939    end Scalar_Part_Present;
17940
17941    ------------------------
17942    -- Scope_Is_Transient --
17943    ------------------------
17944
17945    function Scope_Is_Transient return Boolean is
17946    begin
17947       return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
17948    end Scope_Is_Transient;
17949
17950    ------------------
17951    -- Scope_Within --
17952    ------------------
17953
17954    function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
17955       Scop : Entity_Id;
17956
17957    begin
17958       Scop := Scope1;
17959       while Scop /= Standard_Standard loop
17960          Scop := Scope (Scop);
17961
17962          if Scop = Scope2 then
17963             return True;
17964          end if;
17965       end loop;
17966
17967       return False;
17968    end Scope_Within;
17969
17970    --------------------------
17971    -- Scope_Within_Or_Same --
17972    --------------------------
17973
17974    function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
17975       Scop : Entity_Id;
17976
17977    begin
17978       Scop := Scope1;
17979       while Scop /= Standard_Standard loop
17980          if Scop = Scope2 then
17981             return True;
17982          else
17983             Scop := Scope (Scop);
17984          end if;
17985       end loop;
17986
17987       return False;
17988    end Scope_Within_Or_Same;
17989
17990    --------------------
17991    -- Set_Convention --
17992    --------------------
17993
17994    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
17995    begin
17996       Basic_Set_Convention (E, Val);
17997
17998       if Is_Type (E)
17999         and then Is_Access_Subprogram_Type (Base_Type (E))
18000         and then Has_Foreign_Convention (E)
18001       then
18002
18003          --  A pragma Convention in an instance may apply to the subtype
18004          --  created for a formal, in which case we have already verified
18005          --  that conventions of actual and formal match and there is nothing
18006          --  to flag on the subtype.
18007
18008          if In_Instance then
18009             null;
18010          else
18011             Set_Can_Use_Internal_Rep (E, False);
18012          end if;
18013       end if;
18014
18015       --  If E is an object or component, and the type of E is an anonymous
18016       --  access type with no convention set, then also set the convention of
18017       --  the anonymous access type. We do not do this for anonymous protected
18018       --  types, since protected types always have the default convention.
18019
18020       if Present (Etype (E))
18021         and then (Is_Object (E)
18022                    or else Ekind (E) = E_Component
18023
18024                    --  Allow E_Void (happens for pragma Convention appearing
18025                    --  in the middle of a record applying to a component)
18026
18027                    or else Ekind (E) = E_Void)
18028       then
18029          declare
18030             Typ : constant Entity_Id := Etype (E);
18031
18032          begin
18033             if Ekind_In (Typ, E_Anonymous_Access_Type,
18034                               E_Anonymous_Access_Subprogram_Type)
18035               and then not Has_Convention_Pragma (Typ)
18036             then
18037                Basic_Set_Convention (Typ, Val);
18038                Set_Has_Convention_Pragma (Typ);
18039
18040                --  And for the access subprogram type, deal similarly with the
18041                --  designated E_Subprogram_Type if it is also internal (which
18042                --  it always is?)
18043
18044                if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
18045                   declare
18046                      Dtype : constant Entity_Id := Designated_Type (Typ);
18047                   begin
18048                      if Ekind (Dtype) = E_Subprogram_Type
18049                        and then Is_Itype (Dtype)
18050                        and then not Has_Convention_Pragma (Dtype)
18051                      then
18052                         Basic_Set_Convention (Dtype, Val);
18053                         Set_Has_Convention_Pragma (Dtype);
18054                      end if;
18055                   end;
18056                end if;
18057             end if;
18058          end;
18059       end if;
18060    end Set_Convention;
18061
18062    ------------------------
18063    -- Set_Current_Entity --
18064    ------------------------
18065
18066    --  The given entity is to be set as the currently visible definition of its
18067    --  associated name (i.e. the Node_Id associated with its name). All we have
18068    --  to do is to get the name from the identifier, and then set the
18069    --  associated Node_Id to point to the given entity.
18070
18071    procedure Set_Current_Entity (E : Entity_Id) is
18072    begin
18073       Set_Name_Entity_Id (Chars (E), E);
18074    end Set_Current_Entity;
18075
18076    ---------------------------
18077    -- Set_Debug_Info_Needed --
18078    ---------------------------
18079
18080    procedure Set_Debug_Info_Needed (T : Entity_Id) is
18081
18082       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id);
18083       pragma Inline (Set_Debug_Info_Needed_If_Not_Set);
18084       --  Used to set debug info in a related node if not set already
18085
18086       --------------------------------------
18087       -- Set_Debug_Info_Needed_If_Not_Set --
18088       --------------------------------------
18089
18090       procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is
18091       begin
18092          if Present (E) and then not Needs_Debug_Info (E) then
18093             Set_Debug_Info_Needed (E);
18094
18095             --  For a private type, indicate that the full view also needs
18096             --  debug information.
18097
18098             if Is_Type (E)
18099               and then Is_Private_Type (E)
18100               and then Present (Full_View (E))
18101             then
18102                Set_Debug_Info_Needed (Full_View (E));
18103             end if;
18104          end if;
18105       end Set_Debug_Info_Needed_If_Not_Set;
18106
18107    --  Start of processing for Set_Debug_Info_Needed
18108
18109    begin
18110       --  Nothing to do if argument is Empty or has Debug_Info_Off set, which
18111       --  indicates that Debug_Info_Needed is never required for the entity.
18112       --  Nothing to do if entity comes from a predefined file. Library files
18113       --  are compiled without debug information, but inlined bodies of these
18114       --  routines may appear in user code, and debug information on them ends
18115       --  up complicating debugging the user code.
18116
18117       if No (T)
18118         or else Debug_Info_Off (T)
18119       then
18120          return;
18121
18122       elsif In_Inlined_Body
18123         and then Is_Predefined_File_Name
18124            (Unit_File_Name (Get_Source_Unit (Sloc (T))))
18125       then
18126          Set_Needs_Debug_Info (T, False);
18127       end if;
18128
18129       --  Set flag in entity itself. Note that we will go through the following
18130       --  circuitry even if the flag is already set on T. That's intentional,
18131       --  it makes sure that the flag will be set in subsidiary entities.
18132
18133       Set_Needs_Debug_Info (T);
18134
18135       --  Set flag on subsidiary entities if not set already
18136
18137       if Is_Object (T) then
18138          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
18139
18140       elsif Is_Type (T) then
18141          Set_Debug_Info_Needed_If_Not_Set (Etype (T));
18142
18143          if Is_Record_Type (T) then
18144             declare
18145                Ent : Entity_Id := First_Entity (T);
18146             begin
18147                while Present (Ent) loop
18148                   Set_Debug_Info_Needed_If_Not_Set (Ent);
18149                   Next_Entity (Ent);
18150                end loop;
18151             end;
18152
18153             --  For a class wide subtype, we also need debug information
18154             --  for the equivalent type.
18155
18156             if Ekind (T) = E_Class_Wide_Subtype then
18157                Set_Debug_Info_Needed_If_Not_Set (Equivalent_Type (T));
18158             end if;
18159
18160          elsif Is_Array_Type (T) then
18161             Set_Debug_Info_Needed_If_Not_Set (Component_Type (T));
18162
18163             declare
18164                Indx : Node_Id := First_Index (T);
18165             begin
18166                while Present (Indx) loop
18167                   Set_Debug_Info_Needed_If_Not_Set (Etype (Indx));
18168                   Indx := Next_Index (Indx);
18169                end loop;
18170             end;
18171
18172             --  For a packed array type, we also need debug information for
18173             --  the type used to represent the packed array. Conversely, we
18174             --  also need it for the former if we need it for the latter.
18175
18176             if Is_Packed (T) then
18177                Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Impl_Type (T));
18178             end if;
18179
18180             if Is_Packed_Array_Impl_Type (T) then
18181                Set_Debug_Info_Needed_If_Not_Set (Original_Array_Type (T));
18182             end if;
18183
18184          elsif Is_Access_Type (T) then
18185             Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T));
18186
18187          elsif Is_Private_Type (T) then
18188             declare
18189                FV : constant Entity_Id := Full_View (T);
18190
18191             begin
18192                Set_Debug_Info_Needed_If_Not_Set (FV);
18193
18194                --  If the full view is itself a derived private type, we need
18195                --  debug information on its underlying type.
18196
18197                if Present (FV)
18198                  and then Is_Private_Type (FV)
18199                  and then Present (Underlying_Full_View (FV))
18200                then
18201                   Set_Needs_Debug_Info (Underlying_Full_View (FV));
18202                end if;
18203             end;
18204
18205          elsif Is_Protected_Type (T) then
18206             Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T));
18207
18208          elsif Is_Scalar_Type (T) then
18209
18210             --  If the subrange bounds are materialized by dedicated constant
18211             --  objects, also include them in the debug info to make sure the
18212             --  debugger can properly use them.
18213
18214             if Present (Scalar_Range (T))
18215               and then Nkind (Scalar_Range (T)) = N_Range
18216             then
18217                declare
18218                   Low_Bnd  : constant Node_Id := Type_Low_Bound (T);
18219                   High_Bnd : constant Node_Id := Type_High_Bound (T);
18220
18221                begin
18222                   if Is_Entity_Name (Low_Bnd) then
18223                      Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd));
18224                   end if;
18225
18226                   if Is_Entity_Name (High_Bnd) then
18227                      Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd));
18228                   end if;
18229                end;
18230             end if;
18231          end if;
18232       end if;
18233    end Set_Debug_Info_Needed;
18234
18235    ----------------------------
18236    -- Set_Entity_With_Checks --
18237    ----------------------------
18238
18239    procedure Set_Entity_With_Checks (N : Node_Id; Val : Entity_Id) is
18240       Val_Actual : Entity_Id;
18241       Nod        : Node_Id;
18242       Post_Node  : Node_Id;
18243
18244    begin
18245       --  Unconditionally set the entity
18246
18247       Set_Entity (N, Val);
18248
18249       --  The node to post on is the selector in the case of an expanded name,
18250       --  and otherwise the node itself.
18251
18252       if Nkind (N) = N_Expanded_Name then
18253          Post_Node := Selector_Name (N);
18254       else
18255          Post_Node := N;
18256       end if;
18257
18258       --  Check for violation of No_Fixed_IO
18259
18260       if Restriction_Check_Required (No_Fixed_IO)
18261         and then
18262           ((RTU_Loaded (Ada_Text_IO)
18263              and then (Is_RTE (Val, RE_Decimal_IO)
18264                          or else
18265                        Is_RTE (Val, RE_Fixed_IO)))
18266
18267          or else
18268            (RTU_Loaded (Ada_Wide_Text_IO)
18269              and then (Is_RTE (Val, RO_WT_Decimal_IO)
18270                          or else
18271                        Is_RTE (Val, RO_WT_Fixed_IO)))
18272
18273          or else
18274            (RTU_Loaded (Ada_Wide_Wide_Text_IO)
18275              and then (Is_RTE (Val, RO_WW_Decimal_IO)
18276                          or else
18277                        Is_RTE (Val, RO_WW_Fixed_IO))))
18278
18279         --  A special extra check, don't complain about a reference from within
18280         --  the Ada.Interrupts package itself!
18281
18282         and then not In_Same_Extended_Unit (N, Val)
18283       then
18284          Check_Restriction (No_Fixed_IO, Post_Node);
18285       end if;
18286
18287       --  Remaining checks are only done on source nodes. Note that we test
18288       --  for violation of No_Fixed_IO even on non-source nodes, because the
18289       --  cases for checking violations of this restriction are instantiations
18290       --  where the reference in the instance has Comes_From_Source False.
18291
18292       if not Comes_From_Source (N) then
18293          return;
18294       end if;
18295
18296       --  Check for violation of No_Abort_Statements, which is triggered by
18297       --  call to Ada.Task_Identification.Abort_Task.
18298
18299       if Restriction_Check_Required (No_Abort_Statements)
18300         and then (Is_RTE (Val, RE_Abort_Task))
18301
18302         --  A special extra check, don't complain about a reference from within
18303         --  the Ada.Task_Identification package itself!
18304
18305         and then not In_Same_Extended_Unit (N, Val)
18306       then
18307          Check_Restriction (No_Abort_Statements, Post_Node);
18308       end if;
18309
18310       if Val = Standard_Long_Long_Integer then
18311          Check_Restriction (No_Long_Long_Integers, Post_Node);
18312       end if;
18313
18314       --  Check for violation of No_Dynamic_Attachment
18315
18316       if Restriction_Check_Required (No_Dynamic_Attachment)
18317         and then RTU_Loaded (Ada_Interrupts)
18318         and then (Is_RTE (Val, RE_Is_Reserved)      or else
18319                   Is_RTE (Val, RE_Is_Attached)      or else
18320                   Is_RTE (Val, RE_Current_Handler)  or else
18321                   Is_RTE (Val, RE_Attach_Handler)   or else
18322                   Is_RTE (Val, RE_Exchange_Handler) or else
18323                   Is_RTE (Val, RE_Detach_Handler)   or else
18324                   Is_RTE (Val, RE_Reference))
18325
18326         --  A special extra check, don't complain about a reference from within
18327         --  the Ada.Interrupts package itself!
18328
18329         and then not In_Same_Extended_Unit (N, Val)
18330       then
18331          Check_Restriction (No_Dynamic_Attachment, Post_Node);
18332       end if;
18333
18334       --  Check for No_Implementation_Identifiers
18335
18336       if Restriction_Check_Required (No_Implementation_Identifiers) then
18337
18338          --  We have an implementation defined entity if it is marked as
18339          --  implementation defined, or is defined in a package marked as
18340          --  implementation defined. However, library packages themselves
18341          --  are excluded (we don't want to flag Interfaces itself, just
18342          --  the entities within it).
18343
18344          if (Is_Implementation_Defined (Val)
18345               or else
18346                 (Present (Scope (Val))
18347                   and then Is_Implementation_Defined (Scope (Val))))
18348            and then not (Ekind_In (Val, E_Package, E_Generic_Package)
18349                           and then Is_Library_Level_Entity (Val))
18350          then
18351             Check_Restriction (No_Implementation_Identifiers, Post_Node);
18352          end if;
18353       end if;
18354
18355       --  Do the style check
18356
18357       if Style_Check
18358         and then not Suppress_Style_Checks (Val)
18359         and then not In_Instance
18360       then
18361          if Nkind (N) = N_Identifier then
18362             Nod := N;
18363          elsif Nkind (N) = N_Expanded_Name then
18364             Nod := Selector_Name (N);
18365          else
18366             return;
18367          end if;
18368
18369          --  A special situation arises for derived operations, where we want
18370          --  to do the check against the parent (since the Sloc of the derived
18371          --  operation points to the derived type declaration itself).
18372
18373          Val_Actual := Val;
18374          while not Comes_From_Source (Val_Actual)
18375            and then Nkind (Val_Actual) in N_Entity
18376            and then (Ekind (Val_Actual) = E_Enumeration_Literal
18377                       or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
18378            and then Present (Alias (Val_Actual))
18379          loop
18380             Val_Actual := Alias (Val_Actual);
18381          end loop;
18382
18383          --  Renaming declarations for generic actuals do not come from source,
18384          --  and have a different name from that of the entity they rename, so
18385          --  there is no style check to perform here.
18386
18387          if Chars (Nod) = Chars (Val_Actual) then
18388             Style.Check_Identifier (Nod, Val_Actual);
18389          end if;
18390       end if;
18391
18392       Set_Entity (N, Val);
18393    end Set_Entity_With_Checks;
18394
18395    ------------------------
18396    -- Set_Name_Entity_Id --
18397    ------------------------
18398
18399    procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
18400    begin
18401       Set_Name_Table_Int (Id, Int (Val));
18402    end Set_Name_Entity_Id;
18403
18404    ---------------------
18405    -- Set_Next_Actual --
18406    ---------------------
18407
18408    procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
18409    begin
18410       if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
18411          Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
18412       end if;
18413    end Set_Next_Actual;
18414
18415    ----------------------------------
18416    -- Set_Optimize_Alignment_Flags --
18417    ----------------------------------
18418
18419    procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is
18420    begin
18421       if Optimize_Alignment = 'S' then
18422          Set_Optimize_Alignment_Space (E);
18423       elsif Optimize_Alignment = 'T' then
18424          Set_Optimize_Alignment_Time (E);
18425       end if;
18426    end Set_Optimize_Alignment_Flags;
18427
18428    -----------------------
18429    -- Set_Public_Status --
18430    -----------------------
18431
18432    procedure Set_Public_Status (Id : Entity_Id) is
18433       S : constant Entity_Id := Current_Scope;
18434
18435       function Within_HSS_Or_If (E : Entity_Id) return Boolean;
18436       --  Determines if E is defined within handled statement sequence or
18437       --  an if statement, returns True if so, False otherwise.
18438
18439       ----------------------
18440       -- Within_HSS_Or_If --
18441       ----------------------
18442
18443       function Within_HSS_Or_If (E : Entity_Id) return Boolean is
18444          N : Node_Id;
18445       begin
18446          N := Declaration_Node (E);
18447          loop
18448             N := Parent (N);
18449
18450             if No (N) then
18451                return False;
18452
18453             elsif Nkind_In (N, N_Handled_Sequence_Of_Statements,
18454                                N_If_Statement)
18455             then
18456                return True;
18457             end if;
18458          end loop;
18459       end Within_HSS_Or_If;
18460
18461    --  Start of processing for Set_Public_Status
18462
18463    begin
18464       --  Everything in the scope of Standard is public
18465
18466       if S = Standard_Standard then
18467          Set_Is_Public (Id);
18468
18469       --  Entity is definitely not public if enclosing scope is not public
18470
18471       elsif not Is_Public (S) then
18472          return;
18473
18474       --  An object or function declaration that occurs in a handled sequence
18475       --  of statements or within an if statement is the declaration for a
18476       --  temporary object or local subprogram generated by the expander. It
18477       --  never needs to be made public and furthermore, making it public can
18478       --  cause back end problems.
18479
18480       elsif Nkind_In (Parent (Id), N_Object_Declaration,
18481                                    N_Function_Specification)
18482         and then Within_HSS_Or_If (Id)
18483       then
18484          return;
18485
18486       --  Entities in public packages or records are public
18487
18488       elsif Ekind (S) = E_Package or Is_Record_Type (S) then
18489          Set_Is_Public (Id);
18490
18491       --  The bounds of an entry family declaration can generate object
18492       --  declarations that are visible to the back-end, e.g. in the
18493       --  the declaration of a composite type that contains tasks.
18494
18495       elsif Is_Concurrent_Type (S)
18496         and then not Has_Completion (S)
18497         and then Nkind (Parent (Id)) = N_Object_Declaration
18498       then
18499          Set_Is_Public (Id);
18500       end if;
18501    end Set_Public_Status;
18502
18503    -----------------------------
18504    -- Set_Referenced_Modified --
18505    -----------------------------
18506
18507    procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is
18508       Pref : Node_Id;
18509
18510    begin
18511       --  Deal with indexed or selected component where prefix is modified
18512
18513       if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
18514          Pref := Prefix (N);
18515
18516          --  If prefix is access type, then it is the designated object that is
18517          --  being modified, which means we have no entity to set the flag on.
18518
18519          if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then
18520             return;
18521
18522             --  Otherwise chase the prefix
18523
18524          else
18525             Set_Referenced_Modified (Pref, Out_Param);
18526          end if;
18527
18528       --  Otherwise see if we have an entity name (only other case to process)
18529
18530       elsif Is_Entity_Name (N) and then Present (Entity (N)) then
18531          Set_Referenced_As_LHS           (Entity (N), not Out_Param);
18532          Set_Referenced_As_Out_Parameter (Entity (N), Out_Param);
18533       end if;
18534    end Set_Referenced_Modified;
18535
18536    ----------------------------
18537    -- Set_Scope_Is_Transient --
18538    ----------------------------
18539
18540    procedure Set_Scope_Is_Transient (V : Boolean := True) is
18541    begin
18542       Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
18543    end Set_Scope_Is_Transient;
18544
18545    -------------------
18546    -- Set_Size_Info --
18547    -------------------
18548
18549    procedure Set_Size_Info (T1, T2 : Entity_Id) is
18550    begin
18551       --  We copy Esize, but not RM_Size, since in general RM_Size is
18552       --  subtype specific and does not get inherited by all subtypes.
18553
18554       Set_Esize                     (T1, Esize                     (T2));
18555       Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
18556
18557       if Is_Discrete_Or_Fixed_Point_Type (T1)
18558            and then
18559          Is_Discrete_Or_Fixed_Point_Type (T2)
18560       then
18561          Set_Is_Unsigned_Type       (T1, Is_Unsigned_Type          (T2));
18562       end if;
18563
18564       Set_Alignment                 (T1, Alignment                 (T2));
18565    end Set_Size_Info;
18566
18567    --------------------
18568    -- Static_Boolean --
18569    --------------------
18570
18571    function Static_Boolean (N : Node_Id) return Uint is
18572    begin
18573       Analyze_And_Resolve (N, Standard_Boolean);
18574
18575       if N = Error
18576         or else Error_Posted (N)
18577         or else Etype (N) = Any_Type
18578       then
18579          return No_Uint;
18580       end if;
18581
18582       if Is_OK_Static_Expression (N) then
18583          if not Raises_Constraint_Error (N) then
18584             return Expr_Value (N);
18585          else
18586             return No_Uint;
18587          end if;
18588
18589       elsif Etype (N) = Any_Type then
18590          return No_Uint;
18591
18592       else
18593          Flag_Non_Static_Expr
18594            ("static boolean expression required here", N);
18595          return No_Uint;
18596       end if;
18597    end Static_Boolean;
18598
18599    --------------------
18600    -- Static_Integer --
18601    --------------------
18602
18603    function Static_Integer (N : Node_Id) return Uint is
18604    begin
18605       Analyze_And_Resolve (N, Any_Integer);
18606
18607       if N = Error
18608         or else Error_Posted (N)
18609         or else Etype (N) = Any_Type
18610       then
18611          return No_Uint;
18612       end if;
18613
18614       if Is_OK_Static_Expression (N) then
18615          if not Raises_Constraint_Error (N) then
18616             return Expr_Value (N);
18617          else
18618             return No_Uint;
18619          end if;
18620
18621       elsif Etype (N) = Any_Type then
18622          return No_Uint;
18623
18624       else
18625          Flag_Non_Static_Expr
18626            ("static integer expression required here", N);
18627          return No_Uint;
18628       end if;
18629    end Static_Integer;
18630
18631    --------------------------
18632    -- Statically_Different --
18633    --------------------------
18634
18635    function Statically_Different (E1, E2 : Node_Id) return Boolean is
18636       R1 : constant Node_Id := Get_Referenced_Object (E1);
18637       R2 : constant Node_Id := Get_Referenced_Object (E2);
18638    begin
18639       return     Is_Entity_Name (R1)
18640         and then Is_Entity_Name (R2)
18641         and then Entity (R1) /= Entity (R2)
18642         and then not Is_Formal (Entity (R1))
18643         and then not Is_Formal (Entity (R2));
18644    end Statically_Different;
18645
18646    --------------------------------------
18647    -- Subject_To_Loop_Entry_Attributes --
18648    --------------------------------------
18649
18650    function Subject_To_Loop_Entry_Attributes (N : Node_Id) return Boolean is
18651       Stmt : Node_Id;
18652
18653    begin
18654       Stmt := N;
18655
18656       --  The expansion mechanism transform a loop subject to at least one
18657       --  'Loop_Entry attribute into a conditional block. Infinite loops lack
18658       --  the conditional part.
18659
18660       if Nkind_In (Stmt, N_Block_Statement, N_If_Statement)
18661         and then Nkind (Original_Node (N)) = N_Loop_Statement
18662       then
18663          Stmt := Original_Node (N);
18664       end if;
18665
18666       return
18667         Nkind (Stmt) = N_Loop_Statement
18668           and then Present (Identifier (Stmt))
18669           and then Present (Entity (Identifier (Stmt)))
18670           and then Has_Loop_Entry_Attributes (Entity (Identifier (Stmt)));
18671    end Subject_To_Loop_Entry_Attributes;
18672
18673    -----------------------------
18674    -- Subprogram_Access_Level --
18675    -----------------------------
18676
18677    function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
18678    begin
18679       if Present (Alias (Subp)) then
18680          return Subprogram_Access_Level (Alias (Subp));
18681       else
18682          return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
18683       end if;
18684    end Subprogram_Access_Level;
18685
18686    -------------------------------
18687    -- Support_Atomic_Primitives --
18688    -------------------------------
18689
18690    function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean is
18691       Size : Int;
18692
18693    begin
18694       --  Verify the alignment of Typ is known
18695
18696       if not Known_Alignment (Typ) then
18697          return False;
18698       end if;
18699
18700       if Known_Static_Esize (Typ) then
18701          Size := UI_To_Int (Esize (Typ));
18702
18703       --  If the Esize (Object_Size) is unknown at compile time, look at the
18704       --  RM_Size (Value_Size) which may have been set by an explicit rep item.
18705
18706       elsif Known_Static_RM_Size (Typ) then
18707          Size := UI_To_Int (RM_Size (Typ));
18708
18709       --  Otherwise, the size is considered to be unknown.
18710
18711       else
18712          return False;
18713       end if;
18714
18715       --  Check that the size of the component is 8, 16, 32 or 64 bits and that
18716       --  Typ is properly aligned.
18717
18718       case Size is
18719          when 8 | 16 | 32 | 64 =>
18720             return Size = UI_To_Int (Alignment (Typ)) * 8;
18721          when others           =>
18722             return False;
18723       end case;
18724    end Support_Atomic_Primitives;
18725
18726    -----------------
18727    -- Trace_Scope --
18728    -----------------
18729
18730    procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
18731    begin
18732       if Debug_Flag_W then
18733          for J in 0 .. Scope_Stack.Last loop
18734             Write_Str ("  ");
18735          end loop;
18736
18737          Write_Str (Msg);
18738          Write_Name (Chars (E));
18739          Write_Str (" from ");
18740          Write_Location (Sloc (N));
18741          Write_Eol;
18742       end if;
18743    end Trace_Scope;
18744
18745    -----------------------
18746    -- Transfer_Entities --
18747    -----------------------
18748
18749    procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
18750       procedure Set_Public_Status_Of (Id : Entity_Id);
18751       --  Set the Is_Public attribute of arbitrary entity Id by calling routine
18752       --  Set_Public_Status. If successfull and Id denotes a record type, set
18753       --  the Is_Public attribute of its fields.
18754
18755       --------------------------
18756       -- Set_Public_Status_Of --
18757       --------------------------
18758
18759       procedure Set_Public_Status_Of (Id : Entity_Id) is
18760          Field : Entity_Id;
18761
18762       begin
18763          if not Is_Public (Id) then
18764             Set_Public_Status (Id);
18765
18766             --  When the input entity is a public record type, ensure that all
18767             --  its internal fields are also exposed to the linker. The fields
18768             --  of a class-wide type are never made public.
18769
18770             if Is_Public (Id)
18771               and then Is_Record_Type (Id)
18772               and then not Is_Class_Wide_Type (Id)
18773             then
18774                Field := First_Entity (Id);
18775                while Present (Field) loop
18776                   Set_Is_Public (Field);
18777                   Next_Entity (Field);
18778                end loop;
18779             end if;
18780          end if;
18781       end Set_Public_Status_Of;
18782
18783       --  Local variables
18784
18785       Full_Id : Entity_Id;
18786       Id      : Entity_Id;
18787
18788    --  Start of processing for Transfer_Entities
18789
18790    begin
18791       Id := First_Entity (From);
18792
18793       if Present (Id) then
18794
18795          --  Merge the entity chain of the source scope with that of the
18796          --  destination scope.
18797
18798          if Present (Last_Entity (To)) then
18799             Set_Next_Entity (Last_Entity (To), Id);
18800          else
18801             Set_First_Entity (To, Id);
18802          end if;
18803
18804          Set_Last_Entity (To, Last_Entity (From));
18805
18806          --  Inspect the entities of the source scope and update their Scope
18807          --  attribute.
18808
18809          while Present (Id) loop
18810             Set_Scope            (Id, To);
18811             Set_Public_Status_Of (Id);
18812
18813             --  Handle an internally generated full view for a private type
18814
18815             if Is_Private_Type (Id)
18816               and then Present (Full_View (Id))
18817               and then Is_Itype (Full_View (Id))
18818             then
18819                Full_Id := Full_View (Id);
18820
18821                Set_Scope            (Full_Id, To);
18822                Set_Public_Status_Of (Full_Id);
18823             end if;
18824
18825             Next_Entity (Id);
18826          end loop;
18827
18828          Set_First_Entity (From, Empty);
18829          Set_Last_Entity  (From, Empty);
18830       end if;
18831    end Transfer_Entities;
18832
18833    -----------------------
18834    -- Type_Access_Level --
18835    -----------------------
18836
18837    function Type_Access_Level (Typ : Entity_Id) return Uint is
18838       Btyp : Entity_Id;
18839
18840    begin
18841       Btyp := Base_Type (Typ);
18842
18843       --  Ada 2005 (AI-230): For most cases of anonymous access types, we
18844       --  simply use the level where the type is declared. This is true for
18845       --  stand-alone object declarations, and for anonymous access types
18846       --  associated with components the level is the same as that of the
18847       --  enclosing composite type. However, special treatment is needed for
18848       --  the cases of access parameters, return objects of an anonymous access
18849       --  type, and, in Ada 95, access discriminants of limited types.
18850
18851       if Is_Access_Type (Btyp) then
18852          if Ekind (Btyp) = E_Anonymous_Access_Type then
18853
18854             --  If the type is a nonlocal anonymous access type (such as for
18855             --  an access parameter) we treat it as being declared at the
18856             --  library level to ensure that names such as X.all'access don't
18857             --  fail static accessibility checks.
18858
18859             if not Is_Local_Anonymous_Access (Typ) then
18860                return Scope_Depth (Standard_Standard);
18861
18862             --  If this is a return object, the accessibility level is that of
18863             --  the result subtype of the enclosing function. The test here is
18864             --  little complicated, because we have to account for extended
18865             --  return statements that have been rewritten as blocks, in which
18866             --  case we have to find and the Is_Return_Object attribute of the
18867             --  itype's associated object. It would be nice to find a way to
18868             --  simplify this test, but it doesn't seem worthwhile to add a new
18869             --  flag just for purposes of this test. ???
18870
18871             elsif Ekind (Scope (Btyp)) = E_Return_Statement
18872               or else
18873                 (Is_Itype (Btyp)
18874                   and then Nkind (Associated_Node_For_Itype (Btyp)) =
18875                                                          N_Object_Declaration
18876                   and then Is_Return_Object
18877                              (Defining_Identifier
18878                                 (Associated_Node_For_Itype (Btyp))))
18879             then
18880                declare
18881                   Scop : Entity_Id;
18882
18883                begin
18884                   Scop := Scope (Scope (Btyp));
18885                   while Present (Scop) loop
18886                      exit when Ekind (Scop) = E_Function;
18887                      Scop := Scope (Scop);
18888                   end loop;
18889
18890                   --  Treat the return object's type as having the level of the
18891                   --  function's result subtype (as per RM05-6.5(5.3/2)).
18892
18893                   return Type_Access_Level (Etype (Scop));
18894                end;
18895             end if;
18896          end if;
18897
18898          Btyp := Root_Type (Btyp);
18899
18900          --  The accessibility level of anonymous access types associated with
18901          --  discriminants is that of the current instance of the type, and
18902          --  that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
18903
18904          --  AI-402: access discriminants have accessibility based on the
18905          --  object rather than the type in Ada 2005, so the above paragraph
18906          --  doesn't apply.
18907
18908          --  ??? Needs completion with rules from AI-416
18909
18910          if Ada_Version <= Ada_95
18911            and then Ekind (Typ) = E_Anonymous_Access_Type
18912            and then Present (Associated_Node_For_Itype (Typ))
18913            and then Nkind (Associated_Node_For_Itype (Typ)) =
18914                                                  N_Discriminant_Specification
18915          then
18916             return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1;
18917          end if;
18918       end if;
18919
18920       --  Return library level for a generic formal type. This is done because
18921       --  RM(10.3.2) says that "The statically deeper relationship does not
18922       --  apply to ... a descendant of a generic formal type". Rather than
18923       --  checking at each point where a static accessibility check is
18924       --  performed to see if we are dealing with a formal type, this rule is
18925       --  implemented by having Type_Access_Level and Deepest_Type_Access_Level
18926       --  return extreme values for a formal type; Deepest_Type_Access_Level
18927       --  returns Int'Last. By calling the appropriate function from among the
18928       --  two, we ensure that the static accessibility check will pass if we
18929       --  happen to run into a formal type. More specifically, we should call
18930       --  Deepest_Type_Access_Level instead of Type_Access_Level whenever the
18931       --  call occurs as part of a static accessibility check and the error
18932       --  case is the case where the type's level is too shallow (as opposed
18933       --  to too deep).
18934
18935       if Is_Generic_Type (Root_Type (Btyp)) then
18936          return Scope_Depth (Standard_Standard);
18937       end if;
18938
18939       return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
18940    end Type_Access_Level;
18941
18942    ------------------------------------
18943    -- Type_Without_Stream_Operation  --
18944    ------------------------------------
18945
18946    function Type_Without_Stream_Operation
18947      (T  : Entity_Id;
18948       Op : TSS_Name_Type := TSS_Null) return Entity_Id
18949    is
18950       BT         : constant Entity_Id := Base_Type (T);
18951       Op_Missing : Boolean;
18952
18953    begin
18954       if not Restriction_Active (No_Default_Stream_Attributes) then
18955          return Empty;
18956       end if;
18957
18958       if Is_Elementary_Type (T) then
18959          if Op = TSS_Null then
18960             Op_Missing :=
18961               No (TSS (BT, TSS_Stream_Read))
18962                 or else No (TSS (BT, TSS_Stream_Write));
18963
18964          else
18965             Op_Missing := No (TSS (BT, Op));
18966          end if;
18967
18968          if Op_Missing then
18969             return T;
18970          else
18971             return Empty;
18972          end if;
18973
18974       elsif Is_Array_Type (T) then
18975          return Type_Without_Stream_Operation (Component_Type (T), Op);
18976
18977       elsif Is_Record_Type (T) then
18978          declare
18979             Comp  : Entity_Id;
18980             C_Typ : Entity_Id;
18981
18982          begin
18983             Comp := First_Component (T);
18984             while Present (Comp) loop
18985                C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op);
18986
18987                if Present (C_Typ) then
18988                   return C_Typ;
18989                end if;
18990
18991                Next_Component (Comp);
18992             end loop;
18993
18994             return Empty;
18995          end;
18996
18997       elsif Is_Private_Type (T) and then Present (Full_View (T)) then
18998          return Type_Without_Stream_Operation (Full_View (T), Op);
18999       else
19000          return Empty;
19001       end if;
19002    end Type_Without_Stream_Operation;
19003
19004    ----------------------------
19005    -- Unique_Defining_Entity --
19006    ----------------------------
19007
19008    function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
19009    begin
19010       return Unique_Entity (Defining_Entity (N));
19011    end Unique_Defining_Entity;
19012
19013    -------------------
19014    -- Unique_Entity --
19015    -------------------
19016
19017    function Unique_Entity (E : Entity_Id) return Entity_Id is
19018       U : Entity_Id := E;
19019       P : Node_Id;
19020
19021    begin
19022       case Ekind (E) is
19023          when E_Constant =>
19024             if Present (Full_View (E)) then
19025                U := Full_View (E);
19026             end if;
19027
19028          when Entry_Kind =>
19029             if Nkind (Parent (E)) = N_Entry_Body then
19030                declare
19031                   Prot_Item : Entity_Id;
19032                begin
19033                   --  Traverse the entity list of the protected type and locate
19034                   --  an entry declaration which matches the entry body.
19035
19036                   Prot_Item := First_Entity (Scope (E));
19037                   while Present (Prot_Item) loop
19038                      if Ekind (Prot_Item) = E_Entry
19039                        and then Corresponding_Body (Parent (Prot_Item)) = E
19040                      then
19041                         U := Prot_Item;
19042                         exit;
19043                      end if;
19044
19045                      Next_Entity (Prot_Item);
19046                   end loop;
19047                end;
19048             end if;
19049
19050          when Formal_Kind =>
19051             if Present (Spec_Entity (E)) then
19052                U := Spec_Entity (E);
19053             end if;
19054
19055          when E_Package_Body =>
19056             P := Parent (E);
19057
19058             if Nkind (P) = N_Defining_Program_Unit_Name then
19059                P := Parent (P);
19060             end if;
19061
19062             if Nkind (P) = N_Package_Body
19063               and then Present (Corresponding_Spec (P))
19064             then
19065                U := Corresponding_Spec (P);
19066
19067             elsif Nkind (P) = N_Package_Body_Stub
19068               and then Present (Corresponding_Spec_Of_Stub (P))
19069             then
19070                U := Corresponding_Spec_Of_Stub (P);
19071             end if;
19072
19073          when E_Protected_Body =>
19074             P := Parent (E);
19075
19076             if Nkind (P) = N_Protected_Body
19077               and then Present (Corresponding_Spec (P))
19078             then
19079                U := Corresponding_Spec (P);
19080
19081             elsif Nkind (P) = N_Protected_Body_Stub
19082               and then Present (Corresponding_Spec_Of_Stub (P))
19083             then
19084                U := Corresponding_Spec_Of_Stub (P);
19085             end if;
19086
19087          when E_Subprogram_Body =>
19088             P := Parent (E);
19089
19090             if Nkind (P) = N_Defining_Program_Unit_Name then
19091                P := Parent (P);
19092             end if;
19093
19094             P := Parent (P);
19095
19096             if Nkind (P) = N_Subprogram_Body
19097               and then Present (Corresponding_Spec (P))
19098             then
19099                U := Corresponding_Spec (P);
19100
19101             elsif Nkind (P) = N_Subprogram_Body_Stub
19102               and then Present (Corresponding_Spec_Of_Stub (P))
19103             then
19104                U := Corresponding_Spec_Of_Stub (P);
19105             end if;
19106
19107          when E_Task_Body =>
19108             P := Parent (E);
19109
19110             if Nkind (P) = N_Task_Body
19111               and then Present (Corresponding_Spec (P))
19112             then
19113                U := Corresponding_Spec (P);
19114
19115             elsif Nkind (P) = N_Task_Body_Stub
19116               and then Present (Corresponding_Spec_Of_Stub (P))
19117             then
19118                U := Corresponding_Spec_Of_Stub (P);
19119             end if;
19120
19121          when Type_Kind =>
19122             if Present (Full_View (E)) then
19123                U := Full_View (E);
19124             end if;
19125
19126          when others =>
19127             null;
19128       end case;
19129
19130       return U;
19131    end Unique_Entity;
19132
19133    -----------------
19134    -- Unique_Name --
19135    -----------------
19136
19137    function Unique_Name (E : Entity_Id) return String is
19138
19139       --  Names of E_Subprogram_Body or E_Package_Body entities are not
19140       --  reliable, as they may not include the overloading suffix. Instead,
19141       --  when looking for the name of E or one of its enclosing scope, we get
19142       --  the name of the corresponding Unique_Entity.
19143
19144       function Get_Scoped_Name (E : Entity_Id) return String;
19145       --  Return the name of E prefixed by all the names of the scopes to which
19146       --  E belongs, except for Standard.
19147
19148       ---------------------
19149       -- Get_Scoped_Name --
19150       ---------------------
19151
19152       function Get_Scoped_Name (E : Entity_Id) return String is
19153          Name : constant String := Get_Name_String (Chars (E));
19154       begin
19155          if Has_Fully_Qualified_Name (E)
19156            or else Scope (E) = Standard_Standard
19157          then
19158             return Name;
19159          else
19160             return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
19161          end if;
19162       end Get_Scoped_Name;
19163
19164    --  Start of processing for Unique_Name
19165
19166    begin
19167       if E = Standard_Standard then
19168          return Get_Name_String (Name_Standard);
19169
19170       elsif Scope (E) = Standard_Standard
19171         and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
19172       then
19173          return Get_Name_String (Name_Standard) & "__" &
19174            Get_Name_String (Chars (E));
19175
19176       elsif Ekind (E) = E_Enumeration_Literal then
19177          return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
19178
19179       else
19180          return Get_Scoped_Name (Unique_Entity (E));
19181       end if;
19182    end Unique_Name;
19183
19184    ---------------------
19185    -- Unit_Is_Visible --
19186    ---------------------
19187
19188    function Unit_Is_Visible (U : Entity_Id) return Boolean is
19189       Curr        : constant Node_Id   := Cunit (Current_Sem_Unit);
19190       Curr_Entity : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
19191
19192       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean;
19193       --  For a child unit, check whether unit appears in a with_clause
19194       --  of a parent.
19195
19196       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean;
19197       --  Scan the context clause of one compilation unit looking for a
19198       --  with_clause for the unit in question.
19199
19200       ----------------------------
19201       -- Unit_In_Parent_Context --
19202       ----------------------------
19203
19204       function Unit_In_Parent_Context (Par_Unit : Node_Id) return Boolean is
19205       begin
19206          if Unit_In_Context (Par_Unit) then
19207             return True;
19208
19209          elsif Is_Child_Unit (Defining_Entity (Unit (Par_Unit))) then
19210             return Unit_In_Parent_Context (Parent_Spec (Unit (Par_Unit)));
19211
19212          else
19213             return False;
19214          end if;
19215       end Unit_In_Parent_Context;
19216
19217       ---------------------
19218       -- Unit_In_Context --
19219       ---------------------
19220
19221       function Unit_In_Context (Comp_Unit : Node_Id) return Boolean is
19222          Clause : Node_Id;
19223
19224       begin
19225          Clause := First (Context_Items (Comp_Unit));
19226          while Present (Clause) loop
19227             if Nkind (Clause) = N_With_Clause then
19228                if Library_Unit (Clause) = U then
19229                   return True;
19230
19231                --  The with_clause may denote a renaming of the unit we are
19232                --  looking for, eg. Text_IO which renames Ada.Text_IO.
19233
19234                elsif
19235                  Renamed_Entity (Entity (Name (Clause))) =
19236                                                 Defining_Entity (Unit (U))
19237                then
19238                   return True;
19239                end if;
19240             end if;
19241
19242             Next (Clause);
19243          end loop;
19244
19245          return False;
19246       end Unit_In_Context;
19247
19248    --  Start of processing for Unit_Is_Visible
19249
19250    begin
19251       --  The currrent unit is directly visible
19252
19253       if Curr = U then
19254          return True;
19255
19256       elsif Unit_In_Context (Curr) then
19257          return True;
19258
19259       --  If the current unit is a body, check the context of the spec
19260
19261       elsif Nkind (Unit (Curr)) = N_Package_Body
19262         or else
19263           (Nkind (Unit (Curr)) = N_Subprogram_Body
19264             and then not Acts_As_Spec (Unit (Curr)))
19265       then
19266          if Unit_In_Context (Library_Unit (Curr)) then
19267             return True;
19268          end if;
19269       end if;
19270
19271       --  If the spec is a child unit, examine the parents
19272
19273       if Is_Child_Unit (Curr_Entity) then
19274          if Nkind (Unit (Curr)) in N_Unit_Body then
19275             return
19276               Unit_In_Parent_Context
19277                 (Parent_Spec (Unit (Library_Unit (Curr))));
19278          else
19279             return Unit_In_Parent_Context (Parent_Spec (Unit (Curr)));
19280          end if;
19281
19282       else
19283          return False;
19284       end if;
19285    end Unit_Is_Visible;
19286
19287    ------------------------------
19288    -- Universal_Interpretation --
19289    ------------------------------
19290
19291    function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
19292       Index : Interp_Index;
19293       It    : Interp;
19294
19295    begin
19296       --  The argument may be a formal parameter of an operator or subprogram
19297       --  with multiple interpretations, or else an expression for an actual.
19298
19299       if Nkind (Opnd) = N_Defining_Identifier
19300         or else not Is_Overloaded (Opnd)
19301       then
19302          if Etype (Opnd) = Universal_Integer
19303            or else Etype (Opnd) = Universal_Real
19304          then
19305             return Etype (Opnd);
19306          else
19307             return Empty;
19308          end if;
19309
19310       else
19311          Get_First_Interp (Opnd, Index, It);
19312          while Present (It.Typ) loop
19313             if It.Typ = Universal_Integer
19314               or else It.Typ = Universal_Real
19315             then
19316                return It.Typ;
19317             end if;
19318
19319             Get_Next_Interp (Index, It);
19320          end loop;
19321
19322          return Empty;
19323       end if;
19324    end Universal_Interpretation;
19325
19326    ---------------
19327    -- Unqualify --
19328    ---------------
19329
19330    function Unqualify (Expr : Node_Id) return Node_Id is
19331    begin
19332       --  Recurse to handle unlikely case of multiple levels of qualification
19333
19334       if Nkind (Expr) = N_Qualified_Expression then
19335          return Unqualify (Expression (Expr));
19336
19337       --  Normal case, not a qualified expression
19338
19339       else
19340          return Expr;
19341       end if;
19342    end Unqualify;
19343
19344    -----------------------
19345    -- Visible_Ancestors --
19346    -----------------------
19347
19348    function Visible_Ancestors (Typ : Entity_Id) return Elist_Id is
19349       List_1 : Elist_Id;
19350       List_2 : Elist_Id;
19351       Elmt   : Elmt_Id;
19352
19353    begin
19354       pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ));
19355
19356       --  Collect all the parents and progenitors of Typ. If the full-view of
19357       --  private parents and progenitors is available then it is used to
19358       --  generate the list of visible ancestors; otherwise their partial
19359       --  view is added to the resulting list.
19360
19361       Collect_Parents
19362         (T               => Typ,
19363          List            => List_1,
19364          Use_Full_View   => True);
19365
19366       Collect_Interfaces
19367         (T               => Typ,
19368          Ifaces_List     => List_2,
19369          Exclude_Parents => True,
19370          Use_Full_View   => True);
19371
19372       --  Join the two lists. Avoid duplications because an interface may
19373       --  simultaneously be parent and progenitor of a type.
19374
19375       Elmt := First_Elmt (List_2);
19376       while Present (Elmt) loop
19377          Append_Unique_Elmt (Node (Elmt), List_1);
19378          Next_Elmt (Elmt);
19379       end loop;
19380
19381       return List_1;
19382    end Visible_Ancestors;
19383
19384    ----------------------
19385    -- Within_Init_Proc --
19386    ----------------------
19387
19388    function Within_Init_Proc return Boolean is
19389       S : Entity_Id;
19390
19391    begin
19392       S := Current_Scope;
19393       while not Is_Overloadable (S) loop
19394          if S = Standard_Standard then
19395             return False;
19396          else
19397             S := Scope (S);
19398          end if;
19399       end loop;
19400
19401       return Is_Init_Proc (S);
19402    end Within_Init_Proc;
19403
19404    ------------------
19405    -- Within_Scope --
19406    ------------------
19407
19408    function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
19409       SE : Entity_Id;
19410    begin
19411       SE := Scope (E);
19412       loop
19413          if SE = S then
19414             return True;
19415          elsif SE = Standard_Standard then
19416             return False;
19417          else
19418             SE := Scope (SE);
19419          end if;
19420       end loop;
19421    end Within_Scope;
19422
19423    ----------------
19424    -- Wrong_Type --
19425    ----------------
19426
19427    procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
19428       Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
19429       Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
19430
19431       Matching_Field : Entity_Id;
19432       --  Entity to give a more precise suggestion on how to write a one-
19433       --  element positional aggregate.
19434
19435       function Has_One_Matching_Field return Boolean;
19436       --  Determines if Expec_Type is a record type with a single component or
19437       --  discriminant whose type matches the found type or is one dimensional
19438       --  array whose component type matches the found type. In the case of
19439       --  one discriminant, we ignore the variant parts. That's not accurate,
19440       --  but good enough for the warning.
19441
19442       ----------------------------
19443       -- Has_One_Matching_Field --
19444       ----------------------------
19445
19446       function Has_One_Matching_Field return Boolean is
19447          E : Entity_Id;
19448
19449       begin
19450          Matching_Field := Empty;
19451
19452          if Is_Array_Type (Expec_Type)
19453            and then Number_Dimensions (Expec_Type) = 1
19454            and then Covers (Etype (Component_Type (Expec_Type)), Found_Type)
19455          then
19456             --  Use type name if available. This excludes multidimensional
19457             --  arrays and anonymous arrays.
19458
19459             if Comes_From_Source (Expec_Type) then
19460                Matching_Field := Expec_Type;
19461
19462             --  For an assignment, use name of target
19463
19464             elsif Nkind (Parent (Expr)) = N_Assignment_Statement
19465               and then Is_Entity_Name (Name (Parent (Expr)))
19466             then
19467                Matching_Field := Entity (Name (Parent (Expr)));
19468             end if;
19469
19470             return True;
19471
19472          elsif not Is_Record_Type (Expec_Type) then
19473             return False;
19474
19475          else
19476             E := First_Entity (Expec_Type);
19477             loop
19478                if No (E) then
19479                   return False;
19480
19481                elsif not Ekind_In (E, E_Discriminant, E_Component)
19482                  or else Nam_In (Chars (E), Name_uTag, Name_uParent)
19483                then
19484                   Next_Entity (E);
19485
19486                else
19487                   exit;
19488                end if;
19489             end loop;
19490
19491             if not Covers (Etype (E), Found_Type) then
19492                return False;
19493
19494             elsif Present (Next_Entity (E))
19495               and then (Ekind (E) = E_Component
19496                          or else Ekind (Next_Entity (E)) = E_Discriminant)
19497             then
19498                return False;
19499
19500             else
19501                Matching_Field := E;
19502                return True;
19503             end if;
19504          end if;
19505       end Has_One_Matching_Field;
19506
19507    --  Start of processing for Wrong_Type
19508
19509    begin
19510       --  Don't output message if either type is Any_Type, or if a message
19511       --  has already been posted for this node. We need to do the latter
19512       --  check explicitly (it is ordinarily done in Errout), because we
19513       --  are using ! to force the output of the error messages.
19514
19515       if Expec_Type = Any_Type
19516         or else Found_Type = Any_Type
19517         or else Error_Posted (Expr)
19518       then
19519          return;
19520
19521       --  If one of the types is a Taft-Amendment type and the other it its
19522       --  completion, it must be an illegal use of a TAT in the spec, for
19523       --  which an error was already emitted. Avoid cascaded errors.
19524
19525       elsif Is_Incomplete_Type (Expec_Type)
19526         and then Has_Completion_In_Body (Expec_Type)
19527         and then Full_View (Expec_Type) = Etype (Expr)
19528       then
19529          return;
19530
19531       elsif Is_Incomplete_Type (Etype (Expr))
19532         and then Has_Completion_In_Body (Etype (Expr))
19533         and then Full_View (Etype (Expr)) = Expec_Type
19534       then
19535          return;
19536
19537       --  In  an instance, there is an ongoing problem with completion of
19538       --  type derived from private types. Their structure is what Gigi
19539       --  expects, but the  Etype is the parent type rather than the
19540       --  derived private type itself. Do not flag error in this case. The
19541       --  private completion is an entity without a parent, like an Itype.
19542       --  Similarly, full and partial views may be incorrect in the instance.
19543       --  There is no simple way to insure that it is consistent ???
19544
19545       --  A similar view discrepancy can happen in an inlined body, for the
19546       --  same reason: inserted body may be outside of the original package
19547       --  and only partial views are visible at the point of insertion.
19548
19549       elsif In_Instance or else In_Inlined_Body then
19550          if Etype (Etype (Expr)) = Etype (Expected_Type)
19551            and then
19552              (Has_Private_Declaration (Expected_Type)
19553                or else Has_Private_Declaration (Etype (Expr)))
19554            and then No (Parent (Expected_Type))
19555          then
19556             return;
19557
19558          elsif Nkind (Parent (Expr)) = N_Qualified_Expression
19559            and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type
19560          then
19561             return;
19562
19563          elsif Is_Private_Type (Expected_Type)
19564            and then Present (Full_View (Expected_Type))
19565            and then Covers (Full_View (Expected_Type), Etype (Expr))
19566          then
19567             return;
19568
19569          --  Conversely, type of expression may be the private one
19570
19571          elsif Is_Private_Type (Base_Type (Etype (Expr)))
19572            and then Full_View (Base_Type (Etype (Expr))) = Expected_Type
19573          then
19574             return;
19575          end if;
19576       end if;
19577
19578       --  An interesting special check. If the expression is parenthesized
19579       --  and its type corresponds to the type of the sole component of the
19580       --  expected record type, or to the component type of the expected one
19581       --  dimensional array type, then assume we have a bad aggregate attempt.
19582
19583       if Nkind (Expr) in N_Subexpr
19584         and then Paren_Count (Expr) /= 0
19585         and then Has_One_Matching_Field
19586       then
19587          Error_Msg_N ("positional aggregate cannot have one component", Expr);
19588
19589          if Present (Matching_Field) then
19590             if Is_Array_Type (Expec_Type) then
19591                Error_Msg_NE
19592                  ("\write instead `&''First ='> ...`", Expr, Matching_Field);
19593             else
19594                Error_Msg_NE
19595                  ("\write instead `& ='> ...`", Expr, Matching_Field);
19596             end if;
19597          end if;
19598
19599       --  Another special check, if we are looking for a pool-specific access
19600       --  type and we found an E_Access_Attribute_Type, then we have the case
19601       --  of an Access attribute being used in a context which needs a pool-
19602       --  specific type, which is never allowed. The one extra check we make
19603       --  is that the expected designated type covers the Found_Type.
19604
19605       elsif Is_Access_Type (Expec_Type)
19606         and then Ekind (Found_Type) = E_Access_Attribute_Type
19607         and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
19608         and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
19609         and then Covers
19610           (Designated_Type (Expec_Type), Designated_Type (Found_Type))
19611       then
19612          Error_Msg_N -- CODEFIX
19613            ("result must be general access type!", Expr);
19614          Error_Msg_NE -- CODEFIX
19615            ("add ALL to }!", Expr, Expec_Type);
19616
19617       --  Another special check, if the expected type is an integer type,
19618       --  but the expression is of type System.Address, and the parent is
19619       --  an addition or subtraction operation whose left operand is the
19620       --  expression in question and whose right operand is of an integral
19621       --  type, then this is an attempt at address arithmetic, so give
19622       --  appropriate message.
19623
19624       elsif Is_Integer_Type (Expec_Type)
19625         and then Is_RTE (Found_Type, RE_Address)
19626         and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract)
19627         and then Expr = Left_Opnd (Parent (Expr))
19628         and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr))))
19629       then
19630          Error_Msg_N
19631            ("address arithmetic not predefined in package System",
19632             Parent (Expr));
19633          Error_Msg_N
19634            ("\possible missing with/use of System.Storage_Elements",
19635             Parent (Expr));
19636          return;
19637
19638       --  If the expected type is an anonymous access type, as for access
19639       --  parameters and discriminants, the error is on the designated types.
19640
19641       elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
19642          if Comes_From_Source (Expec_Type) then
19643             Error_Msg_NE ("expected}!", Expr, Expec_Type);
19644          else
19645             Error_Msg_NE
19646               ("expected an access type with designated}",
19647                  Expr, Designated_Type (Expec_Type));
19648          end if;
19649
19650          if Is_Access_Type (Found_Type)
19651            and then not Comes_From_Source (Found_Type)
19652          then
19653             Error_Msg_NE
19654               ("\\found an access type with designated}!",
19655                 Expr, Designated_Type (Found_Type));
19656          else
19657             if From_Limited_With (Found_Type) then
19658                Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type);
19659                Error_Msg_Qual_Level := 99;
19660                Error_Msg_NE -- CODEFIX
19661                  ("\\missing `WITH &;", Expr, Scope (Found_Type));
19662                Error_Msg_Qual_Level := 0;
19663             else
19664                Error_Msg_NE ("found}!", Expr, Found_Type);
19665             end if;
19666          end if;
19667
19668       --  Normal case of one type found, some other type expected
19669
19670       else
19671          --  If the names of the two types are the same, see if some number
19672          --  of levels of qualification will help. Don't try more than three
19673          --  levels, and if we get to standard, it's no use (and probably
19674          --  represents an error in the compiler) Also do not bother with
19675          --  internal scope names.
19676
19677          declare
19678             Expec_Scope : Entity_Id;
19679             Found_Scope : Entity_Id;
19680
19681          begin
19682             Expec_Scope := Expec_Type;
19683             Found_Scope := Found_Type;
19684
19685             for Levels in Int range 0 .. 3 loop
19686                if Chars (Expec_Scope) /= Chars (Found_Scope) then
19687                   Error_Msg_Qual_Level := Levels;
19688                   exit;
19689                end if;
19690
19691                Expec_Scope := Scope (Expec_Scope);
19692                Found_Scope := Scope (Found_Scope);
19693
19694                exit when Expec_Scope = Standard_Standard
19695                  or else Found_Scope = Standard_Standard
19696                  or else not Comes_From_Source (Expec_Scope)
19697                  or else not Comes_From_Source (Found_Scope);
19698             end loop;
19699          end;
19700
19701          if Is_Record_Type (Expec_Type)
19702            and then Present (Corresponding_Remote_Type (Expec_Type))
19703          then
19704             Error_Msg_NE ("expected}!", Expr,
19705                           Corresponding_Remote_Type (Expec_Type));
19706          else
19707             Error_Msg_NE ("expected}!", Expr, Expec_Type);
19708          end if;
19709
19710          if Is_Entity_Name (Expr)
19711            and then Is_Package_Or_Generic_Package (Entity (Expr))
19712          then
19713             Error_Msg_N ("\\found package name!", Expr);
19714
19715          elsif Is_Entity_Name (Expr)
19716            and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure)
19717          then
19718             if Ekind (Expec_Type) = E_Access_Subprogram_Type then
19719                Error_Msg_N
19720                  ("found procedure name, possibly missing Access attribute!",
19721                    Expr);
19722             else
19723                Error_Msg_N
19724                  ("\\found procedure name instead of function!", Expr);
19725             end if;
19726
19727          elsif Nkind (Expr) = N_Function_Call
19728            and then Ekind (Expec_Type) = E_Access_Subprogram_Type
19729            and then Etype (Designated_Type (Expec_Type)) = Etype (Expr)
19730            and then No (Parameter_Associations (Expr))
19731          then
19732             Error_Msg_N
19733               ("found function name, possibly missing Access attribute!",
19734                Expr);
19735
19736          --  Catch common error: a prefix or infix operator which is not
19737          --  directly visible because the type isn't.
19738
19739          elsif Nkind (Expr) in N_Op
19740             and then Is_Overloaded (Expr)
19741             and then not Is_Immediately_Visible (Expec_Type)
19742             and then not Is_Potentially_Use_Visible (Expec_Type)
19743             and then not In_Use (Expec_Type)
19744             and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
19745          then
19746             Error_Msg_N
19747               ("operator of the type is not directly visible!", Expr);
19748
19749          elsif Ekind (Found_Type) = E_Void
19750            and then Present (Parent (Found_Type))
19751            and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration
19752          then
19753             Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type);
19754
19755          else
19756             Error_Msg_NE ("\\found}!", Expr, Found_Type);
19757          end if;
19758
19759          --  A special check for cases like M1 and M2 = 0 where M1 and M2 are
19760          --  of the same modular type, and (M1 and M2) = 0 was intended.
19761
19762          if Expec_Type = Standard_Boolean
19763            and then Is_Modular_Integer_Type (Found_Type)
19764            and then Nkind_In (Parent (Expr), N_Op_And, N_Op_Or, N_Op_Xor)
19765            and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare
19766          then
19767             declare
19768                Op : constant Node_Id := Right_Opnd (Parent (Expr));
19769                L  : constant Node_Id := Left_Opnd (Op);
19770                R  : constant Node_Id := Right_Opnd (Op);
19771
19772             begin
19773                --  The case for the message is when the left operand of the
19774                --  comparison is the same modular type, or when it is an
19775                --  integer literal (or other universal integer expression),
19776                --  which would have been typed as the modular type if the
19777                --  parens had been there.
19778
19779                if (Etype (L) = Found_Type
19780                      or else
19781                    Etype (L) = Universal_Integer)
19782                  and then Is_Integer_Type (Etype (R))
19783                then
19784                   Error_Msg_N
19785                     ("\\possible missing parens for modular operation", Expr);
19786                end if;
19787             end;
19788          end if;
19789
19790          --  Reset error message qualification indication
19791
19792          Error_Msg_Qual_Level := 0;
19793       end if;
19794    end Wrong_Type;
19795
19796 end Sem_Util;