gcc/ada/einfo-utils.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                           E I N F O . U T I L S                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 2020-2023, Free Software Foundation, Inc.        --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;          use Atree;
  27 with Elists;         use Elists;
  28 with Nlists;         use Nlists;
  29 with Output;         use Output;
  30 with Sinfo;          use Sinfo;
  31 with Sinfo.Utils;    use Sinfo.Utils;
  32
  33 package body Einfo.Utils is
  34
  35    -----------------------
  36    -- Local subprograms --
  37    -----------------------
  38
  39    function Has_Option
  40      (State_Id   : Entity_Id;
  41       Option_Nam : Name_Id) return Boolean;
  42    --  Determine whether abstract state State_Id has particular option denoted
  43    --  by the name Option_Nam.
  44
  45    -------------------------------------------
  46    -- Aliases/Renamings of Renamed_Or_Alias --
  47    -------------------------------------------
  48
  49    function Alias (N : Entity_Id) return Entity_Id is
  50    begin
  51       return Val : constant Entity_Id := Renamed_Or_Alias (N) do
  52          pragma Assert
  53            (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type);
  54          pragma Assert (Val in N_Entity_Id | N_Empty_Id);
  55       end return;
  56    end Alias;
  57
  58    procedure Set_Alias (N : Entity_Id; Val : Entity_Id) is
  59    begin
  60       pragma Assert
  61         (Is_Overloadable (N) or else Ekind (N) = E_Subprogram_Type);
  62       pragma Assert (Val in N_Entity_Id | N_Empty_Id);
  63
  64       Set_Renamed_Or_Alias (N, Val);
  65    end Set_Alias;
  66
  67    function Renamed_Entity (N : Entity_Id) return Entity_Id is
  68    begin
  69       return Val : constant Entity_Id := Renamed_Or_Alias (N) do
  70          pragma Assert (not Is_Object (N) or else Etype (N) = Any_Type);
  71          pragma Assert (Val in N_Entity_Id | N_Empty_Id);
  72       end return;
  73    end Renamed_Entity;
  74
  75    procedure Set_Renamed_Entity (N : Entity_Id; Val : Entity_Id) is
  76    begin
  77       pragma Assert (not Is_Object (N));
  78       pragma Assert (Val in N_Entity_Id);
  79
  80       Set_Renamed_Or_Alias (N, Val);
  81    end Set_Renamed_Entity;
  82
  83    function Renamed_Object (N : Entity_Id) return Node_Id is
  84    begin
  85       return Val : constant Node_Id := Renamed_Or_Alias (N) do
  86          --  Formal_Kind uses the entity, not a name of it. This happens
  87          --  in front-end inlining, which also sets to Empty. Also in
  88          --  Exp_Ch9, where formals are renamed for the benefit of gdb.
  89
  90          if Ekind (N) not in Formal_Kind then
  91             pragma Assert (Is_Object (N));
  92             pragma Assert (Val in N_Subexpr_Id | N_Empty_Id);
  93             null;
  94          end if;
  95       end return;
  96    end Renamed_Object;
  97
  98    procedure Set_Renamed_Object (N : Entity_Id; Val : Node_Id) is
  99    begin
 100       if Ekind (N) not in Formal_Kind then
 101          pragma Assert (Is_Object (N));
 102          pragma Assert (Val in N_Subexpr_Id | N_Empty_Id);
 103          null;
 104       end if;
 105
 106       Set_Renamed_Or_Alias (N, Val);
 107    end Set_Renamed_Object;
 108
 109    function Renamed_Entity_Or_Object (N : Entity_Id) return Node_Id is
 110    begin
 111       if Is_Object (N) then
 112          return Renamed_Object (N);
 113       else
 114          return Renamed_Entity (N);
 115       end if;
 116    end Renamed_Entity_Or_Object;
 117
 118    procedure Set_Renamed_Object_Of_Possibly_Void
 119      (N : Entity_Id; Val : Node_Id)
 120    is
 121    begin
 122       pragma Assert (Val in N_Subexpr_Id);
 123       Set_Renamed_Or_Alias (N, Val);
 124    end Set_Renamed_Object_Of_Possibly_Void;
 125
 126    ----------------
 127    -- Has_Option --
 128    ----------------
 129
 130    function Has_Option
 131      (State_Id   : Entity_Id;
 132       Option_Nam : Name_Id) return Boolean
 133    is
 134       Decl    : constant Node_Id := Parent (State_Id);
 135       Opt     : Node_Id;
 136       Opt_Nam : Node_Id;
 137
 138    begin
 139       pragma Assert (Ekind (State_Id) = E_Abstract_State);
 140
 141       --  The declaration of abstract states with options appear as an
 142       --  extension aggregate. If this is not the case, the option is not
 143       --  available.
 144
 145       if Nkind (Decl) /= N_Extension_Aggregate then
 146          return False;
 147       end if;
 148
 149       --  Simple options
 150
 151       Opt := First (Expressions (Decl));
 152       while Present (Opt) loop
 153          if Nkind (Opt) = N_Identifier and then Chars (Opt) = Option_Nam then
 154             return True;
 155          end if;
 156
 157          Next (Opt);
 158       end loop;
 159
 160       --  Complex options with various specifiers
 161
 162       Opt := First (Component_Associations (Decl));
 163       while Present (Opt) loop
 164          Opt_Nam := First (Choices (Opt));
 165
 166          if Nkind (Opt_Nam) = N_Identifier
 167            and then Chars (Opt_Nam) = Option_Nam
 168          then
 169             return True;
 170          end if;
 171
 172          Next (Opt);
 173       end loop;
 174
 175       return False;
 176    end Has_Option;
 177
 178    ------------------------------
 179    -- Classification Functions --
 180    ------------------------------
 181
 182    function Is_Access_Object_Type               (Id : E) return B is
 183    begin
 184       return Is_Access_Type (Id)
 185         and then Ekind (Directly_Designated_Type (Id)) /= E_Subprogram_Type;
 186    end Is_Access_Object_Type;
 187
 188    function Is_Access_Type                      (Id : E) return B is
 189    begin
 190       return Ekind (Id) in Access_Kind;
 191    end Is_Access_Type;
 192
 193    function Is_Access_Protected_Subprogram_Type (Id : E) return B is
 194    begin
 195       return Ekind (Id) in Access_Protected_Kind;
 196    end Is_Access_Protected_Subprogram_Type;
 197
 198    function Is_Access_Subprogram_Type           (Id : E) return B is
 199    begin
 200       return Is_Access_Type (Id)
 201         and then Ekind (Directly_Designated_Type (Id)) = E_Subprogram_Type;
 202    end Is_Access_Subprogram_Type;
 203
 204    function Is_Aggregate_Type                   (Id : E) return B is
 205    begin
 206       return Ekind (Id) in Aggregate_Kind;
 207    end Is_Aggregate_Type;
 208
 209    function Is_Anonymous_Access_Type            (Id : E) return B is
 210    begin
 211       return Ekind (Id) in Anonymous_Access_Kind;
 212    end Is_Anonymous_Access_Type;
 213
 214    function Is_Array_Type                       (Id : E) return B is
 215    begin
 216       return Ekind (Id) in Array_Kind;
 217    end Is_Array_Type;
 218
 219    function Is_Assignable                       (Id : E) return B is
 220    begin
 221       return Ekind (Id) in Assignable_Kind;
 222    end Is_Assignable;
 223
 224    function Is_Class_Wide_Type                  (Id : E) return B is
 225    begin
 226       return Ekind (Id) in Class_Wide_Kind;
 227    end Is_Class_Wide_Type;
 228
 229    function Is_Composite_Type                   (Id : E) return B is
 230    begin
 231       return Ekind (Id) in Composite_Kind;
 232    end Is_Composite_Type;
 233
 234    function Is_Concurrent_Body                  (Id : E) return B is
 235    begin
 236       return Ekind (Id) in Concurrent_Body_Kind;
 237    end Is_Concurrent_Body;
 238
 239    function Is_Concurrent_Type                  (Id : E) return B is
 240    begin
 241       return Ekind (Id) in Concurrent_Kind;
 242    end Is_Concurrent_Type;
 243
 244    function Is_Decimal_Fixed_Point_Type         (Id : E) return B is
 245    begin
 246       return Ekind (Id) in Decimal_Fixed_Point_Kind;
 247    end Is_Decimal_Fixed_Point_Type;
 248
 249    function Is_Digits_Type                      (Id : E) return B is
 250    begin
 251       return Ekind (Id) in Digits_Kind;
 252    end Is_Digits_Type;
 253
 254    function Is_Discrete_Or_Fixed_Point_Type     (Id : E) return B is
 255    begin
 256       return Ekind (Id) in Discrete_Or_Fixed_Point_Kind;
 257    end Is_Discrete_Or_Fixed_Point_Type;
 258
 259    function Is_Discrete_Type                    (Id : E) return B is
 260    begin
 261       return Ekind (Id) in Discrete_Kind;
 262    end Is_Discrete_Type;
 263
 264    function Is_Elementary_Type                  (Id : E) return B is
 265    begin
 266       return Ekind (Id) in Elementary_Kind;
 267    end Is_Elementary_Type;
 268
 269    function Is_Entry                            (Id : E) return B is
 270    begin
 271       return Ekind (Id) in Entry_Kind;
 272    end Is_Entry;
 273
 274    function Is_Enumeration_Type                 (Id : E) return B is
 275    begin
 276       return Ekind (Id) in Enumeration_Kind;
 277    end Is_Enumeration_Type;
 278
 279    function Is_Fixed_Point_Type                 (Id : E) return B is
 280    begin
 281       return Ekind (Id) in Fixed_Point_Kind;
 282    end Is_Fixed_Point_Type;
 283
 284    function Is_Floating_Point_Type              (Id : E) return B is
 285    begin
 286       return Ekind (Id) in Float_Kind;
 287    end Is_Floating_Point_Type;
 288
 289    function Is_Formal                           (Id : E) return B is
 290    begin
 291       return Ekind (Id) in Formal_Kind;
 292    end Is_Formal;
 293
 294    function Is_Formal_Object                    (Id : E) return B is
 295    begin
 296       return Ekind (Id) in Formal_Object_Kind;
 297    end Is_Formal_Object;
 298
 299    function Is_Generic_Subprogram               (Id : E) return B is
 300    begin
 301       return Ekind (Id) in Generic_Subprogram_Kind;
 302    end Is_Generic_Subprogram;
 303
 304    function Is_Generic_Unit                     (Id : E) return B is
 305    begin
 306       return Ekind (Id) in Generic_Unit_Kind;
 307    end Is_Generic_Unit;
 308
 309    function Is_Ghost_Entity                     (Id : E) return Boolean is
 310    begin
 311       return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id);
 312    end Is_Ghost_Entity;
 313
 314    function Is_Incomplete_Or_Private_Type       (Id : E) return B is
 315    begin
 316       return Ekind (Id) in Incomplete_Or_Private_Kind;
 317    end Is_Incomplete_Or_Private_Type;
 318
 319    function Is_Incomplete_Type                  (Id : E) return B is
 320    begin
 321       return Ekind (Id) in Incomplete_Kind;
 322    end Is_Incomplete_Type;
 323
 324    function Is_Integer_Type                     (Id : E) return B is
 325    begin
 326       return Ekind (Id) in Integer_Kind;
 327    end Is_Integer_Type;
 328
 329    function Is_Modular_Integer_Type             (Id : E) return B is
 330    begin
 331       return Ekind (Id) in Modular_Integer_Kind;
 332    end Is_Modular_Integer_Type;
 333
 334    function Is_Named_Access_Type                (Id : E) return B is
 335    begin
 336       return Ekind (Id) in Named_Access_Kind;
 337    end Is_Named_Access_Type;
 338
 339    function Is_Named_Number                     (Id : E) return B is
 340    begin
 341       return Ekind (Id) in Named_Kind;
 342    end Is_Named_Number;
 343
 344    function Is_Numeric_Type                     (Id : E) return B is
 345    begin
 346       return Ekind (Id) in Numeric_Kind;
 347    end Is_Numeric_Type;
 348
 349    function Is_Object                           (Id : E) return B is
 350    begin
 351       return Ekind (Id) in Object_Kind;
 352    end Is_Object;
 353
 354    function Is_Ordinary_Fixed_Point_Type        (Id : E) return B is
 355    begin
 356       return Ekind (Id) in Ordinary_Fixed_Point_Kind;
 357    end Is_Ordinary_Fixed_Point_Type;
 358
 359    function Is_Overloadable                     (Id : E) return B is
 360    begin
 361       return Ekind (Id) in Overloadable_Kind;
 362    end Is_Overloadable;
 363
 364    function Is_Private_Type                     (Id : E) return B is
 365    begin
 366       return Ekind (Id) in Private_Kind;
 367    end Is_Private_Type;
 368
 369    function Is_Protected_Type                   (Id : E) return B is
 370    begin
 371       return Ekind (Id) in Protected_Kind;
 372    end Is_Protected_Type;
 373
 374    function Is_Real_Type                        (Id : E) return B is
 375    begin
 376       return Ekind (Id) in Real_Kind;
 377    end Is_Real_Type;
 378
 379    function Is_Record_Type                      (Id : E) return B is
 380    begin
 381       return Ekind (Id) in Record_Kind;
 382    end Is_Record_Type;
 383
 384    function Is_Scalar_Type                      (Id : E) return B is
 385    begin
 386       return Ekind (Id) in Scalar_Kind;
 387    end Is_Scalar_Type;
 388
 389    function Is_Signed_Integer_Type              (Id : E) return B is
 390    begin
 391       return Ekind (Id) in Signed_Integer_Kind;
 392    end Is_Signed_Integer_Type;
 393
 394    function Is_Subprogram                       (Id : E) return B is
 395    begin
 396       return Ekind (Id) in Subprogram_Kind;
 397    end Is_Subprogram;
 398
 399    function Is_Subprogram_Or_Entry              (Id : E) return B is
 400    begin
 401       return Ekind (Id) in Subprogram_Kind
 402                or else
 403              Ekind (Id) in Entry_Kind;
 404    end Is_Subprogram_Or_Entry;
 405
 406    function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is
 407    begin
 408       return Ekind (Id) in Subprogram_Kind
 409                or else
 410              Ekind (Id) in Generic_Subprogram_Kind;
 411    end Is_Subprogram_Or_Generic_Subprogram;
 412
 413    function Is_Task_Type                        (Id : E) return B is
 414    begin
 415       return Ekind (Id) in Task_Kind;
 416    end Is_Task_Type;
 417
 418    function Is_Type                             (Id : E) return B is
 419    begin
 420       return Ekind (Id) in Type_Kind;
 421    end Is_Type;
 422
 423    ------------------------------------------
 424    -- Type Representation Attribute Fields --
 425    ------------------------------------------
 426
 427    function Known_Alignment (E : Entity_Id) return B is
 428    begin
 429       --  For some reason, Empty is passed to this sometimes
 430
 431       return No (E) or else not Field_Is_Initial_Zero (E, F_Alignment);
 432    end Known_Alignment;
 433
 434    procedure Reinit_Alignment (Id : E) is
 435    begin
 436       Reinit_Field_To_Zero (Id, F_Alignment);
 437    end Reinit_Alignment;
 438
 439    procedure Copy_Alignment (To, From : E) is
 440    begin
 441       if Known_Alignment (From) then
 442          Set_Alignment (To, Alignment (From));
 443       else
 444          Reinit_Alignment (To);
 445       end if;
 446    end Copy_Alignment;
 447
 448    function Known_Component_Bit_Offset (E : Entity_Id) return B is
 449    begin
 450       return Present (Component_Bit_Offset (E));
 451    end Known_Component_Bit_Offset;
 452
 453    function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is
 454    begin
 455       return Known_Component_Bit_Offset (E)
 456         and then Component_Bit_Offset (E) >= Uint_0;
 457    end Known_Static_Component_Bit_Offset;
 458
 459    function Known_Component_Size (E : Entity_Id) return B is
 460    begin
 461       return Present (Component_Size (E));
 462    end Known_Component_Size;
 463
 464    function Known_Static_Component_Size (E : Entity_Id) return B is
 465    begin
 466       return Known_Component_Size (E) and then Component_Size (E) >= Uint_0;
 467    end Known_Static_Component_Size;
 468
 469    function Known_Esize (E : Entity_Id) return B is
 470    begin
 471       return Present (Esize (E));
 472    end Known_Esize;
 473
 474    function Known_Static_Esize (E : Entity_Id) return B is
 475    begin
 476       return Known_Esize (E)
 477         and then Esize (E) >= Uint_0
 478         and then not Is_Generic_Type (E);
 479    end Known_Static_Esize;
 480
 481    procedure Reinit_Esize (Id : E) is
 482    begin
 483       Reinit_Field_To_Zero (Id, F_Esize);
 484    end Reinit_Esize;
 485
 486    procedure Copy_Esize (To, From : E) is
 487    begin
 488       if Known_Esize (From) then
 489          Set_Esize (To, Esize (From));
 490       else
 491          Reinit_Esize (To);
 492       end if;
 493    end Copy_Esize;
 494
 495    function Known_Normalized_First_Bit (E : Entity_Id) return B is
 496    begin
 497       return Present (Normalized_First_Bit (E));
 498    end Known_Normalized_First_Bit;
 499
 500    function Known_Static_Normalized_First_Bit (E : Entity_Id) return B is
 501    begin
 502       return Known_Normalized_First_Bit (E)
 503         and then Normalized_First_Bit (E) >= Uint_0;
 504    end Known_Static_Normalized_First_Bit;
 505
 506    function Known_Normalized_Position (E : Entity_Id) return B is
 507    begin
 508       return Present (Normalized_Position (E));
 509    end Known_Normalized_Position;
 510
 511    function Known_Static_Normalized_Position (E : Entity_Id) return B is
 512    begin
 513       return Known_Normalized_Position (E)
 514         and then Normalized_Position (E) >= Uint_0;
 515    end Known_Static_Normalized_Position;
 516
 517    function Known_RM_Size (E : Entity_Id) return B is
 518    begin
 519       return Present (RM_Size (E));
 520    end Known_RM_Size;
 521
 522    function Known_Static_RM_Size (E : Entity_Id) return B is
 523    begin
 524       return Known_RM_Size (E)
 525         and then RM_Size (E) >= Uint_0
 526         and then not Is_Generic_Type (E);
 527    end Known_Static_RM_Size;
 528
 529    procedure Reinit_RM_Size (Id : E) is
 530    begin
 531       Reinit_Field_To_Zero (Id, F_RM_Size);
 532    end Reinit_RM_Size;
 533
 534    procedure Copy_RM_Size (To, From : E) is
 535    begin
 536       if Known_RM_Size (From) then
 537          Set_RM_Size (To, RM_Size (From));
 538       else
 539          Reinit_RM_Size (To);
 540       end if;
 541    end Copy_RM_Size;
 542
 543    -------------------------------
 544    -- Reinit_Component_Location --
 545    -------------------------------
 546
 547    procedure Reinit_Component_Location (Id : E) is
 548    begin
 549       Set_Normalized_First_Bit (Id, No_Uint);
 550       Set_Component_Bit_Offset (Id, No_Uint);
 551       Reinit_Esize (Id);
 552       Set_Normalized_Position (Id, No_Uint);
 553    end Reinit_Component_Location;
 554
 555    ------------------------------
 556    -- Reinit_Object_Size_Align --
 557    ------------------------------
 558
 559    procedure Reinit_Object_Size_Align (Id : E) is
 560    begin
 561       Reinit_Esize (Id);
 562       Reinit_Alignment (Id);
 563    end Reinit_Object_Size_Align;
 564
 565    ---------------
 566    -- Init_Size --
 567    ---------------
 568
 569    procedure Init_Size (Id : E; V : Int) is
 570    begin
 571       pragma Assert (Is_Type (Id));
 572       pragma Assert (not Known_Esize (Id) or else Esize (Id) = V);
 573       pragma Assert (not Known_RM_Size (Id) or else RM_Size (Id) = V);
 574
 575       Set_Esize (Id, UI_From_Int (V));
 576       Set_RM_Size (Id, UI_From_Int (V));
 577    end Init_Size;
 578
 579    -----------------------
 580    -- Reinit_Size_Align --
 581    -----------------------
 582
 583    procedure Reinit_Size_Align (Id : E) is
 584    begin
 585       pragma Assert (Ekind (Id) in Type_Kind | E_Void);
 586       Reinit_Esize (Id);
 587       Reinit_RM_Size (Id);
 588       Reinit_Alignment (Id);
 589    end Reinit_Size_Align;
 590
 591    --------------------
 592    -- Address_Clause --
 593    --------------------
 594
 595    function Address_Clause (Id : E) return Node_Id is
 596    begin
 597       return Get_Attribute_Definition_Clause (Id, Attribute_Address);
 598    end Address_Clause;
 599
 600    ---------------
 601    -- Aft_Value --
 602    ---------------
 603
 604    function Aft_Value (Id : E) return U is
 605       Result    : Nat := 1;
 606       Delta_Val : Ureal := Delta_Value (Id);
 607    begin
 608       while Delta_Val < Ureal_Tenth loop
 609          Delta_Val := Delta_Val * Ureal_10;
 610          Result := Result + 1;
 611       end loop;
 612
 613       return UI_From_Int (Result);
 614    end Aft_Value;
 615
 616    ----------------------
 617    -- Alignment_Clause --
 618    ----------------------
 619
 620    function Alignment_Clause (Id : E) return Node_Id is
 621    begin
 622       return Get_Attribute_Definition_Clause (Id, Attribute_Alignment);
 623    end Alignment_Clause;
 624
 625    -------------------
 626    -- Append_Entity --
 627    -------------------
 628
 629    procedure Append_Entity (Id : Entity_Id; Scop : Entity_Id) is
 630       Last : constant Entity_Id := Last_Entity (Scop);
 631
 632    begin
 633       Set_Scope (Id, Scop);
 634       Set_Prev_Entity (Id, Empty);  --  Empty <-- Id
 635
 636       --  The entity chain is empty
 637
 638       if No (Last) then
 639          Set_First_Entity (Scop, Id);
 640
 641       --  Otherwise the entity chain has at least one element
 642
 643       else
 644          Link_Entities (Last, Id);  --  Last <-- Id, Last --> Id
 645       end if;
 646
 647       --  NOTE: The setting of the Next_Entity attribute of Id must happen
 648       --  here as opposed to at the beginning of the routine because doing
 649       --  so causes the binder to hang. It is not clear why ???
 650
 651       Set_Next_Entity (Id, Empty);  --  Id --> Empty
 652
 653       Set_Last_Entity (Scop, Id);
 654    end Append_Entity;
 655
 656    ---------------
 657    -- Base_Type --
 658    ---------------
 659
 660    function Base_Type (Id : E) return E is
 661    begin
 662       if Is_Base_Type (Id) then
 663          return Id;
 664       else
 665          pragma Assert (Is_Type (Id));
 666          return Etype (Id);
 667       end if;
 668    end Base_Type;
 669
 670    ----------------------
 671    -- Declaration_Node --
 672    ----------------------
 673
 674    function Declaration_Node (Id : E) return Node_Id is
 675       P : Node_Id;
 676
 677    begin
 678       if Ekind (Id) = E_Incomplete_Type
 679         and then Present (Full_View (Id))
 680       then
 681          P := Parent (Full_View (Id));
 682       else
 683          P := Parent (Id);
 684       end if;
 685
 686       while Nkind (P) in N_Selected_Component | N_Expanded_Name
 687         or else (Nkind (P) = N_Defining_Program_Unit_Name
 688                    and then Is_Child_Unit (Id))
 689       loop
 690          P := Parent (P);
 691       end loop;
 692
 693       if Is_Itype (Id)
 694         and then Nkind (P) not in
 695           N_Full_Type_Declaration | N_Subtype_Declaration
 696       then
 697          P := Empty;
 698       end if;
 699
 700       --  Declarations are sometimes removed by replacing them with other
 701       --  irrelevant nodes. For example, a declare expression can be turned
 702       --  into a literal by constant folding. In these cases we want to
 703       --  return Empty.
 704
 705       if Nkind (P) in
 706           N_Assignment_Statement
 707         | N_Integer_Literal
 708         | N_Procedure_Call_Statement
 709         | N_Subtype_Indication
 710         | N_Type_Conversion
 711       then
 712          P := Empty;
 713       end if;
 714
 715       --  The following Assert indicates what kinds of nodes can be returned;
 716       --  they are not all "declarations".
 717
 718       if Serious_Errors_Detected = 0 then
 719          pragma Assert
 720            (Nkind (P) in N_Is_Decl | N_Empty,
 721             "Declaration_Node incorrect kind: " & Node_Kind'Image (Nkind (P)));
 722       end if;
 723
 724       return P;
 725    end Declaration_Node;
 726
 727    ---------------------
 728    -- Designated_Type --
 729    ---------------------
 730
 731    function Designated_Type (Id : E) return E is
 732       Desig_Type : Entity_Id;
 733
 734    begin
 735       Desig_Type := Directly_Designated_Type (Id);
 736
 737       if No (Desig_Type) then
 738          pragma Assert (Error_Posted (Id));
 739          return Any_Type;
 740       end if;
 741
 742       if Is_Incomplete_Type (Desig_Type)
 743         and then Present (Full_View (Desig_Type))
 744       then
 745          return Full_View (Desig_Type);
 746       end if;
 747
 748       if Is_Class_Wide_Type (Desig_Type)
 749         and then Is_Incomplete_Type (Etype (Desig_Type))
 750         and then Present (Full_View (Etype (Desig_Type)))
 751         and then Present (Class_Wide_Type (Full_View (Etype (Desig_Type))))
 752       then
 753          return Class_Wide_Type (Full_View (Etype (Desig_Type)));
 754       end if;
 755
 756       return Desig_Type;
 757    end Designated_Type;
 758
 759    ----------------------
 760    -- Entry_Index_Type --
 761    ----------------------
 762
 763    function Entry_Index_Type (Id : E) return E is
 764    begin
 765       pragma Assert (Ekind (Id) = E_Entry_Family);
 766       return Etype (Discrete_Subtype_Definition (Parent (Id)));
 767    end Entry_Index_Type;
 768
 769    ---------------------
 770    -- First_Component --
 771    ---------------------
 772
 773    function First_Component (Id : E) return Entity_Id is
 774       Comp_Id : Entity_Id;
 775
 776    begin
 777       pragma Assert
 778         (Is_Concurrent_Type (Id)
 779           or else Is_Incomplete_Or_Private_Type (Id)
 780           or else Is_Record_Type (Id));
 781
 782       Comp_Id := First_Entity (Id);
 783       while Present (Comp_Id) loop
 784          exit when Ekind (Comp_Id) = E_Component;
 785          Next_Entity (Comp_Id);
 786       end loop;
 787
 788       return Comp_Id;
 789    end First_Component;
 790
 791    -------------------------------------
 792    -- First_Component_Or_Discriminant --
 793    -------------------------------------
 794
 795    function First_Component_Or_Discriminant (Id : E) return Entity_Id is
 796       Comp_Id : Entity_Id;
 797
 798    begin
 799       pragma Assert
 800         (Is_Concurrent_Type (Id)
 801           or else Is_Incomplete_Or_Private_Type (Id)
 802           or else Is_Record_Type (Id)
 803           or else Has_Discriminants (Id));
 804
 805       Comp_Id := First_Entity (Id);
 806       while Present (Comp_Id) loop
 807          exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
 808          Next_Entity (Comp_Id);
 809       end loop;
 810
 811       return Comp_Id;
 812    end First_Component_Or_Discriminant;
 813
 814    ------------------
 815    -- First_Formal --
 816    ------------------
 817
 818    function First_Formal (Id : E) return Entity_Id is
 819       Formal : Entity_Id;
 820
 821    begin
 822       pragma Assert
 823         (Is_Generic_Subprogram (Id)
 824            or else Is_Overloadable (Id)
 825            or else Ekind (Id) in E_Entry_Family
 826                                | E_Subprogram_Body
 827                                | E_Subprogram_Type);
 828
 829       if Ekind (Id) = E_Enumeration_Literal then
 830          return Empty;
 831
 832       else
 833          Formal := First_Entity (Id);
 834
 835          --  Deal with the common, non-generic case first
 836
 837          if No (Formal) or else Is_Formal (Formal) then
 838             return Formal;
 839          end if;
 840
 841          --  The first/next entity chain of a generic subprogram contains all
 842          --  generic formal parameters, followed by the formal parameters.
 843
 844          if Is_Generic_Subprogram (Id) then
 845             while Present (Formal) and then not Is_Formal (Formal) loop
 846                Next_Entity (Formal);
 847             end loop;
 848             return Formal;
 849          else
 850             return Empty;
 851          end if;
 852       end if;
 853    end First_Formal;
 854
 855    ------------------------------
 856    -- First_Formal_With_Extras --
 857    ------------------------------
 858
 859    function First_Formal_With_Extras (Id : E) return Entity_Id is
 860       Formal : Entity_Id;
 861
 862    begin
 863       pragma Assert
 864         (Is_Generic_Subprogram (Id)
 865            or else Is_Overloadable (Id)
 866            or else Ekind (Id) in E_Entry_Family
 867                                | E_Subprogram_Body
 868                                | E_Subprogram_Type);
 869
 870       if Ekind (Id) = E_Enumeration_Literal then
 871          return Empty;
 872
 873       else
 874          Formal := First_Entity (Id);
 875
 876          --  The first/next entity chain of a generic subprogram contains all
 877          --  generic formal parameters, followed by the formal parameters. Go
 878          --  directly to the parameters by skipping the formal part.
 879
 880          if Is_Generic_Subprogram (Id) then
 881             while Present (Formal) and then not Is_Formal (Formal) loop
 882                Next_Entity (Formal);
 883             end loop;
 884          end if;
 885
 886          if Present (Formal) and then Is_Formal (Formal) then
 887             return Formal;
 888          else
 889             return Extra_Formals (Id);  -- Empty if no extra formals
 890          end if;
 891       end if;
 892    end First_Formal_With_Extras;
 893
 894    ---------------
 895    -- Float_Rep --
 896    ---------------
 897
 898    function Float_Rep (N : Entity_Id) return Float_Rep_Kind is
 899       pragma Unreferenced (N);
 900       pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last);
 901
 902       --  There is only one value, so we don't need to store it, see types.ads.
 903
 904       Val : constant Float_Rep_Kind := IEEE_Binary;
 905
 906    begin
 907       return Val;
 908    end Float_Rep;
 909
 910    -------------------------------------
 911    -- Get_Attribute_Definition_Clause --
 912    -------------------------------------
 913
 914    function Get_Attribute_Definition_Clause
 915      (E  : Entity_Id;
 916       Id : Attribute_Id) return Node_Id
 917    is
 918       N : Node_Id;
 919
 920    begin
 921       N := First_Rep_Item (E);
 922       while Present (N) loop
 923          if Nkind (N) = N_Attribute_Definition_Clause
 924            and then Get_Attribute_Id (Chars (N)) = Id
 925          then
 926             return N;
 927          else
 928             Next_Rep_Item (N);
 929          end if;
 930       end loop;
 931
 932       return Empty;
 933    end Get_Attribute_Definition_Clause;
 934
 935    ---------------------------
 936    -- Get_Class_Wide_Pragma --
 937    ---------------------------
 938
 939    function Get_Class_Wide_Pragma
 940      (E  : Entity_Id;
 941       Id : Pragma_Id) return Node_Id
 942     is
 943       Item  : Node_Id;
 944       Items : Node_Id;
 945
 946    begin
 947       Items := Contract (E);
 948
 949       if No (Items) then
 950          return Empty;
 951       end if;
 952
 953       Item := Pre_Post_Conditions (Items);
 954       while Present (Item) loop
 955          if Nkind (Item) = N_Pragma
 956            and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
 957            and then Class_Present (Item)
 958          then
 959             return Item;
 960          end if;
 961
 962          Item := Next_Pragma (Item);
 963       end loop;
 964
 965       return Empty;
 966    end Get_Class_Wide_Pragma;
 967
 968    -------------------
 969    -- Get_Full_View --
 970    -------------------
 971
 972    function Get_Full_View (T : Entity_Id) return Entity_Id is
 973    begin
 974       if Is_Incomplete_Type (T) and then Present (Full_View (T)) then
 975          return Full_View (T);
 976
 977       elsif Is_Class_Wide_Type (T)
 978         and then Is_Incomplete_Type (Root_Type (T))
 979         and then Present (Full_View (Root_Type (T)))
 980       then
 981          return Class_Wide_Type (Full_View (Root_Type (T)));
 982
 983       else
 984          return T;
 985       end if;
 986    end Get_Full_View;
 987
 988    ----------------
 989    -- Get_Pragma --
 990    ----------------
 991
 992    function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is
 993
 994       --  Classification pragmas
 995
 996       Is_CLS : constant Boolean :=
 997                  Id = Pragma_Abstract_State             or else
 998                  Id = Pragma_Attach_Handler             or else
 999                  Id = Pragma_Async_Readers              or else
1000                  Id = Pragma_Async_Writers              or else
1001                  Id = Pragma_Constant_After_Elaboration or else
1002                  Id = Pragma_Depends                    or else
1003                  Id = Pragma_Effective_Reads            or else
1004                  Id = Pragma_Effective_Writes           or else
1005                  Id = Pragma_Extensions_Visible         or else
1006                  Id = Pragma_Global                     or else
1007                  Id = Pragma_Initial_Condition          or else
1008                  Id = Pragma_Initializes                or else
1009                  Id = Pragma_Interrupt_Handler          or else
1010                  Id = Pragma_No_Caching                 or else
1011                  Id = Pragma_Part_Of                    or else
1012                  Id = Pragma_Refined_Depends            or else
1013                  Id = Pragma_Refined_Global             or else
1014                  Id = Pragma_Refined_State              or else
1015                  Id = Pragma_Volatile_Function;
1016
1017       --  Contract / subprogram variant / test case pragmas
1018
1019       Is_CTC : constant Boolean :=
1020                   Id = Pragma_Contract_Cases            or else
1021                   Id = Pragma_Subprogram_Variant        or else
1022                   Id = Pragma_Test_Case;
1023
1024       --  Pre / postcondition pragmas
1025
1026       Is_PPC : constant Boolean :=
1027                   Id = Pragma_Precondition              or else
1028                   Id = Pragma_Postcondition             or else
1029                   Id = Pragma_Refined_Post;
1030
1031       In_Contract : constant Boolean := Is_CLS or Is_CTC or Is_PPC;
1032
1033       Item  : Node_Id;
1034       Items : Node_Id;
1035
1036    begin
1037       --  Handle pragmas that appear in N_Contract nodes. Those have to be
1038       --  extracted from their specialized list.
1039
1040       if In_Contract then
1041          Items := Contract (E);
1042
1043          if No (Items) then
1044             return Empty;
1045
1046          elsif Is_CLS then
1047             Item := Classifications (Items);
1048
1049          elsif Is_CTC then
1050             Item := Contract_Test_Cases (Items);
1051
1052          else
1053             Item := Pre_Post_Conditions (Items);
1054          end if;
1055
1056       --  Regular pragmas
1057
1058       else
1059          Item := First_Rep_Item (E);
1060       end if;
1061
1062       while Present (Item) loop
1063          if Nkind (Item) = N_Pragma
1064            and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
1065          then
1066             return Item;
1067
1068          --  All nodes in N_Contract are chained using Next_Pragma
1069
1070          elsif In_Contract then
1071             Item := Next_Pragma (Item);
1072
1073          --  Regular pragmas
1074
1075          else
1076             Next_Rep_Item (Item);
1077          end if;
1078       end loop;
1079
1080       return Empty;
1081    end Get_Pragma;
1082
1083    --------------------------------------
1084    -- Get_Record_Representation_Clause --
1085    --------------------------------------
1086
1087    function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is
1088       N : Node_Id;
1089
1090    begin
1091       N := First_Rep_Item (E);
1092       while Present (N) loop
1093          if Nkind (N) = N_Record_Representation_Clause then
1094             return N;
1095          end if;
1096
1097          Next_Rep_Item (N);
1098       end loop;
1099
1100       return Empty;
1101    end Get_Record_Representation_Clause;
1102
1103    ------------------------
1104    -- Has_Attach_Handler --
1105    ------------------------
1106
1107    function Has_Attach_Handler (Id : E) return B is
1108       Ritem : Node_Id;
1109
1110    begin
1111       pragma Assert (Is_Protected_Type (Id));
1112
1113       Ritem := First_Rep_Item (Id);
1114       while Present (Ritem) loop
1115          if Nkind (Ritem) = N_Pragma
1116            and then Pragma_Name (Ritem) = Name_Attach_Handler
1117          then
1118             return True;
1119          else
1120             Next_Rep_Item (Ritem);
1121          end if;
1122       end loop;
1123
1124       return False;
1125    end Has_Attach_Handler;
1126
1127    -------------
1128    -- Has_DIC --
1129    -------------
1130
1131    function Has_DIC (Id : E) return B is
1132    begin
1133       return Has_Own_DIC (Id) or else Has_Inherited_DIC (Id);
1134    end Has_DIC;
1135
1136    -----------------
1137    -- Has_Entries --
1138    -----------------
1139
1140    function Has_Entries (Id : E) return B is
1141       Ent : Entity_Id;
1142
1143    begin
1144       pragma Assert (Is_Concurrent_Type (Id));
1145
1146       Ent := First_Entity (Id);
1147       while Present (Ent) loop
1148          if Is_Entry (Ent) then
1149             return True;
1150          end if;
1151
1152          Next_Entity (Ent);
1153       end loop;
1154
1155       return False;
1156    end Has_Entries;
1157
1158    ----------------------------
1159    -- Has_Foreign_Convention --
1160    ----------------------------
1161
1162    function Has_Foreign_Convention (Id : E) return B is
1163    begin
1164       --  While regular Intrinsics such as the Standard operators fit in the
1165       --  "Ada" convention, those with an Interface_Name materialize GCC
1166       --  builtin imports for which Ada special treatments shouldn't apply.
1167
1168       return Convention (Id) in Foreign_Convention
1169         or else (Convention (Id) = Convention_Intrinsic
1170                    and then Present (Interface_Name (Id)));
1171    end Has_Foreign_Convention;
1172
1173    ---------------------------
1174    -- Has_Interrupt_Handler --
1175    ---------------------------
1176
1177    function Has_Interrupt_Handler (Id : E) return B is
1178       Ritem : Node_Id;
1179
1180    begin
1181       pragma Assert (Is_Protected_Type (Id));
1182
1183       Ritem := First_Rep_Item (Id);
1184       while Present (Ritem) loop
1185          if Nkind (Ritem) = N_Pragma
1186            and then Pragma_Name (Ritem) = Name_Interrupt_Handler
1187          then
1188             return True;
1189          else
1190             Next_Rep_Item (Ritem);
1191          end if;
1192       end loop;
1193
1194       return False;
1195    end Has_Interrupt_Handler;
1196
1197    --------------------
1198    -- Has_Invariants --
1199    --------------------
1200
1201    function Has_Invariants (Id : E) return B is
1202    begin
1203       return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
1204    end Has_Invariants;
1205
1206    --------------------------
1207    -- Has_Limited_View --
1208    --------------------------
1209
1210    function Has_Limited_View (Id : E) return B is
1211    begin
1212       return Ekind (Id) = E_Package
1213         and then not Is_Generic_Instance (Id)
1214         and then Present (Limited_View (Id));
1215    end Has_Limited_View;
1216
1217    --------------------------
1218    -- Has_Non_Limited_View --
1219    --------------------------
1220
1221    function Has_Non_Limited_View (Id : E) return B is
1222    begin
1223       return (Ekind (Id) in Incomplete_Kind
1224                or else Ekind (Id) in Class_Wide_Kind
1225                or else Ekind (Id) = E_Abstract_State)
1226         and then Present (Non_Limited_View (Id));
1227    end Has_Non_Limited_View;
1228
1229    ---------------------------------
1230    -- Has_Non_Null_Abstract_State --
1231    ---------------------------------
1232
1233    function Has_Non_Null_Abstract_State (Id : E) return B is
1234    begin
1235       pragma Assert (Is_Package_Or_Generic_Package (Id));
1236
1237       return
1238         Present (Abstract_States (Id))
1239           and then
1240             not Is_Null_State (Node (First_Elmt (Abstract_States (Id))));
1241    end Has_Non_Null_Abstract_State;
1242
1243    -------------------------------------
1244    -- Has_Non_Null_Visible_Refinement --
1245    -------------------------------------
1246
1247    function Has_Non_Null_Visible_Refinement (Id : E) return B is
1248       Constits : Elist_Id;
1249
1250    begin
1251       --  "Refinement" is a concept applicable only to abstract states
1252
1253       pragma Assert (Ekind (Id) = E_Abstract_State);
1254       Constits := Refinement_Constituents (Id);
1255
1256       --  A partial refinement is always non-null. For a full refinement to be
1257       --  non-null, the first constituent must be anything other than null.
1258
1259       return
1260         Has_Partial_Visible_Refinement (Id)
1261           or else (Has_Visible_Refinement (Id)
1262                     and then Present (Constits)
1263                     and then Nkind (Node (First_Elmt (Constits))) /= N_Null);
1264    end Has_Non_Null_Visible_Refinement;
1265
1266    -----------------------------
1267    -- Has_Null_Abstract_State --
1268    -----------------------------
1269
1270    function Has_Null_Abstract_State (Id : E) return B is
1271       pragma Assert (Is_Package_Or_Generic_Package (Id));
1272
1273       States : constant Elist_Id := Abstract_States (Id);
1274
1275    begin
1276       --  Check first available state of related package. A null abstract
1277       --  state always appears as the sole element of the state list.
1278
1279       return
1280         Present (States)
1281           and then Is_Null_State (Node (First_Elmt (States)));
1282    end Has_Null_Abstract_State;
1283
1284    ---------------------------------
1285    -- Has_Null_Visible_Refinement --
1286    ---------------------------------
1287
1288    function Has_Null_Visible_Refinement (Id : E) return B is
1289       Constits : Elist_Id;
1290
1291    begin
1292       --  "Refinement" is a concept applicable only to abstract states
1293
1294       pragma Assert (Ekind (Id) = E_Abstract_State);
1295       Constits := Refinement_Constituents (Id);
1296
1297       --  For a refinement to be null, the state's sole constituent must be a
1298       --  null.
1299
1300       return
1301         Has_Visible_Refinement (Id)
1302           and then Present (Constits)
1303           and then Nkind (Node (First_Elmt (Constits))) = N_Null;
1304    end Has_Null_Visible_Refinement;
1305
1306    --------------------
1307    -- Has_Unmodified --
1308    --------------------
1309
1310    function Has_Unmodified (E : Entity_Id) return Boolean is
1311    begin
1312       if Has_Pragma_Unmodified (E) then
1313          return True;
1314       elsif Warnings_Off (E) then
1315          Set_Warnings_Off_Used_Unmodified (E);
1316          return True;
1317       else
1318          return False;
1319       end if;
1320    end Has_Unmodified;
1321
1322    ---------------------
1323    -- Has_Unreferenced --
1324    ---------------------
1325
1326    function Has_Unreferenced (E : Entity_Id) return Boolean is
1327    begin
1328       if Has_Pragma_Unreferenced (E) then
1329          return True;
1330       elsif Warnings_Off (E) then
1331          Set_Warnings_Off_Used_Unreferenced (E);
1332          return True;
1333       else
1334          return False;
1335       end if;
1336    end Has_Unreferenced;
1337
1338    ----------------------
1339    -- Has_Warnings_Off --
1340    ----------------------
1341
1342    function Has_Warnings_Off (E : Entity_Id) return Boolean is
1343    begin
1344       if Warnings_Off (E) then
1345          Set_Warnings_Off_Used (E);
1346          return True;
1347       else
1348          return False;
1349       end if;
1350    end Has_Warnings_Off;
1351
1352    ------------------------------
1353    -- Implementation_Base_Type --
1354    ------------------------------
1355
1356    function Implementation_Base_Type (Id : E) return E is
1357       Bastyp : Entity_Id;
1358       Imptyp : Entity_Id;
1359
1360    begin
1361       Bastyp := Base_Type (Id);
1362
1363       if Is_Incomplete_Or_Private_Type (Bastyp) then
1364          Imptyp := Underlying_Type (Bastyp);
1365
1366          --  If we have an implementation type, then just return it,
1367          --  otherwise we return the Base_Type anyway. This can only
1368          --  happen in error situations and should avoid some error bombs.
1369
1370          if Present (Imptyp) then
1371             return Base_Type (Imptyp);
1372          else
1373             return Bastyp;
1374          end if;
1375
1376       else
1377          return Bastyp;
1378       end if;
1379    end Implementation_Base_Type;
1380
1381    -------------------------
1382    -- Invariant_Procedure --
1383    -------------------------
1384
1385    function Invariant_Procedure (Id : E) return Entity_Id is
1386       Subp_Elmt : Elmt_Id;
1387       Subp_Id   : Entity_Id;
1388       Subps     : Elist_Id;
1389
1390    begin
1391       pragma Assert (Is_Type (Id));
1392
1393       Subps := Subprograms_For_Type (Base_Type (Id));
1394
1395       if Present (Subps) then
1396          Subp_Elmt := First_Elmt (Subps);
1397          while Present (Subp_Elmt) loop
1398             Subp_Id := Node (Subp_Elmt);
1399
1400             if Is_Invariant_Procedure (Subp_Id) then
1401                return Subp_Id;
1402             end if;
1403
1404             Next_Elmt (Subp_Elmt);
1405          end loop;
1406       end if;
1407
1408       return Empty;
1409    end Invariant_Procedure;
1410
1411    ------------------
1412    -- Is_Base_Type --
1413    ------------------
1414
1415    --  Global flag table allowing rapid computation of this function
1416
1417    Entity_Is_Base_Type : constant array (Entity_Kind) of Boolean :=
1418      (E_Enumeration_Subtype          |
1419       E_Incomplete_Subtype           |
1420       E_Signed_Integer_Subtype       |
1421       E_Modular_Integer_Subtype      |
1422       E_Floating_Point_Subtype       |
1423       E_Ordinary_Fixed_Point_Subtype |
1424       E_Decimal_Fixed_Point_Subtype  |
1425       E_Array_Subtype                |
1426       E_Record_Subtype               |
1427       E_Private_Subtype              |
1428       E_Record_Subtype_With_Private  |
1429       E_Limited_Private_Subtype      |
1430       E_Access_Subtype               |
1431       E_Protected_Subtype            |
1432       E_Task_Subtype                 |
1433       E_String_Literal_Subtype       |
1434       E_Class_Wide_Subtype           => False,
1435       others                         => True);
1436
1437    function Is_Base_Type (Id : E) return Boolean is
1438    begin
1439       return Entity_Is_Base_Type (Ekind (Id));
1440    end Is_Base_Type;
1441
1442    ---------------------
1443    -- Is_Boolean_Type --
1444    ---------------------
1445
1446    function Is_Boolean_Type (Id : E) return B is
1447    begin
1448       return Root_Type (Id) = Standard_Boolean;
1449    end Is_Boolean_Type;
1450
1451    ------------------------
1452    -- Is_Constant_Object --
1453    ------------------------
1454
1455    function Is_Constant_Object (Id : E) return B is
1456    begin
1457       return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter;
1458    end Is_Constant_Object;
1459
1460    -------------------
1461    -- Is_Controlled --
1462    -------------------
1463
1464    function Is_Controlled (Id : E) return B is
1465    begin
1466       return Is_Controlled_Active (Id) and then not Disable_Controlled (Id);
1467    end Is_Controlled;
1468
1469    --------------------
1470    -- Is_Discriminal --
1471    --------------------
1472
1473    function Is_Discriminal (Id : E) return B is
1474    begin
1475       return Ekind (Id) in E_Constant | E_In_Parameter
1476                and then Present (Discriminal_Link (Id));
1477    end Is_Discriminal;
1478
1479    ----------------------
1480    -- Is_Dynamic_Scope --
1481    ----------------------
1482
1483    function Is_Dynamic_Scope (Id : E) return B is
1484    begin
1485       return Ekind (Id) in E_Block
1486       --  Including an E_Block that came from an N_Expression_With_Actions
1487                          | E_Entry
1488                          | E_Entry_Family
1489                          | E_Function
1490                          | E_Procedure
1491                          | E_Return_Statement
1492                          | E_Subprogram_Body
1493                          | E_Task_Type
1494           or else
1495         (Ekind (Id) = E_Limited_Private_Type
1496           and then Present (Full_View (Id))
1497           and then Ekind (Full_View (Id)) = E_Task_Type);
1498    end Is_Dynamic_Scope;
1499
1500    --------------------
1501    -- Is_Entity_Name --
1502    --------------------
1503
1504    function Is_Entity_Name (N : Node_Id) return Boolean is
1505       Kind : constant Node_Kind := Nkind (N);
1506
1507    begin
1508       --  Identifiers, operator symbols, expanded names are entity names
1509
1510       return Kind = N_Identifier
1511         or else Kind = N_Operator_Symbol
1512         or else Kind = N_Expanded_Name
1513
1514       --  Attribute references are entity names if they refer to an entity.
1515       --  Note that we don't do this by testing for the presence of the
1516       --  Entity field in the N_Attribute_Reference node, since it may not
1517       --  have been set yet.
1518
1519         or else (Kind = N_Attribute_Reference
1520                   and then Is_Entity_Attribute_Name (Attribute_Name (N)));
1521    end Is_Entity_Name;
1522
1523    ---------------------------
1524    -- Is_Elaboration_Target --
1525    ---------------------------
1526
1527    function Is_Elaboration_Target (Id : E) return Boolean is
1528    begin
1529       return
1530         Ekind (Id) in E_Constant | E_Package | E_Variable
1531           or else Is_Entry        (Id)
1532           or else Is_Generic_Unit (Id)
1533           or else Is_Subprogram   (Id)
1534           or else Is_Task_Type    (Id);
1535    end Is_Elaboration_Target;
1536
1537    -----------------------
1538    -- Is_External_State --
1539    -----------------------
1540
1541    function Is_External_State (Id : E) return B is
1542    begin
1543       --  To qualify, the abstract state must appear with option "external" or
1544       --  "synchronous" (SPARK RM 7.1.4(7) and (9)).
1545
1546       return
1547         Ekind (Id) = E_Abstract_State
1548           and then (Has_Option (Id, Name_External)
1549                       or else
1550                     Has_Option (Id, Name_Synchronous));
1551    end Is_External_State;
1552
1553    ------------------
1554    -- Is_Finalizer --
1555    ------------------
1556
1557    function Is_Finalizer (Id : E) return B is
1558    begin
1559       return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
1560    end Is_Finalizer;
1561
1562    ----------------------
1563    -- Is_Full_Access --
1564    ----------------------
1565
1566    function Is_Full_Access (Id : E) return B is
1567    begin
1568       return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
1569    end Is_Full_Access;
1570
1571    -------------------
1572    -- Is_Null_State --
1573    -------------------
1574
1575    function Is_Null_State (Id : E) return B is
1576    begin
1577       return
1578         Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null;
1579    end Is_Null_State;
1580
1581    -----------------------------------
1582    -- Is_Package_Or_Generic_Package --
1583    -----------------------------------
1584
1585    function Is_Package_Or_Generic_Package (Id : E) return B is
1586    begin
1587       return Ekind (Id) in E_Generic_Package | E_Package;
1588    end Is_Package_Or_Generic_Package;
1589
1590    ---------------------
1591    -- Is_Packed_Array --
1592    ---------------------
1593
1594    function Is_Packed_Array (Id : E) return B is
1595    begin
1596       return Is_Array_Type (Id) and then Is_Packed (Id);
1597    end Is_Packed_Array;
1598
1599    ---------------
1600    -- Is_Prival --
1601    ---------------
1602
1603    function Is_Prival (Id : E) return B is
1604    begin
1605       return Ekind (Id) in E_Constant | E_Variable
1606                and then Present (Prival_Link (Id));
1607    end Is_Prival;
1608
1609    ----------------------------
1610    -- Is_Protected_Component --
1611    ----------------------------
1612
1613    function Is_Protected_Component (Id : E) return B is
1614    begin
1615       return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id));
1616    end Is_Protected_Component;
1617
1618    ----------------------------
1619    -- Is_Protected_Interface --
1620    ----------------------------
1621
1622    function Is_Protected_Interface (Id : E) return B is
1623       Typ : constant Entity_Id := Base_Type (Id);
1624    begin
1625       if not Is_Interface (Typ) then
1626          return False;
1627       elsif Is_Class_Wide_Type (Typ) then
1628          return Is_Protected_Interface (Etype (Typ));
1629       else
1630          return Protected_Present (Type_Definition (Parent (Typ)));
1631       end if;
1632    end Is_Protected_Interface;
1633
1634    ------------------------------
1635    -- Is_Protected_Record_Type --
1636    ------------------------------
1637
1638    function Is_Protected_Record_Type (Id : E) return B is
1639    begin
1640       return
1641         Is_Concurrent_Record_Type (Id)
1642           and then Is_Protected_Type (Corresponding_Concurrent_Type (Id));
1643    end Is_Protected_Record_Type;
1644
1645    -------------------------------------
1646    -- Is_Relaxed_Initialization_State --
1647    -------------------------------------
1648
1649    function Is_Relaxed_Initialization_State (Id : E) return B is
1650    begin
1651       --  To qualify, the abstract state must appear with simple option
1652       --  "Relaxed_Initialization" (SPARK RM 6.10).
1653
1654       return
1655         Ekind (Id) = E_Abstract_State
1656           and then Has_Option (Id, Name_Relaxed_Initialization);
1657    end Is_Relaxed_Initialization_State;
1658
1659    --------------------------------
1660    -- Is_Standard_Character_Type --
1661    --------------------------------
1662
1663    function Is_Standard_Character_Type (Id : E) return B is
1664    begin
1665       return Is_Type (Id)
1666         and then Root_Type (Id) in Standard_Character
1667                                  | Standard_Wide_Character
1668                                  | Standard_Wide_Wide_Character;
1669    end Is_Standard_Character_Type;
1670
1671    -----------------------------
1672    -- Is_Standard_String_Type --
1673    -----------------------------
1674
1675    function Is_Standard_String_Type (Id : E) return B is
1676    begin
1677       return Is_Type (Id)
1678         and then Root_Type (Id) in Standard_String
1679                                  | Standard_Wide_String
1680                                  | Standard_Wide_Wide_String;
1681    end Is_Standard_String_Type;
1682
1683    --------------------
1684    -- Is_String_Type --
1685    --------------------
1686
1687    function Is_String_Type (Id : E) return B is
1688    begin
1689       return Is_Array_Type (Id)
1690         and then Id /= Any_Composite
1691         and then Number_Dimensions (Id) = 1
1692         and then Is_Character_Type (Component_Type (Id));
1693    end Is_String_Type;
1694
1695    -------------------------------
1696    -- Is_Synchronized_Interface --
1697    -------------------------------
1698
1699    function Is_Synchronized_Interface (Id : E) return B is
1700       Typ : constant Entity_Id := Base_Type (Id);
1701
1702    begin
1703       if not Is_Interface (Typ) then
1704          return False;
1705
1706       elsif Is_Class_Wide_Type (Typ) then
1707          return Is_Synchronized_Interface (Etype (Typ));
1708
1709       else
1710          return    Protected_Present    (Type_Definition (Parent (Typ)))
1711            or else Synchronized_Present (Type_Definition (Parent (Typ)))
1712            or else Task_Present         (Type_Definition (Parent (Typ)));
1713       end if;
1714    end Is_Synchronized_Interface;
1715
1716    ---------------------------
1717    -- Is_Synchronized_State --
1718    ---------------------------
1719
1720    function Is_Synchronized_State (Id : E) return B is
1721    begin
1722       --  To qualify, the abstract state must appear with simple option
1723       --  "synchronous" (SPARK RM 7.1.4(9)).
1724
1725       return
1726         Ekind (Id) = E_Abstract_State
1727           and then Has_Option (Id, Name_Synchronous);
1728    end Is_Synchronized_State;
1729
1730    -----------------------
1731    -- Is_Task_Interface --
1732    -----------------------
1733
1734    function Is_Task_Interface (Id : E) return B is
1735       Typ : constant Entity_Id := Base_Type (Id);
1736    begin
1737       if not Is_Interface (Typ) then
1738          return False;
1739       elsif Is_Class_Wide_Type (Typ) then
1740          return Is_Task_Interface (Etype (Typ));
1741       else
1742          return Task_Present (Type_Definition (Parent (Typ)));
1743       end if;
1744    end Is_Task_Interface;
1745
1746    -------------------------
1747    -- Is_Task_Record_Type --
1748    -------------------------
1749
1750    function Is_Task_Record_Type (Id : E) return B is
1751    begin
1752       return
1753         Is_Concurrent_Record_Type (Id)
1754           and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
1755    end Is_Task_Record_Type;
1756
1757    ------------------------
1758    -- Is_Wrapper_Package --
1759    ------------------------
1760
1761    function Is_Wrapper_Package (Id : E) return B is
1762    begin
1763       return Ekind (Id) = E_Package and then Present (Related_Instance (Id));
1764    end Is_Wrapper_Package;
1765
1766    -----------------
1767    -- Last_Formal --
1768    -----------------
1769
1770    function Last_Formal (Id : E) return Entity_Id is
1771       Formal : Entity_Id;
1772
1773    begin
1774       pragma Assert
1775         (Is_Overloadable (Id)
1776           or else Ekind (Id) in E_Entry_Family
1777                               | E_Subprogram_Body
1778                               | E_Subprogram_Type);
1779
1780       if Ekind (Id) = E_Enumeration_Literal then
1781          return Empty;
1782
1783       else
1784          Formal := First_Formal (Id);
1785
1786          if Present (Formal) then
1787             while Present (Next_Formal (Formal)) loop
1788                Next_Formal (Formal);
1789             end loop;
1790          end if;
1791
1792          return Formal;
1793       end if;
1794    end Last_Formal;
1795
1796    -------------------
1797    -- Link_Entities --
1798    -------------------
1799
1800    procedure Link_Entities (First, Second : Entity_Id) is
1801    begin
1802       if Present (Second) then
1803          Set_Prev_Entity (Second, First);  --  First <-- Second
1804       end if;
1805
1806       Set_Next_Entity (First, Second);     --  First --> Second
1807    end Link_Entities;
1808
1809    ------------------------
1810    -- Machine_Emax_Value --
1811    ------------------------
1812
1813    function Machine_Emax_Value (Id : E) return Uint is
1814       Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
1815
1816    begin
1817       case Float_Rep (Id) is
1818          when IEEE_Binary =>
1819             case Digs is
1820                when  1 ..  6 => return Uint_128;
1821                when  7 .. 15 => return 2**10;
1822                when 16 .. 33 => return 2**14;
1823                when others   => return No_Uint;
1824             end case;
1825       end case;
1826    end Machine_Emax_Value;
1827
1828    ------------------------
1829    -- Machine_Emin_Value --
1830    ------------------------
1831
1832    function Machine_Emin_Value (Id : E) return Uint is
1833    begin
1834       case Float_Rep (Id) is
1835          when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
1836       end case;
1837    end Machine_Emin_Value;
1838
1839    ----------------------------
1840    -- Machine_Mantissa_Value --
1841    ----------------------------
1842
1843    function Machine_Mantissa_Value (Id : E) return Uint is
1844       Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
1845
1846    begin
1847       case Float_Rep (Id) is
1848          when IEEE_Binary =>
1849             case Digs is
1850                when  1 ..  6 => return Uint_24;
1851                when  7 .. 15 => return UI_From_Int (53);
1852                when 16 .. 18 => return Uint_64;
1853                when 19 .. 33 => return UI_From_Int (113);
1854                when others   => return No_Uint;
1855             end case;
1856       end case;
1857    end Machine_Mantissa_Value;
1858
1859    -------------------------
1860    -- Machine_Radix_Value --
1861    -------------------------
1862
1863    function Machine_Radix_Value (Id : E) return U is
1864    begin
1865       case Float_Rep (Id) is
1866          when IEEE_Binary =>
1867             return Uint_2;
1868       end case;
1869    end Machine_Radix_Value;
1870
1871    ----------------------
1872    -- Model_Emin_Value --
1873    ----------------------
1874
1875    function Model_Emin_Value (Id : E) return Uint is
1876    begin
1877       return Machine_Emin_Value (Id);
1878    end Model_Emin_Value;
1879
1880    -------------------------
1881    -- Model_Epsilon_Value --
1882    -------------------------
1883
1884    function Model_Epsilon_Value (Id : E) return Ureal is
1885       Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
1886    begin
1887       return Radix ** (1 - Model_Mantissa_Value (Id));
1888    end Model_Epsilon_Value;
1889
1890    --------------------------
1891    -- Model_Mantissa_Value --
1892    --------------------------
1893
1894    function Model_Mantissa_Value (Id : E) return Uint is
1895    begin
1896       return Machine_Mantissa_Value (Id);
1897    end Model_Mantissa_Value;
1898
1899    -----------------------
1900    -- Model_Small_Value --
1901    -----------------------
1902
1903    function Model_Small_Value (Id : E) return Ureal is
1904       Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
1905    begin
1906       return Radix ** (Model_Emin_Value (Id) - 1);
1907    end Model_Small_Value;
1908
1909    --------------------
1910    -- Next_Component --
1911    --------------------
1912
1913    function Next_Component (Id : E) return Entity_Id is
1914       Comp_Id : Entity_Id;
1915
1916    begin
1917       Comp_Id := Next_Entity (Id);
1918       while Present (Comp_Id) loop
1919          exit when Ekind (Comp_Id) = E_Component;
1920          Next_Entity (Comp_Id);
1921       end loop;
1922
1923       return Comp_Id;
1924    end Next_Component;
1925
1926    ------------------------------------
1927    -- Next_Component_Or_Discriminant --
1928    ------------------------------------
1929
1930    function Next_Component_Or_Discriminant (Id : E) return Entity_Id is
1931       Comp_Id : Entity_Id;
1932
1933    begin
1934       Comp_Id := Next_Entity (Id);
1935       while Present (Comp_Id) loop
1936          exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
1937          Next_Entity (Comp_Id);
1938       end loop;
1939
1940       return Comp_Id;
1941    end Next_Component_Or_Discriminant;
1942
1943    -----------------------
1944    -- Next_Discriminant --
1945    -----------------------
1946
1947    --  This function actually implements both Next_Discriminant and
1948    --  Next_Stored_Discriminant by making sure that the Discriminant
1949    --  returned is of the same variety as Id.
1950
1951    function Next_Discriminant (Id : E) return Entity_Id is
1952
1953       --  Derived Tagged types with private extensions look like this...
1954
1955       --       E_Discriminant d1
1956       --       E_Discriminant d2
1957       --       E_Component    _tag
1958       --       E_Discriminant d1
1959       --       E_Discriminant d2
1960       --       ...
1961
1962       --  so it is critical not to go past the leading discriminants
1963
1964       D : Entity_Id := Id;
1965
1966    begin
1967       pragma Assert (Ekind (Id) = E_Discriminant);
1968
1969       loop
1970          Next_Entity (D);
1971          if No (D)
1972            or else (Ekind (D) /= E_Discriminant
1973                       and then not Is_Itype (D))
1974          then
1975             return Empty;
1976          end if;
1977
1978          exit when Ekind (D) = E_Discriminant
1979            and then (Is_Completely_Hidden (D) = Is_Completely_Hidden (Id));
1980       end loop;
1981
1982       return D;
1983    end Next_Discriminant;
1984
1985    -----------------
1986    -- Next_Formal --
1987    -----------------
1988
1989    function Next_Formal (Id : E) return Entity_Id is
1990       P : Entity_Id;
1991
1992    begin
1993       --  Follow the chain of declared entities as long as the kind of the
1994       --  entity corresponds to a formal parameter. Skip internal entities
1995       --  that may have been created for implicit subtypes, in the process
1996       --  of analyzing default expressions.
1997
1998       P := Id;
1999       loop
2000          Next_Entity (P);
2001
2002          if No (P) or else Is_Formal (P) then
2003             return P;
2004          elsif not Is_Internal (P) then
2005             return Empty;
2006          end if;
2007       end loop;
2008    end Next_Formal;
2009
2010    -----------------------------
2011    -- Next_Formal_With_Extras --
2012    -----------------------------
2013
2014    function Next_Formal_With_Extras (Id : E) return Entity_Id is
2015    begin
2016       if Present (Extra_Formal (Id)) then
2017          return Extra_Formal (Id);
2018       else
2019          return Next_Formal (Id);
2020       end if;
2021    end Next_Formal_With_Extras;
2022
2023    ----------------
2024    -- Next_Index --
2025    ----------------
2026
2027    function Next_Index (Id : N) return Node_Id is
2028    begin
2029       pragma Assert (Nkind (Id) in N_Is_Index);
2030       pragma Assert (No (Next (Id)) or else Nkind (Next (Id)) in N_Is_Index);
2031       return Next (Id);
2032    end Next_Index;
2033
2034    ------------------
2035    -- Next_Literal --
2036    ------------------
2037
2038    function Next_Literal (Id : E) return Entity_Id is
2039    begin
2040       pragma Assert (Nkind (Id) in N_Entity);
2041       return Next (Id);
2042    end Next_Literal;
2043
2044    ------------------------------
2045    -- Next_Stored_Discriminant --
2046    ------------------------------
2047
2048    function Next_Stored_Discriminant (Id : E) return Entity_Id is
2049    begin
2050       --  See comment in Next_Discriminant
2051
2052       return Next_Discriminant (Id);
2053    end Next_Stored_Discriminant;
2054
2055    -----------------------
2056    -- Number_Dimensions --
2057    -----------------------
2058
2059    function Number_Dimensions (Id : E) return Pos is
2060       N : Int;
2061       T : Node_Id;
2062
2063    begin
2064       if Ekind (Id) = E_String_Literal_Subtype then
2065          return 1;
2066
2067       else
2068          N := 0;
2069          T := First_Index (Id);
2070          while Present (T) loop
2071             N := N + 1;
2072             Next_Index (T);
2073          end loop;
2074
2075          return N;
2076       end if;
2077    end Number_Dimensions;
2078
2079    --------------------
2080    -- Number_Entries --
2081    --------------------
2082
2083    function Number_Entries (Id : E) return Nat is
2084       N   : Nat;
2085       Ent : Entity_Id;
2086
2087    begin
2088       pragma Assert (Is_Concurrent_Type (Id));
2089
2090       N := 0;
2091       Ent := First_Entity (Id);
2092       while Present (Ent) loop
2093          if Is_Entry (Ent) then
2094             N := N + 1;
2095          end if;
2096
2097          Next_Entity (Ent);
2098       end loop;
2099
2100       return N;
2101    end Number_Entries;
2102
2103    --------------------
2104    -- Number_Formals --
2105    --------------------
2106
2107    function Number_Formals (Id : E) return Pos is
2108       N      : Int;
2109       Formal : Entity_Id;
2110
2111    begin
2112       N := 0;
2113       Formal := First_Formal (Id);
2114       while Present (Formal) loop
2115          N := N + 1;
2116          Next_Formal (Formal);
2117       end loop;
2118
2119       return N;
2120    end Number_Formals;
2121
2122    ------------------------
2123    -- Object_Size_Clause --
2124    ------------------------
2125
2126    function Object_Size_Clause (Id : E) return Node_Id is
2127    begin
2128       return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size);
2129    end Object_Size_Clause;
2130
2131    --------------------
2132    -- Parameter_Mode --
2133    --------------------
2134
2135    function Parameter_Mode (Id : E) return Formal_Kind is
2136    begin
2137       return Ekind (Id);
2138    end Parameter_Mode;
2139
2140    -------------------
2141    -- DIC_Procedure --
2142    -------------------
2143
2144    function DIC_Procedure (Id : E) return Entity_Id is
2145       Subp_Elmt : Elmt_Id;
2146       Subp_Id   : Entity_Id;
2147       Subps     : Elist_Id;
2148
2149    begin
2150       pragma Assert (Is_Type (Id));
2151
2152       Subps := Subprograms_For_Type (Base_Type (Id));
2153
2154       if Present (Subps) then
2155          Subp_Elmt := First_Elmt (Subps);
2156          while Present (Subp_Elmt) loop
2157             Subp_Id := Node (Subp_Elmt);
2158
2159             --  Currently the flag Is_DIC_Procedure is set for both normal DIC
2160             --  check procedures as well as for partial DIC check procedures,
2161             --  and we don't have a flag for the partial procedures.
2162
2163             if Is_DIC_Procedure (Subp_Id)
2164               and then not Is_Partial_DIC_Procedure (Subp_Id)
2165             then
2166                return Subp_Id;
2167             end if;
2168
2169             Next_Elmt (Subp_Elmt);
2170          end loop;
2171       end if;
2172
2173       return Empty;
2174    end DIC_Procedure;
2175
2176    function Partial_DIC_Procedure (Id : E) return Entity_Id is
2177       Subp_Elmt : Elmt_Id;
2178       Subp_Id   : Entity_Id;
2179       Subps     : Elist_Id;
2180
2181    begin
2182       pragma Assert (Is_Type (Id));
2183
2184       Subps := Subprograms_For_Type (Base_Type (Id));
2185
2186       if Present (Subps) then
2187          Subp_Elmt := First_Elmt (Subps);
2188          while Present (Subp_Elmt) loop
2189             Subp_Id := Node (Subp_Elmt);
2190
2191             if Is_Partial_DIC_Procedure (Subp_Id) then
2192                return Subp_Id;
2193             end if;
2194
2195             Next_Elmt (Subp_Elmt);
2196          end loop;
2197       end if;
2198
2199       return Empty;
2200    end Partial_DIC_Procedure;
2201
2202    function Is_Partial_DIC_Procedure (Id : E) return B is
2203       Partial_DIC_Suffix : constant String := "Partial_DIC";
2204       DIC_Nam            : constant String := Get_Name_String (Chars (Id));
2205
2206    begin
2207       pragma Assert (Ekind (Id) in E_Function | E_Procedure);
2208
2209       --  Instead of adding a new Entity_Id flag (which are in short supply),
2210       --  we test the form of the subprogram name. When the node field and flag
2211       --  situation is eased, this should be replaced with a flag. ???
2212
2213       if DIC_Nam'Length > Partial_DIC_Suffix'Length
2214         and then
2215           DIC_Nam
2216             (DIC_Nam'Last - Partial_DIC_Suffix'Length + 1 .. DIC_Nam'Last) =
2217                Partial_DIC_Suffix
2218       then
2219          return True;
2220       else
2221          return False;
2222       end if;
2223    end Is_Partial_DIC_Procedure;
2224
2225    ---------------------------------
2226    -- Partial_Invariant_Procedure --
2227    ---------------------------------
2228
2229    function Partial_Invariant_Procedure (Id : E) return Entity_Id is
2230       Subp_Elmt : Elmt_Id;
2231       Subp_Id   : Entity_Id;
2232       Subps     : Elist_Id;
2233
2234    begin
2235       pragma Assert (Is_Type (Id));
2236
2237       Subps := Subprograms_For_Type (Base_Type (Id));
2238
2239       if Present (Subps) then
2240          Subp_Elmt := First_Elmt (Subps);
2241          while Present (Subp_Elmt) loop
2242             Subp_Id := Node (Subp_Elmt);
2243
2244             if Is_Partial_Invariant_Procedure (Subp_Id) then
2245                return Subp_Id;
2246             end if;
2247
2248             Next_Elmt (Subp_Elmt);
2249          end loop;
2250       end if;
2251
2252       return Empty;
2253    end Partial_Invariant_Procedure;
2254
2255    -------------------------------------
2256    -- Partial_Refinement_Constituents --
2257    -------------------------------------
2258
2259    function Partial_Refinement_Constituents (Id : E) return L is
2260       Constits : Elist_Id := No_Elist;
2261
2262       procedure Add_Usable_Constituents (Item : E);
2263       --  Add global item Item and/or its constituents to list Constits when
2264       --  they can be used in a global refinement within the current scope. The
2265       --  criteria are:
2266       --    1) If Item is an abstract state with full refinement visible, add
2267       --       its constituents.
2268       --    2) If Item is an abstract state with only partial refinement
2269       --       visible, add both Item and its constituents.
2270       --    3) If Item is an abstract state without a visible refinement, add
2271       --       it.
2272       --    4) If Id is not an abstract state, add it.
2273
2274       procedure Add_Usable_Constituents (List : Elist_Id);
2275       --  Apply Add_Usable_Constituents to every constituent in List
2276
2277       -----------------------------
2278       -- Add_Usable_Constituents --
2279       -----------------------------
2280
2281       procedure Add_Usable_Constituents (Item : E) is
2282       begin
2283          if Ekind (Item) = E_Abstract_State then
2284             if Has_Visible_Refinement (Item) then
2285                Add_Usable_Constituents (Refinement_Constituents (Item));
2286
2287             elsif Has_Partial_Visible_Refinement (Item) then
2288                Append_New_Elmt (Item, Constits);
2289                Add_Usable_Constituents (Part_Of_Constituents (Item));
2290
2291             else
2292                Append_New_Elmt (Item, Constits);
2293             end if;
2294
2295          else
2296             Append_New_Elmt (Item, Constits);
2297          end if;
2298       end Add_Usable_Constituents;
2299
2300       procedure Add_Usable_Constituents (List : Elist_Id) is
2301          Constit_Elmt : Elmt_Id;
2302       begin
2303          if Present (List) then
2304             Constit_Elmt := First_Elmt (List);
2305             while Present (Constit_Elmt) loop
2306                Add_Usable_Constituents (Node (Constit_Elmt));
2307                Next_Elmt (Constit_Elmt);
2308             end loop;
2309          end if;
2310       end Add_Usable_Constituents;
2311
2312    --  Start of processing for Partial_Refinement_Constituents
2313
2314    begin
2315       --  "Refinement" is a concept applicable only to abstract states
2316
2317       pragma Assert (Ekind (Id) = E_Abstract_State);
2318
2319       if Has_Visible_Refinement (Id) then
2320          Constits := Refinement_Constituents (Id);
2321
2322       --  A refinement may be partially visible when objects declared in the
2323       --  private part of a package are subject to a Part_Of indicator.
2324
2325       elsif Has_Partial_Visible_Refinement (Id) then
2326          Add_Usable_Constituents (Part_Of_Constituents (Id));
2327
2328       --  Function should only be called when full or partial refinement is
2329       --  visible.
2330
2331       else
2332          raise Program_Error;
2333       end if;
2334
2335       return Constits;
2336    end Partial_Refinement_Constituents;
2337
2338    ------------------------
2339    -- Predicate_Function --
2340    ------------------------
2341
2342    function Predicate_Function (Id : E) return Entity_Id is
2343       Subp_Elmt : Elmt_Id;
2344       Subp_Id   : Entity_Id;
2345       Subps     : Elist_Id;
2346       Typ       : Entity_Id;
2347
2348    begin
2349       pragma Assert (Is_Type (Id));
2350
2351       --  If type is private and has a completion, predicate may be defined on
2352       --  the full view.
2353
2354       if Is_Private_Type (Id)
2355          and then
2356            (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
2357          and then Present (Full_View (Id))
2358       then
2359          Typ := Full_View (Id);
2360
2361       elsif Ekind (Id) in E_Array_Subtype
2362                         | E_Record_Subtype
2363                         | E_Record_Subtype_With_Private
2364         and then Present (Predicated_Parent (Id))
2365       then
2366          Typ := Predicated_Parent (Id);
2367
2368       else
2369          Typ := Id;
2370       end if;
2371
2372       Subps := Subprograms_For_Type (Typ);
2373
2374       if Present (Subps) then
2375          Subp_Elmt := First_Elmt (Subps);
2376          while Present (Subp_Elmt) loop
2377             Subp_Id := Node (Subp_Elmt);
2378
2379             if Ekind (Subp_Id) = E_Function
2380               and then Is_Predicate_Function (Subp_Id)
2381             then
2382                return Subp_Id;
2383             end if;
2384
2385             Next_Elmt (Subp_Elmt);
2386          end loop;
2387       end if;
2388
2389       return Empty;
2390    end Predicate_Function;
2391
2392    -------------------------
2393    -- Present_In_Rep_Item --
2394    -------------------------
2395
2396    function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
2397       Ritem : Node_Id;
2398
2399    begin
2400       Ritem := First_Rep_Item (E);
2401
2402       while Present (Ritem) loop
2403          if Ritem = N then
2404             return True;
2405          end if;
2406
2407          Next_Rep_Item (Ritem);
2408       end loop;
2409
2410       return False;
2411    end Present_In_Rep_Item;
2412
2413    --------------------------
2414    -- Primitive_Operations --
2415    --------------------------
2416
2417    function Primitive_Operations (Id : E) return L is
2418    begin
2419       if Is_Concurrent_Type (Id) then
2420          if Present (Corresponding_Record_Type (Id)) then
2421             return Direct_Primitive_Operations
2422               (Corresponding_Record_Type (Id));
2423
2424          --  When expansion is disabled, the corresponding record type is
2425          --  absent, but if this is a tagged type with ancestors, or if the
2426          --  extension of prefixed calls for untagged types is enabled, then
2427          --  it may have associated primitive operations.
2428
2429          else
2430             return Direct_Primitive_Operations (Id);
2431          end if;
2432
2433       else
2434          return Direct_Primitive_Operations (Id);
2435       end if;
2436    end Primitive_Operations;
2437
2438    ---------------------
2439    -- Record_Rep_Item --
2440    ---------------------
2441
2442    procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
2443    begin
2444       Set_Next_Rep_Item (N, First_Rep_Item (E));
2445       Set_First_Rep_Item (E, N);
2446    end Record_Rep_Item;
2447
2448    -------------------
2449    -- Remove_Entity --
2450    -------------------
2451
2452    procedure Remove_Entity (Id : Entity_Id) is
2453       Next  : constant Entity_Id := Next_Entity (Id);
2454       Prev  : constant Entity_Id := Prev_Entity (Id);
2455       Scop  : constant Entity_Id := Scope (Id);
2456       First : constant Entity_Id := First_Entity (Scop);
2457       Last  : constant Entity_Id := Last_Entity  (Scop);
2458
2459    begin
2460       --  Eliminate any existing linkages from the entity
2461
2462       Set_Prev_Entity (Id, Empty);  --  Empty <-- Id
2463       Set_Next_Entity (Id, Empty);  --  Id --> Empty
2464
2465       --  The eliminated entity was the only element in the entity chain
2466
2467       if Id = First and then Id = Last then
2468          Set_First_Entity (Scop, Empty);
2469          Set_Last_Entity  (Scop, Empty);
2470
2471       --  The eliminated entity was the head of the entity chain
2472
2473       elsif Id = First then
2474          Set_First_Entity (Scop, Next);
2475          Set_Prev_Entity (Next, Empty);  --  Empty <-- First_Entity
2476
2477       --  The eliminated entity was the tail of the entity chain
2478
2479       elsif Id = Last then
2480          Set_Last_Entity (Scop, Prev);
2481          Set_Next_Entity (Prev, Empty);  --  Last_Entity --> Empty
2482
2483       --  Otherwise the eliminated entity comes from the middle of the entity
2484       --  chain.
2485
2486       else
2487          Link_Entities (Prev, Next);  --  Prev <-- Next, Prev --> Next
2488       end if;
2489    end Remove_Entity;
2490
2491    ---------------
2492    -- Root_Type --
2493    ---------------
2494
2495    function Root_Type (Id : E) return E is
2496       T, Etyp : Entity_Id;
2497
2498    begin
2499       pragma Assert (Nkind (Id) in N_Entity);
2500
2501       T := Base_Type (Id);
2502
2503       if Ekind (T) = E_Class_Wide_Type then
2504          return Etype (T);
2505
2506       --  Other cases
2507
2508       else
2509          loop
2510             Etyp := Etype (T);
2511
2512             if T = Etyp then
2513                return T;
2514
2515             --  Following test catches some error cases resulting from
2516             --  previous errors.
2517
2518             elsif No (Etyp) then
2519                Check_Error_Detected;
2520                return T;
2521
2522             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
2523                return T;
2524
2525             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
2526                return T;
2527             end if;
2528
2529             T := Etyp;
2530
2531             --  Return if there is a circularity in the inheritance chain. This
2532             --  happens in some error situations and we do not want to get
2533             --  stuck in this loop.
2534
2535             if T = Base_Type (Id) then
2536                return T;
2537             end if;
2538          end loop;
2539       end if;
2540    end Root_Type;
2541
2542    ---------------------
2543    -- Safe_Emax_Value --
2544    ---------------------
2545
2546    function Safe_Emax_Value (Id : E) return Uint is
2547    begin
2548       return Machine_Emax_Value (Id);
2549    end Safe_Emax_Value;
2550
2551    ----------------------
2552    -- Safe_First_Value --
2553    ----------------------
2554
2555    function Safe_First_Value (Id : E) return Ureal is
2556    begin
2557       return -Safe_Last_Value (Id);
2558    end Safe_First_Value;
2559
2560    ---------------------
2561    -- Safe_Last_Value --
2562    ---------------------
2563
2564    function Safe_Last_Value (Id : E) return Ureal is
2565       Radix       : constant Uint := Machine_Radix_Value (Id);
2566       Mantissa    : constant Uint := Machine_Mantissa_Value (Id);
2567       Emax        : constant Uint := Safe_Emax_Value (Id);
2568       Significand : constant Uint := Radix ** Mantissa - 1;
2569       Exponent    : constant Uint := Emax - Mantissa;
2570
2571    begin
2572       if Radix = 2 then
2573          return
2574            UR_From_Components
2575              (Num   => Significand * 2 ** (Exponent mod 4),
2576               Den   => -Exponent / 4,
2577               Rbase => 16);
2578       else
2579          return
2580            UR_From_Components
2581              (Num => Significand,
2582               Den => -Exponent,
2583               Rbase => 16);
2584       end if;
2585    end Safe_Last_Value;
2586
2587    -----------------
2588    -- Scope_Depth --
2589    -----------------
2590
2591    function Scope_Depth (Id : E) return Uint is
2592       Scop : Entity_Id;
2593
2594    begin
2595       Scop := Id;
2596       while Is_Record_Type (Scop) loop
2597          Scop := Scope (Scop);
2598       end loop;
2599
2600       return Scope_Depth_Value (Scop);
2601    end Scope_Depth;
2602
2603    function Scope_Depth_Default_0 (Id : E) return U is
2604    begin
2605       if Scope_Depth_Set (Id) then
2606          return Scope_Depth (Id);
2607
2608       else
2609          return Uint_0;
2610       end if;
2611    end Scope_Depth_Default_0;
2612
2613    ---------------------
2614    -- Scope_Depth_Set --
2615    ---------------------
2616
2617    function Scope_Depth_Set (Id : E) return B is
2618    begin
2619       return not Is_Record_Type (Id)
2620         and then not Field_Is_Initial_Zero (Id, F_Scope_Depth_Value);
2621       --  We can't call Scope_Depth_Value here, because Empty is not a valid
2622       --  value of type Uint.
2623    end Scope_Depth_Set;
2624
2625    --------------------
2626    -- Set_Convention --
2627    --------------------
2628
2629    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
2630    begin
2631       Set_Basic_Convention (E, Val);
2632
2633       if Ekind (E) in Access_Subprogram_Kind
2634         and then Has_Foreign_Convention (E)
2635       then
2636          Set_Can_Use_Internal_Rep (E, False);
2637       end if;
2638
2639       --  If E is an object, including a component, and the type of E is an
2640       --  anonymous access type with no convention set, then also set the
2641       --  convention of the anonymous access type. We do not do this for
2642       --  anonymous protected types, since protected types always have the
2643       --  default convention.
2644
2645       if Present (Etype (E))
2646         and then (Is_Object (E)
2647
2648                    --  Allow E_Void (happens for pragma Convention appearing
2649                    --  in the middle of a record applying to a component)
2650
2651                    or else Ekind (E) = E_Void)
2652       then
2653          declare
2654             Typ : constant Entity_Id := Etype (E);
2655
2656          begin
2657             if Ekind (Typ) in E_Anonymous_Access_Type
2658                             | E_Anonymous_Access_Subprogram_Type
2659               and then not Has_Convention_Pragma (Typ)
2660             then
2661                Set_Convention (Typ, Val);
2662                Set_Has_Convention_Pragma (Typ);
2663
2664                --  And for the access subprogram type, deal similarly with the
2665                --  designated E_Subprogram_Type, which is always internal.
2666
2667                if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
2668                   declare
2669                      Dtype : constant Entity_Id := Designated_Type (Typ);
2670                   begin
2671                      if Ekind (Dtype) = E_Subprogram_Type then
2672                         pragma Assert (not Has_Convention_Pragma (Dtype));
2673                         Set_Convention (Dtype, Val);
2674                         Set_Has_Convention_Pragma (Dtype);
2675                      end if;
2676                   end;
2677                end if;
2678             end if;
2679          end;
2680       end if;
2681    end Set_Convention;
2682
2683    -----------------------
2684    -- Set_DIC_Procedure --
2685    -----------------------
2686
2687    procedure Set_DIC_Procedure (Id : E; V : E) is
2688       Base_Typ  : Entity_Id;
2689       Subps     : Elist_Id;
2690
2691    begin
2692       pragma Assert (Is_Type (Id));
2693
2694       Base_Typ := Base_Type (Id);
2695       Subps    := Subprograms_For_Type (Base_Typ);
2696
2697       if No (Subps) then
2698          Subps := New_Elmt_List;
2699          Set_Subprograms_For_Type (Base_Typ, Subps);
2700       end if;
2701
2702       Prepend_Elmt (V, Subps);
2703    end Set_DIC_Procedure;
2704
2705    procedure Set_Partial_DIC_Procedure (Id : E; V : E) is
2706    begin
2707       Set_DIC_Procedure (Id, V);
2708    end Set_Partial_DIC_Procedure;
2709
2710    -------------------
2711    -- Set_Float_Rep --
2712    -------------------
2713
2714    procedure Set_Float_Rep
2715      (Ignore_N : Entity_Id; Ignore_Val : Float_Rep_Kind) is
2716    begin
2717       pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last);
2718       --  There is only one value, so we don't need to store it (see
2719       --  types.ads).
2720    end Set_Float_Rep;
2721
2722    -----------------------------
2723    -- Set_Invariant_Procedure --
2724    -----------------------------
2725
2726    procedure Set_Invariant_Procedure (Id : E; V : E) is
2727       Base_Typ  : Entity_Id;
2728       Subp_Elmt : Elmt_Id;
2729       Subp_Id   : Entity_Id;
2730       Subps     : Elist_Id;
2731
2732    begin
2733       pragma Assert (Is_Type (Id));
2734
2735       Base_Typ := Base_Type (Id);
2736       Subps    := Subprograms_For_Type (Base_Typ);
2737
2738       if No (Subps) then
2739          Subps := New_Elmt_List;
2740          Set_Subprograms_For_Type (Base_Typ, Subps);
2741       end if;
2742
2743       Subp_Elmt := First_Elmt (Subps);
2744       Prepend_Elmt (V, Subps);
2745
2746       --  Check for a duplicate invariant procedure
2747
2748       while Present (Subp_Elmt) loop
2749          Subp_Id := Node (Subp_Elmt);
2750
2751          if Is_Invariant_Procedure (Subp_Id) then
2752             raise Program_Error;
2753          end if;
2754
2755          Next_Elmt (Subp_Elmt);
2756       end loop;
2757    end Set_Invariant_Procedure;
2758
2759    -------------------------------------
2760    -- Set_Partial_Invariant_Procedure --
2761    -------------------------------------
2762
2763    procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
2764       Base_Typ  : Entity_Id;
2765       Subp_Elmt : Elmt_Id;
2766       Subp_Id   : Entity_Id;
2767       Subps     : Elist_Id;
2768
2769    begin
2770       pragma Assert (Is_Type (Id));
2771
2772       Base_Typ := Base_Type (Id);
2773       Subps    := Subprograms_For_Type (Base_Typ);
2774
2775       if No (Subps) then
2776          Subps := New_Elmt_List;
2777          Set_Subprograms_For_Type (Base_Typ, Subps);
2778       end if;
2779
2780       Subp_Elmt := First_Elmt (Subps);
2781       Prepend_Elmt (V, Subps);
2782
2783       --  Check for a duplicate partial invariant procedure
2784
2785       while Present (Subp_Elmt) loop
2786          Subp_Id := Node (Subp_Elmt);
2787
2788          if Is_Partial_Invariant_Procedure (Subp_Id) then
2789             raise Program_Error;
2790          end if;
2791
2792          Next_Elmt (Subp_Elmt);
2793       end loop;
2794    end Set_Partial_Invariant_Procedure;
2795
2796    ----------------------------
2797    -- Set_Predicate_Function --
2798    ----------------------------
2799
2800    procedure Set_Predicate_Function (Id : E; V : E) is
2801       Subp_Elmt : Elmt_Id;
2802       Subp_Id   : Entity_Id;
2803       Subps     : Elist_Id;
2804
2805    begin
2806       pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
2807
2808       Subps := Subprograms_For_Type (Id);
2809
2810       if No (Subps) then
2811          Subps := New_Elmt_List;
2812          Set_Subprograms_For_Type (Id, Subps);
2813       end if;
2814
2815       Subp_Elmt := First_Elmt (Subps);
2816       Prepend_Elmt (V, Subps);
2817
2818       --  Check for a duplicate predication function
2819
2820       while Present (Subp_Elmt) loop
2821          Subp_Id := Node (Subp_Elmt);
2822
2823          if Ekind (Subp_Id) = E_Function
2824            and then Is_Predicate_Function (Subp_Id)
2825          then
2826             raise Program_Error;
2827          end if;
2828
2829          Next_Elmt (Subp_Elmt);
2830       end loop;
2831    end Set_Predicate_Function;
2832
2833    -----------------
2834    -- Size_Clause --
2835    -----------------
2836
2837    function Size_Clause (Id : E) return Node_Id is
2838       Result : Node_Id := Get_Attribute_Definition_Clause (Id, Attribute_Size);
2839    begin
2840       if No (Result) then
2841          Result := Get_Attribute_Definition_Clause (Id, Attribute_Value_Size);
2842       end if;
2843
2844       return Result;
2845    end Size_Clause;
2846
2847    ------------------------
2848    -- Stream_Size_Clause --
2849    ------------------------
2850
2851    function Stream_Size_Clause (Id : E) return N is
2852    begin
2853       return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
2854    end Stream_Size_Clause;
2855
2856    ------------------
2857    -- Subtype_Kind --
2858    ------------------
2859
2860    function Subtype_Kind (K : Entity_Kind) return Entity_Kind is
2861       Kind : Entity_Kind;
2862
2863    begin
2864       case K is
2865          when Access_Kind =>
2866             Kind := E_Access_Subtype;
2867
2868          when E_Array_Subtype
2869             | E_Array_Type
2870          =>
2871             Kind := E_Array_Subtype;
2872
2873          when E_Class_Wide_Subtype
2874             | E_Class_Wide_Type
2875          =>
2876             Kind := E_Class_Wide_Subtype;
2877
2878          when E_Decimal_Fixed_Point_Subtype
2879             | E_Decimal_Fixed_Point_Type
2880          =>
2881             Kind := E_Decimal_Fixed_Point_Subtype;
2882
2883          when E_Ordinary_Fixed_Point_Subtype
2884             | E_Ordinary_Fixed_Point_Type
2885          =>
2886             Kind := E_Ordinary_Fixed_Point_Subtype;
2887
2888          when E_Private_Subtype
2889             | E_Private_Type
2890          =>
2891             Kind := E_Private_Subtype;
2892
2893          when E_Limited_Private_Subtype
2894             | E_Limited_Private_Type
2895          =>
2896             Kind := E_Limited_Private_Subtype;
2897
2898          when E_Record_Subtype_With_Private
2899             | E_Record_Type_With_Private
2900          =>
2901             Kind := E_Record_Subtype_With_Private;
2902
2903          when E_Record_Subtype
2904             | E_Record_Type
2905          =>
2906             Kind := E_Record_Subtype;
2907
2908          when Enumeration_Kind =>
2909             Kind := E_Enumeration_Subtype;
2910
2911          when E_Incomplete_Type =>
2912             Kind := E_Incomplete_Subtype;
2913
2914          when Float_Kind =>
2915             Kind := E_Floating_Point_Subtype;
2916
2917          when Signed_Integer_Kind =>
2918             Kind := E_Signed_Integer_Subtype;
2919
2920          when Modular_Integer_Kind =>
2921             Kind := E_Modular_Integer_Subtype;
2922
2923          when Protected_Kind =>
2924             Kind := E_Protected_Subtype;
2925
2926          when Task_Kind =>
2927             Kind := E_Task_Subtype;
2928
2929          when others =>
2930             raise Program_Error;
2931       end case;
2932
2933       return Kind;
2934    end Subtype_Kind;
2935
2936    ---------------------
2937    -- Type_High_Bound --
2938    ---------------------
2939
2940    function Type_High_Bound (Id : E) return N is
2941       Rng : constant Node_Id := Scalar_Range (Id);
2942    begin
2943       if Nkind (Rng) = N_Subtype_Indication then
2944          return High_Bound (Range_Expression (Constraint (Rng)));
2945       else
2946          return High_Bound (Rng);
2947       end if;
2948    end Type_High_Bound;
2949
2950    --------------------
2951    -- Type_Low_Bound --
2952    --------------------
2953
2954    function Type_Low_Bound (Id : E) return N is
2955       Rng : constant Node_Id := Scalar_Range (Id);
2956    begin
2957       if Nkind (Rng) = N_Subtype_Indication then
2958          return Low_Bound (Range_Expression (Constraint (Rng)));
2959       else
2960          return Low_Bound (Rng);
2961       end if;
2962    end Type_Low_Bound;
2963
2964    ---------------------
2965    -- Underlying_Type --
2966    ---------------------
2967
2968    function Underlying_Type (Id : E) return Entity_Id is
2969    begin
2970       --  For record_with_private the underlying type is always the direct full
2971       --  view. Never try to take the full view of the parent it does not make
2972       --  sense.
2973
2974       if Ekind (Id) = E_Record_Type_With_Private then
2975          return Full_View (Id);
2976
2977       --  If we have a class-wide type that comes from the limited view then we
2978       --  return the Underlying_Type of its nonlimited view.
2979
2980       elsif Ekind (Id) = E_Class_Wide_Type
2981         and then From_Limited_With (Id)
2982         and then Present (Non_Limited_View (Id))
2983       then
2984          return Underlying_Type (Non_Limited_View (Id));
2985
2986       elsif Ekind (Id) in Incomplete_Or_Private_Kind then
2987
2988          --  If we have an incomplete or private type with a full view, then we
2989          --  return the Underlying_Type of this full view.
2990
2991          if Present (Full_View (Id)) then
2992             if Id = Full_View (Id) then
2993
2994                --  Previous error in declaration
2995
2996                return Empty;
2997
2998             else
2999                return Underlying_Type (Full_View (Id));
3000             end if;
3001
3002          --  If we have a private type with an underlying full view, then we
3003          --  return the Underlying_Type of this underlying full view.
3004
3005          elsif Ekind (Id) in Private_Kind
3006            and then Present (Underlying_Full_View (Id))
3007          then
3008             return Underlying_Type (Underlying_Full_View (Id));
3009
3010          --  If we have an incomplete entity that comes from the limited view
3011          --  then we return the Underlying_Type of its nonlimited view.
3012
3013          elsif From_Limited_With (Id)
3014            and then Present (Non_Limited_View (Id))
3015          then
3016             return Underlying_Type (Non_Limited_View (Id));
3017
3018          --  Otherwise check for the case where we have a derived type or
3019          --  subtype, and if so get the Underlying_Type of the parent type.
3020
3021          elsif Etype (Id) /= Id then
3022             return Underlying_Type (Etype (Id));
3023
3024          --  Otherwise we have an incomplete or private type that has no full
3025          --  view, which means that we have not encountered the completion, so
3026          --  return Empty to indicate the underlying type is not yet known.
3027
3028          else
3029             return Empty;
3030          end if;
3031
3032       --  For non-incomplete, non-private types, return the type itself. Also
3033       --  for entities that are not types at all return the entity itself.
3034
3035       else
3036          return Id;
3037       end if;
3038    end Underlying_Type;
3039
3040    ------------------------
3041    -- Unlink_Next_Entity --
3042    ------------------------
3043
3044    procedure Unlink_Next_Entity (Id : Entity_Id) is
3045       Next : constant Entity_Id := Next_Entity (Id);
3046
3047    begin
3048       if Present (Next) then
3049          Set_Prev_Entity (Next, Empty);  --  Empty <-- Next
3050       end if;
3051
3052       Set_Next_Entity (Id, Empty);       --  Id --> Empty
3053    end Unlink_Next_Entity;
3054
3055    ----------------------------------
3056    -- Is_Volatile, Set_Is_Volatile --
3057    ----------------------------------
3058
3059    function Is_Volatile (Id : E) return B is
3060    begin
3061       pragma Assert (Nkind (Id) in N_Entity);
3062
3063       if Is_Type (Id) then
3064          return Is_Volatile_Type (Base_Type (Id));
3065       else
3066          return Is_Volatile_Object (Id);
3067       end if;
3068    end Is_Volatile;
3069
3070    procedure Set_Is_Volatile (Id : E; V : B := True) is
3071    begin
3072       pragma Assert (Nkind (Id) in N_Entity);
3073
3074       if Is_Type (Id) then
3075          Set_Is_Volatile_Type (Id, V);
3076       else
3077          Set_Is_Volatile_Object (Id, V);
3078       end if;
3079    end Set_Is_Volatile;
3080
3081    -----------------------
3082    -- Write_Entity_Info --
3083    -----------------------
3084
3085    procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is
3086
3087       procedure Write_Attribute (Which : String; Nam : E);
3088       --  Write attribute value with given string name
3089
3090       procedure Write_Kind (Id : Entity_Id);
3091       --  Write Ekind field of entity
3092
3093       ---------------------
3094       -- Write_Attribute --
3095       ---------------------
3096
3097       procedure Write_Attribute (Which : String; Nam : E) is
3098       begin
3099          Write_Str (Prefix);
3100          Write_Str (Which);
3101          Write_Int (Int (Nam));
3102          Write_Str (" ");
3103          Write_Name (Chars (Nam));
3104          Write_Str (" ");
3105       end Write_Attribute;
3106
3107       ----------------
3108       -- Write_Kind --
3109       ----------------
3110
3111       procedure Write_Kind (Id : Entity_Id) is
3112          K : constant String := Entity_Kind'Image (Ekind (Id));
3113
3114       begin
3115          Write_Str (Prefix);
3116          Write_Str ("   Kind    ");
3117
3118          if Is_Type (Id) and then Is_Tagged_Type (Id) then
3119             Write_Str ("TAGGED ");
3120          end if;
3121
3122          Write_Str (K (3 .. K'Length));
3123          Write_Str (" ");
3124
3125          if Is_Type (Id) and then Depends_On_Private (Id) then
3126             Write_Str ("Depends_On_Private ");
3127          end if;
3128       end Write_Kind;
3129
3130    --  Start of processing for Write_Entity_Info
3131
3132    begin
3133       Write_Eol;
3134       Write_Attribute ("Name ", Id);
3135       Write_Int (Int (Id));
3136       Write_Eol;
3137       Write_Kind (Id);
3138       Write_Eol;
3139       Write_Attribute ("   Type    ", Etype (Id));
3140       Write_Eol;
3141       if Id /= Standard_Standard then
3142          Write_Attribute ("   Scope   ", Scope (Id));
3143       end if;
3144       Write_Eol;
3145
3146       case Ekind (Id) is
3147          when Discrete_Kind =>
3148             Write_Str ("Bounds: Id = ");
3149
3150             if Present (Scalar_Range (Id)) then
3151                Write_Int (Int (Type_Low_Bound (Id)));
3152                Write_Str (" .. Id = ");
3153                Write_Int (Int (Type_High_Bound (Id)));
3154             else
3155                Write_Str ("Empty");
3156             end if;
3157
3158             Write_Eol;
3159
3160          when Array_Kind =>
3161             declare
3162                Index : Entity_Id;
3163
3164             begin
3165                Write_Attribute
3166                  ("   Component Type    ", Component_Type (Id));
3167                Write_Eol;
3168                Write_Str (Prefix);
3169                Write_Str ("   Indexes ");
3170
3171                Index := First_Index (Id);
3172                while Present (Index) loop
3173                   Write_Attribute (" ", Etype (Index));
3174                   Index := Next_Index (Index);
3175                end loop;
3176
3177                Write_Eol;
3178             end;
3179
3180          when Access_Kind =>
3181                Write_Attribute
3182                  ("   Directly Designated Type ",
3183                   Directly_Designated_Type (Id));
3184                Write_Eol;
3185
3186          when Overloadable_Kind =>
3187             if Present (Homonym (Id)) then
3188                Write_Str ("   Homonym   ");
3189                Write_Name (Chars (Homonym (Id)));
3190                Write_Str ("   ");
3191                Write_Int (Int (Homonym (Id)));
3192                Write_Eol;
3193             end if;
3194
3195             Write_Eol;
3196
3197          when E_Component =>
3198             if Ekind (Scope (Id)) in Record_Kind then
3199                Write_Attribute (
3200                   "   Original_Record_Component   ",
3201                   Original_Record_Component (Id));
3202                Write_Int (Int (Original_Record_Component (Id)));
3203                Write_Eol;
3204             end if;
3205
3206          when others =>
3207             null;
3208       end case;
3209    end Write_Entity_Info;
3210
3211    -------------------------
3212    -- Iterator Procedures --
3213    -------------------------
3214
3215    procedure Proc_Next_Component                 (N : in out Node_Id) is
3216    begin
3217       N := Next_Component (N);
3218    end Proc_Next_Component;
3219
3220    procedure Proc_Next_Component_Or_Discriminant (N : in out Node_Id) is
3221    begin
3222       N := Next_Entity (N);
3223       while Present (N) loop
3224          exit when Ekind (N) in E_Component | E_Discriminant;
3225          N := Next_Entity (N);
3226       end loop;
3227    end Proc_Next_Component_Or_Discriminant;
3228
3229    procedure Proc_Next_Discriminant              (N : in out Node_Id) is
3230    begin
3231       N := Next_Discriminant (N);
3232    end Proc_Next_Discriminant;
3233
3234    procedure Proc_Next_Formal                    (N : in out Node_Id) is
3235    begin
3236       N := Next_Formal (N);
3237    end Proc_Next_Formal;
3238
3239    procedure Proc_Next_Formal_With_Extras        (N : in out Node_Id) is
3240    begin
3241       N := Next_Formal_With_Extras (N);
3242    end Proc_Next_Formal_With_Extras;
3243
3244    procedure Proc_Next_Index                     (N : in out Node_Id) is
3245    begin
3246       N := Next_Index (N);
3247    end Proc_Next_Index;
3248
3249    procedure Proc_Next_Inlined_Subprogram        (N : in out Node_Id) is
3250    begin
3251       N := Next_Inlined_Subprogram (N);
3252    end Proc_Next_Inlined_Subprogram;
3253
3254    procedure Proc_Next_Literal                   (N : in out Node_Id) is
3255    begin
3256       N := Next_Literal (N);
3257    end Proc_Next_Literal;
3258
3259    procedure Proc_Next_Stored_Discriminant       (N : in out Node_Id) is
3260    begin
3261       N := Next_Stored_Discriminant (N);
3262    end Proc_Next_Stored_Discriminant;
3263
3264 end Einfo.Utils;