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       --  (But not N_Character_Literal.)
1510
1511       return Kind in N_Identifier | N_Operator_Symbol | N_Expanded_Name
1512
1513       --  Attribute references are entity names if they refer to an entity.
1514       --  Note that we don't do this by testing for the presence of the
1515       --  Entity field in the N_Attribute_Reference node, since it may not
1516       --  have been set yet.
1517
1518         or else (Kind = N_Attribute_Reference
1519                   and then Is_Entity_Attribute_Name (Attribute_Name (N)));
1520    end Is_Entity_Name;
1521
1522    ---------------------------
1523    -- Is_Elaboration_Target --
1524    ---------------------------
1525
1526    function Is_Elaboration_Target (Id : E) return Boolean is
1527    begin
1528       return
1529         Ekind (Id) in E_Constant | E_Package | E_Variable
1530           or else Is_Entry        (Id)
1531           or else Is_Generic_Unit (Id)
1532           or else Is_Subprogram   (Id)
1533           or else Is_Task_Type    (Id);
1534    end Is_Elaboration_Target;
1535
1536    -----------------------
1537    -- Is_External_State --
1538    -----------------------
1539
1540    function Is_External_State (Id : E) return B is
1541    begin
1542       --  To qualify, the abstract state must appear with option "external" or
1543       --  "synchronous" (SPARK RM 7.1.4(7) and (9)).
1544
1545       return
1546         Ekind (Id) = E_Abstract_State
1547           and then (Has_Option (Id, Name_External)
1548                       or else
1549                     Has_Option (Id, Name_Synchronous));
1550    end Is_External_State;
1551
1552    ------------------
1553    -- Is_Finalizer --
1554    ------------------
1555
1556    function Is_Finalizer (Id : E) return B is
1557    begin
1558       return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
1559    end Is_Finalizer;
1560
1561    ----------------------
1562    -- Is_Full_Access --
1563    ----------------------
1564
1565    function Is_Full_Access (Id : E) return B is
1566    begin
1567       return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
1568    end Is_Full_Access;
1569
1570    -------------------
1571    -- Is_Null_State --
1572    -------------------
1573
1574    function Is_Null_State (Id : E) return B is
1575    begin
1576       return
1577         Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null;
1578    end Is_Null_State;
1579
1580    -----------------------------------
1581    -- Is_Package_Or_Generic_Package --
1582    -----------------------------------
1583
1584    function Is_Package_Or_Generic_Package (Id : E) return B is
1585    begin
1586       return Ekind (Id) in E_Generic_Package | E_Package;
1587    end Is_Package_Or_Generic_Package;
1588
1589    ---------------------
1590    -- Is_Packed_Array --
1591    ---------------------
1592
1593    function Is_Packed_Array (Id : E) return B is
1594    begin
1595       return Is_Array_Type (Id) and then Is_Packed (Id);
1596    end Is_Packed_Array;
1597
1598    ---------------
1599    -- Is_Prival --
1600    ---------------
1601
1602    function Is_Prival (Id : E) return B is
1603    begin
1604       return Ekind (Id) in E_Constant | E_Variable
1605                and then Present (Prival_Link (Id));
1606    end Is_Prival;
1607
1608    ----------------------------
1609    -- Is_Protected_Component --
1610    ----------------------------
1611
1612    function Is_Protected_Component (Id : E) return B is
1613    begin
1614       return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id));
1615    end Is_Protected_Component;
1616
1617    ----------------------------
1618    -- Is_Protected_Interface --
1619    ----------------------------
1620
1621    function Is_Protected_Interface (Id : E) return B is
1622       Typ : constant Entity_Id := Base_Type (Id);
1623    begin
1624       if not Is_Interface (Typ) then
1625          return False;
1626       elsif Is_Class_Wide_Type (Typ) then
1627          return Is_Protected_Interface (Etype (Typ));
1628       else
1629          return Protected_Present (Type_Definition (Parent (Typ)));
1630       end if;
1631    end Is_Protected_Interface;
1632
1633    ------------------------------
1634    -- Is_Protected_Record_Type --
1635    ------------------------------
1636
1637    function Is_Protected_Record_Type (Id : E) return B is
1638    begin
1639       return
1640         Is_Concurrent_Record_Type (Id)
1641           and then Is_Protected_Type (Corresponding_Concurrent_Type (Id));
1642    end Is_Protected_Record_Type;
1643
1644    -------------------------------------
1645    -- Is_Relaxed_Initialization_State --
1646    -------------------------------------
1647
1648    function Is_Relaxed_Initialization_State (Id : E) return B is
1649    begin
1650       --  To qualify, the abstract state must appear with simple option
1651       --  "Relaxed_Initialization" (SPARK RM 6.10).
1652
1653       return
1654         Ekind (Id) = E_Abstract_State
1655           and then Has_Option (Id, Name_Relaxed_Initialization);
1656    end Is_Relaxed_Initialization_State;
1657
1658    --------------------------------
1659    -- Is_Standard_Character_Type --
1660    --------------------------------
1661
1662    function Is_Standard_Character_Type (Id : E) return B is
1663    begin
1664       return Is_Type (Id)
1665         and then Root_Type (Id) in Standard_Character
1666                                  | Standard_Wide_Character
1667                                  | Standard_Wide_Wide_Character;
1668    end Is_Standard_Character_Type;
1669
1670    -----------------------------
1671    -- Is_Standard_String_Type --
1672    -----------------------------
1673
1674    function Is_Standard_String_Type (Id : E) return B is
1675    begin
1676       return Is_Type (Id)
1677         and then Root_Type (Id) in Standard_String
1678                                  | Standard_Wide_String
1679                                  | Standard_Wide_Wide_String;
1680    end Is_Standard_String_Type;
1681
1682    --------------------
1683    -- Is_String_Type --
1684    --------------------
1685
1686    function Is_String_Type (Id : E) return B is
1687    begin
1688       return Is_Array_Type (Id)
1689         and then Id /= Any_Composite
1690         and then Number_Dimensions (Id) = 1
1691         and then Is_Character_Type (Component_Type (Id));
1692    end Is_String_Type;
1693
1694    -------------------------------
1695    -- Is_Synchronized_Interface --
1696    -------------------------------
1697
1698    function Is_Synchronized_Interface (Id : E) return B is
1699       Typ : constant Entity_Id := Base_Type (Id);
1700
1701    begin
1702       if not Is_Interface (Typ) then
1703          return False;
1704
1705       elsif Is_Class_Wide_Type (Typ) then
1706          return Is_Synchronized_Interface (Etype (Typ));
1707
1708       else
1709          return    Protected_Present    (Type_Definition (Parent (Typ)))
1710            or else Synchronized_Present (Type_Definition (Parent (Typ)))
1711            or else Task_Present         (Type_Definition (Parent (Typ)));
1712       end if;
1713    end Is_Synchronized_Interface;
1714
1715    ---------------------------
1716    -- Is_Synchronized_State --
1717    ---------------------------
1718
1719    function Is_Synchronized_State (Id : E) return B is
1720    begin
1721       --  To qualify, the abstract state must appear with simple option
1722       --  "synchronous" (SPARK RM 7.1.4(9)).
1723
1724       return
1725         Ekind (Id) = E_Abstract_State
1726           and then Has_Option (Id, Name_Synchronous);
1727    end Is_Synchronized_State;
1728
1729    -----------------------
1730    -- Is_Task_Interface --
1731    -----------------------
1732
1733    function Is_Task_Interface (Id : E) return B is
1734       Typ : constant Entity_Id := Base_Type (Id);
1735    begin
1736       if not Is_Interface (Typ) then
1737          return False;
1738       elsif Is_Class_Wide_Type (Typ) then
1739          return Is_Task_Interface (Etype (Typ));
1740       else
1741          return Task_Present (Type_Definition (Parent (Typ)));
1742       end if;
1743    end Is_Task_Interface;
1744
1745    -------------------------
1746    -- Is_Task_Record_Type --
1747    -------------------------
1748
1749    function Is_Task_Record_Type (Id : E) return B is
1750    begin
1751       return
1752         Is_Concurrent_Record_Type (Id)
1753           and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
1754    end Is_Task_Record_Type;
1755
1756    ------------------------
1757    -- Is_Wrapper_Package --
1758    ------------------------
1759
1760    function Is_Wrapper_Package (Id : E) return B is
1761    begin
1762       return Ekind (Id) = E_Package and then Present (Related_Instance (Id));
1763    end Is_Wrapper_Package;
1764
1765    -----------------
1766    -- Last_Formal --
1767    -----------------
1768
1769    function Last_Formal (Id : E) return Entity_Id is
1770       Formal : Entity_Id;
1771
1772    begin
1773       pragma Assert
1774         (Is_Overloadable (Id)
1775           or else Ekind (Id) in E_Entry_Family
1776                               | E_Subprogram_Body
1777                               | E_Subprogram_Type);
1778
1779       if Ekind (Id) = E_Enumeration_Literal then
1780          return Empty;
1781
1782       else
1783          Formal := First_Formal (Id);
1784
1785          if Present (Formal) then
1786             while Present (Next_Formal (Formal)) loop
1787                Next_Formal (Formal);
1788             end loop;
1789          end if;
1790
1791          return Formal;
1792       end if;
1793    end Last_Formal;
1794
1795    -------------------
1796    -- Link_Entities --
1797    -------------------
1798
1799    procedure Link_Entities (First, Second : Entity_Id) is
1800    begin
1801       if Present (Second) then
1802          Set_Prev_Entity (Second, First);  --  First <-- Second
1803       end if;
1804
1805       Set_Next_Entity (First, Second);     --  First --> Second
1806    end Link_Entities;
1807
1808    ------------------------
1809    -- Machine_Emax_Value --
1810    ------------------------
1811
1812    function Machine_Emax_Value (Id : E) return Uint is
1813       Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
1814
1815    begin
1816       case Float_Rep (Id) is
1817          when IEEE_Binary =>
1818             case Digs is
1819                when  1 ..  6 => return Uint_128;
1820                when  7 .. 15 => return 2**10;
1821                when 16 .. 33 => return 2**14;
1822                when others   => return No_Uint;
1823             end case;
1824       end case;
1825    end Machine_Emax_Value;
1826
1827    ------------------------
1828    -- Machine_Emin_Value --
1829    ------------------------
1830
1831    function Machine_Emin_Value (Id : E) return Uint is
1832    begin
1833       case Float_Rep (Id) is
1834          when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
1835       end case;
1836    end Machine_Emin_Value;
1837
1838    ----------------------------
1839    -- Machine_Mantissa_Value --
1840    ----------------------------
1841
1842    function Machine_Mantissa_Value (Id : E) return Uint is
1843       Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
1844
1845    begin
1846       case Float_Rep (Id) is
1847          when IEEE_Binary =>
1848             case Digs is
1849                when  1 ..  6 => return Uint_24;
1850                when  7 .. 15 => return UI_From_Int (53);
1851                when 16 .. 18 => return Uint_64;
1852                when 19 .. 33 => return UI_From_Int (113);
1853                when others   => return No_Uint;
1854             end case;
1855       end case;
1856    end Machine_Mantissa_Value;
1857
1858    -------------------------
1859    -- Machine_Radix_Value --
1860    -------------------------
1861
1862    function Machine_Radix_Value (Id : E) return U is
1863    begin
1864       case Float_Rep (Id) is
1865          when IEEE_Binary =>
1866             return Uint_2;
1867       end case;
1868    end Machine_Radix_Value;
1869
1870    ----------------------
1871    -- Model_Emin_Value --
1872    ----------------------
1873
1874    function Model_Emin_Value (Id : E) return Uint is
1875    begin
1876       return Machine_Emin_Value (Id);
1877    end Model_Emin_Value;
1878
1879    -------------------------
1880    -- Model_Epsilon_Value --
1881    -------------------------
1882
1883    function Model_Epsilon_Value (Id : E) return Ureal is
1884       Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
1885    begin
1886       return Radix ** (1 - Model_Mantissa_Value (Id));
1887    end Model_Epsilon_Value;
1888
1889    --------------------------
1890    -- Model_Mantissa_Value --
1891    --------------------------
1892
1893    function Model_Mantissa_Value (Id : E) return Uint is
1894    begin
1895       return Machine_Mantissa_Value (Id);
1896    end Model_Mantissa_Value;
1897
1898    -----------------------
1899    -- Model_Small_Value --
1900    -----------------------
1901
1902    function Model_Small_Value (Id : E) return Ureal is
1903       Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
1904    begin
1905       return Radix ** (Model_Emin_Value (Id) - 1);
1906    end Model_Small_Value;
1907
1908    --------------------
1909    -- Next_Component --
1910    --------------------
1911
1912    function Next_Component (Id : E) return Entity_Id is
1913       Comp_Id : Entity_Id;
1914
1915    begin
1916       Comp_Id := Next_Entity (Id);
1917       while Present (Comp_Id) loop
1918          exit when Ekind (Comp_Id) = E_Component;
1919          Next_Entity (Comp_Id);
1920       end loop;
1921
1922       return Comp_Id;
1923    end Next_Component;
1924
1925    ------------------------------------
1926    -- Next_Component_Or_Discriminant --
1927    ------------------------------------
1928
1929    function Next_Component_Or_Discriminant (Id : E) return Entity_Id is
1930       Comp_Id : Entity_Id;
1931
1932    begin
1933       Comp_Id := Next_Entity (Id);
1934       while Present (Comp_Id) loop
1935          exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
1936          Next_Entity (Comp_Id);
1937       end loop;
1938
1939       return Comp_Id;
1940    end Next_Component_Or_Discriminant;
1941
1942    -----------------------
1943    -- Next_Discriminant --
1944    -----------------------
1945
1946    --  This function actually implements both Next_Discriminant and
1947    --  Next_Stored_Discriminant by making sure that the Discriminant
1948    --  returned is of the same variety as Id.
1949
1950    function Next_Discriminant (Id : E) return Entity_Id is
1951
1952       --  Derived Tagged types with private extensions look like this...
1953
1954       --       E_Discriminant d1
1955       --       E_Discriminant d2
1956       --       E_Component    _tag
1957       --       E_Discriminant d1
1958       --       E_Discriminant d2
1959       --       ...
1960
1961       --  so it is critical not to go past the leading discriminants
1962
1963       D : Entity_Id := Id;
1964
1965    begin
1966       pragma Assert (Ekind (Id) = E_Discriminant);
1967
1968       loop
1969          Next_Entity (D);
1970          if No (D)
1971            or else (Ekind (D) /= E_Discriminant
1972                       and then not Is_Itype (D))
1973          then
1974             return Empty;
1975          end if;
1976
1977          exit when Ekind (D) = E_Discriminant
1978            and then Is_Completely_Hidden (D) = Is_Completely_Hidden (Id);
1979       end loop;
1980
1981       return D;
1982    end Next_Discriminant;
1983
1984    -----------------
1985    -- Next_Formal --
1986    -----------------
1987
1988    function Next_Formal (Id : E) return Entity_Id is
1989       P : Entity_Id;
1990
1991    begin
1992       --  Follow the chain of declared entities as long as the kind of the
1993       --  entity corresponds to a formal parameter. Skip internal entities
1994       --  that may have been created for implicit subtypes, in the process
1995       --  of analyzing default expressions.
1996
1997       P := Id;
1998       loop
1999          Next_Entity (P);
2000
2001          if No (P) or else Is_Formal (P) then
2002             return P;
2003          elsif not Is_Internal (P) then
2004             return Empty;
2005          end if;
2006       end loop;
2007    end Next_Formal;
2008
2009    -----------------------------
2010    -- Next_Formal_With_Extras --
2011    -----------------------------
2012
2013    function Next_Formal_With_Extras (Id : E) return Entity_Id is
2014    begin
2015       if Present (Extra_Formal (Id)) then
2016          return Extra_Formal (Id);
2017       else
2018          return Next_Formal (Id);
2019       end if;
2020    end Next_Formal_With_Extras;
2021
2022    ----------------
2023    -- Next_Index --
2024    ----------------
2025
2026    function Next_Index (Id : N) return Node_Id is
2027    begin
2028       pragma Assert (Nkind (Id) in N_Is_Index);
2029       pragma Assert (No (Next (Id)) or else Nkind (Next (Id)) in N_Is_Index);
2030       return Next (Id);
2031    end Next_Index;
2032
2033    ------------------
2034    -- Next_Literal --
2035    ------------------
2036
2037    function Next_Literal (Id : E) return Entity_Id is
2038    begin
2039       pragma Assert (Nkind (Id) in N_Entity);
2040       return Next (Id);
2041    end Next_Literal;
2042
2043    ------------------------------
2044    -- Next_Stored_Discriminant --
2045    ------------------------------
2046
2047    function Next_Stored_Discriminant (Id : E) return Entity_Id is
2048    begin
2049       --  See comment in Next_Discriminant
2050
2051       return Next_Discriminant (Id);
2052    end Next_Stored_Discriminant;
2053
2054    -----------------------
2055    -- Number_Dimensions --
2056    -----------------------
2057
2058    function Number_Dimensions (Id : E) return Pos is
2059       N : Int;
2060       T : Node_Id;
2061
2062    begin
2063       if Ekind (Id) = E_String_Literal_Subtype then
2064          return 1;
2065
2066       else
2067          N := 0;
2068          T := First_Index (Id);
2069          while Present (T) loop
2070             N := N + 1;
2071             Next_Index (T);
2072          end loop;
2073
2074          return N;
2075       end if;
2076    end Number_Dimensions;
2077
2078    --------------------
2079    -- Number_Entries --
2080    --------------------
2081
2082    function Number_Entries (Id : E) return Nat is
2083       N   : Nat;
2084       Ent : Entity_Id;
2085
2086    begin
2087       pragma Assert (Is_Concurrent_Type (Id));
2088
2089       N := 0;
2090       Ent := First_Entity (Id);
2091       while Present (Ent) loop
2092          if Is_Entry (Ent) then
2093             N := N + 1;
2094          end if;
2095
2096          Next_Entity (Ent);
2097       end loop;
2098
2099       return N;
2100    end Number_Entries;
2101
2102    --------------------
2103    -- Number_Formals --
2104    --------------------
2105
2106    function Number_Formals (Id : E) return Pos is
2107       N      : Int;
2108       Formal : Entity_Id;
2109
2110    begin
2111       N := 0;
2112       Formal := First_Formal (Id);
2113       while Present (Formal) loop
2114          N := N + 1;
2115          Next_Formal (Formal);
2116       end loop;
2117
2118       return N;
2119    end Number_Formals;
2120
2121    ------------------------
2122    -- Object_Size_Clause --
2123    ------------------------
2124
2125    function Object_Size_Clause (Id : E) return Node_Id is
2126    begin
2127       return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size);
2128    end Object_Size_Clause;
2129
2130    --------------------
2131    -- Parameter_Mode --
2132    --------------------
2133
2134    function Parameter_Mode (Id : E) return Formal_Kind is
2135    begin
2136       return Ekind (Id);
2137    end Parameter_Mode;
2138
2139    -------------------
2140    -- DIC_Procedure --
2141    -------------------
2142
2143    function DIC_Procedure (Id : E) return Entity_Id is
2144       Subp_Elmt : Elmt_Id;
2145       Subp_Id   : Entity_Id;
2146       Subps     : Elist_Id;
2147
2148    begin
2149       pragma Assert (Is_Type (Id));
2150
2151       Subps := Subprograms_For_Type (Base_Type (Id));
2152
2153       if Present (Subps) then
2154          Subp_Elmt := First_Elmt (Subps);
2155          while Present (Subp_Elmt) loop
2156             Subp_Id := Node (Subp_Elmt);
2157
2158             --  Currently the flag Is_DIC_Procedure is set for both normal DIC
2159             --  check procedures as well as for partial DIC check procedures,
2160             --  and we don't have a flag for the partial procedures.
2161
2162             if Is_DIC_Procedure (Subp_Id)
2163               and then not Is_Partial_DIC_Procedure (Subp_Id)
2164             then
2165                return Subp_Id;
2166             end if;
2167
2168             Next_Elmt (Subp_Elmt);
2169          end loop;
2170       end if;
2171
2172       return Empty;
2173    end DIC_Procedure;
2174
2175    function Partial_DIC_Procedure (Id : E) return Entity_Id is
2176       Subp_Elmt : Elmt_Id;
2177       Subp_Id   : Entity_Id;
2178       Subps     : Elist_Id;
2179
2180    begin
2181       pragma Assert (Is_Type (Id));
2182
2183       Subps := Subprograms_For_Type (Base_Type (Id));
2184
2185       if Present (Subps) then
2186          Subp_Elmt := First_Elmt (Subps);
2187          while Present (Subp_Elmt) loop
2188             Subp_Id := Node (Subp_Elmt);
2189
2190             if Is_Partial_DIC_Procedure (Subp_Id) then
2191                return Subp_Id;
2192             end if;
2193
2194             Next_Elmt (Subp_Elmt);
2195          end loop;
2196       end if;
2197
2198       return Empty;
2199    end Partial_DIC_Procedure;
2200
2201    function Is_Partial_DIC_Procedure (Id : E) return B is
2202       Partial_DIC_Suffix : constant String := "Partial_DIC";
2203       DIC_Nam            : constant String := Get_Name_String (Chars (Id));
2204
2205    begin
2206       pragma Assert (Ekind (Id) in E_Function | E_Procedure);
2207
2208       --  Instead of adding a new Entity_Id flag (which are in short supply),
2209       --  we test the form of the subprogram name. When the node field and flag
2210       --  situation is eased, this should be replaced with a flag. ???
2211
2212       if DIC_Nam'Length > Partial_DIC_Suffix'Length
2213         and then
2214           DIC_Nam
2215             (DIC_Nam'Last - Partial_DIC_Suffix'Length + 1 .. DIC_Nam'Last) =
2216                Partial_DIC_Suffix
2217       then
2218          return True;
2219       else
2220          return False;
2221       end if;
2222    end Is_Partial_DIC_Procedure;
2223
2224    ---------------------------------
2225    -- Partial_Invariant_Procedure --
2226    ---------------------------------
2227
2228    function Partial_Invariant_Procedure (Id : E) return Entity_Id is
2229       Subp_Elmt : Elmt_Id;
2230       Subp_Id   : Entity_Id;
2231       Subps     : Elist_Id;
2232
2233    begin
2234       pragma Assert (Is_Type (Id));
2235
2236       Subps := Subprograms_For_Type (Base_Type (Id));
2237
2238       if Present (Subps) then
2239          Subp_Elmt := First_Elmt (Subps);
2240          while Present (Subp_Elmt) loop
2241             Subp_Id := Node (Subp_Elmt);
2242
2243             if Is_Partial_Invariant_Procedure (Subp_Id) then
2244                return Subp_Id;
2245             end if;
2246
2247             Next_Elmt (Subp_Elmt);
2248          end loop;
2249       end if;
2250
2251       return Empty;
2252    end Partial_Invariant_Procedure;
2253
2254    -------------------------------------
2255    -- Partial_Refinement_Constituents --
2256    -------------------------------------
2257
2258    function Partial_Refinement_Constituents (Id : E) return L is
2259       Constits : Elist_Id := No_Elist;
2260
2261       procedure Add_Usable_Constituents (Item : E);
2262       --  Add global item Item and/or its constituents to list Constits when
2263       --  they can be used in a global refinement within the current scope. The
2264       --  criteria are:
2265       --    1) If Item is an abstract state with full refinement visible, add
2266       --       its constituents.
2267       --    2) If Item is an abstract state with only partial refinement
2268       --       visible, add both Item and its constituents.
2269       --    3) If Item is an abstract state without a visible refinement, add
2270       --       it.
2271       --    4) If Id is not an abstract state, add it.
2272
2273       procedure Add_Usable_Constituents (List : Elist_Id);
2274       --  Apply Add_Usable_Constituents to every constituent in List
2275
2276       -----------------------------
2277       -- Add_Usable_Constituents --
2278       -----------------------------
2279
2280       procedure Add_Usable_Constituents (Item : E) is
2281       begin
2282          if Ekind (Item) = E_Abstract_State then
2283             if Has_Visible_Refinement (Item) then
2284                Add_Usable_Constituents (Refinement_Constituents (Item));
2285
2286             elsif Has_Partial_Visible_Refinement (Item) then
2287                Append_New_Elmt (Item, Constits);
2288                Add_Usable_Constituents (Part_Of_Constituents (Item));
2289
2290             else
2291                Append_New_Elmt (Item, Constits);
2292             end if;
2293
2294          else
2295             Append_New_Elmt (Item, Constits);
2296          end if;
2297       end Add_Usable_Constituents;
2298
2299       procedure Add_Usable_Constituents (List : Elist_Id) is
2300          Constit_Elmt : Elmt_Id;
2301       begin
2302          if Present (List) then
2303             Constit_Elmt := First_Elmt (List);
2304             while Present (Constit_Elmt) loop
2305                Add_Usable_Constituents (Node (Constit_Elmt));
2306                Next_Elmt (Constit_Elmt);
2307             end loop;
2308          end if;
2309       end Add_Usable_Constituents;
2310
2311    --  Start of processing for Partial_Refinement_Constituents
2312
2313    begin
2314       --  "Refinement" is a concept applicable only to abstract states
2315
2316       pragma Assert (Ekind (Id) = E_Abstract_State);
2317
2318       if Has_Visible_Refinement (Id) then
2319          Constits := Refinement_Constituents (Id);
2320
2321       --  A refinement may be partially visible when objects declared in the
2322       --  private part of a package are subject to a Part_Of indicator.
2323
2324       elsif Has_Partial_Visible_Refinement (Id) then
2325          Add_Usable_Constituents (Part_Of_Constituents (Id));
2326
2327       --  Function should only be called when full or partial refinement is
2328       --  visible.
2329
2330       else
2331          raise Program_Error;
2332       end if;
2333
2334       return Constits;
2335    end Partial_Refinement_Constituents;
2336
2337    ------------------------
2338    -- Predicate_Function --
2339    ------------------------
2340
2341    function Predicate_Function (Id : E) return Entity_Id is
2342       Subp_Elmt : Elmt_Id;
2343       Subp_Id   : Entity_Id;
2344       Subps     : Elist_Id;
2345       Typ       : Entity_Id;
2346
2347    begin
2348       pragma Assert (Is_Type (Id));
2349
2350       --  If type is private and has a completion, predicate may be defined on
2351       --  the full view.
2352
2353       if Is_Private_Type (Id)
2354          and then
2355            (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
2356          and then Present (Full_View (Id))
2357       then
2358          Typ := Full_View (Id);
2359
2360       elsif Ekind (Id) in E_Array_Subtype
2361                         | E_Record_Subtype
2362                         | E_Record_Subtype_With_Private
2363         and then Present (Predicated_Parent (Id))
2364       then
2365          Typ := Predicated_Parent (Id);
2366
2367       else
2368          Typ := Id;
2369       end if;
2370
2371       Subps := Subprograms_For_Type (Typ);
2372
2373       if Present (Subps) then
2374          Subp_Elmt := First_Elmt (Subps);
2375          while Present (Subp_Elmt) loop
2376             Subp_Id := Node (Subp_Elmt);
2377
2378             if Ekind (Subp_Id) = E_Function
2379               and then Is_Predicate_Function (Subp_Id)
2380             then
2381                return Subp_Id;
2382             end if;
2383
2384             Next_Elmt (Subp_Elmt);
2385          end loop;
2386       end if;
2387
2388       return Empty;
2389    end Predicate_Function;
2390
2391    -------------------------
2392    -- Present_In_Rep_Item --
2393    -------------------------
2394
2395    function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
2396       Ritem : Node_Id;
2397
2398    begin
2399       Ritem := First_Rep_Item (E);
2400
2401       while Present (Ritem) loop
2402          if Ritem = N then
2403             return True;
2404          end if;
2405
2406          Next_Rep_Item (Ritem);
2407       end loop;
2408
2409       return False;
2410    end Present_In_Rep_Item;
2411
2412    --------------------------
2413    -- Primitive_Operations --
2414    --------------------------
2415
2416    function Primitive_Operations (Id : E) return L is
2417    begin
2418       if Is_Concurrent_Type (Id) then
2419          if Present (Corresponding_Record_Type (Id)) then
2420             return Direct_Primitive_Operations
2421               (Corresponding_Record_Type (Id));
2422
2423          --  When expansion is disabled, the corresponding record type is
2424          --  absent, but if this is a tagged type with ancestors, or if the
2425          --  extension of prefixed calls for untagged types is enabled, then
2426          --  it may have associated primitive operations.
2427
2428          else
2429             return Direct_Primitive_Operations (Id);
2430          end if;
2431
2432       else
2433          return Direct_Primitive_Operations (Id);
2434       end if;
2435    end Primitive_Operations;
2436
2437    ---------------------
2438    -- Record_Rep_Item --
2439    ---------------------
2440
2441    procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
2442    begin
2443       Set_Next_Rep_Item (N, First_Rep_Item (E));
2444       Set_First_Rep_Item (E, N);
2445    end Record_Rep_Item;
2446
2447    -------------------
2448    -- Remove_Entity --
2449    -------------------
2450
2451    procedure Remove_Entity (Id : Entity_Id) is
2452       Next  : constant Entity_Id := Next_Entity (Id);
2453       Prev  : constant Entity_Id := Prev_Entity (Id);
2454       Scop  : constant Entity_Id := Scope (Id);
2455       First : constant Entity_Id := First_Entity (Scop);
2456       Last  : constant Entity_Id := Last_Entity  (Scop);
2457
2458    begin
2459       --  Eliminate any existing linkages from the entity
2460
2461       Set_Prev_Entity (Id, Empty);  --  Empty <-- Id
2462       Set_Next_Entity (Id, Empty);  --  Id --> Empty
2463
2464       --  The eliminated entity was the only element in the entity chain
2465
2466       if Id = First and then Id = Last then
2467          Set_First_Entity (Scop, Empty);
2468          Set_Last_Entity  (Scop, Empty);
2469
2470       --  The eliminated entity was the head of the entity chain
2471
2472       elsif Id = First then
2473          Set_First_Entity (Scop, Next);
2474          Set_Prev_Entity (Next, Empty);  --  Empty <-- First_Entity
2475
2476       --  The eliminated entity was the tail of the entity chain
2477
2478       elsif Id = Last then
2479          Set_Last_Entity (Scop, Prev);
2480          Set_Next_Entity (Prev, Empty);  --  Last_Entity --> Empty
2481
2482       --  Otherwise the eliminated entity comes from the middle of the entity
2483       --  chain.
2484
2485       else
2486          Link_Entities (Prev, Next);  --  Prev <-- Next, Prev --> Next
2487       end if;
2488    end Remove_Entity;
2489
2490    ---------------
2491    -- Root_Type --
2492    ---------------
2493
2494    function Root_Type (Id : E) return E is
2495       T, Etyp : Entity_Id;
2496
2497    begin
2498       pragma Assert (Nkind (Id) in N_Entity);
2499
2500       T := Base_Type (Id);
2501
2502       if Ekind (T) = E_Class_Wide_Type then
2503          return Etype (T);
2504
2505       --  Other cases
2506
2507       else
2508          loop
2509             Etyp := Etype (T);
2510
2511             if T = Etyp then
2512                return T;
2513
2514             --  Following test catches some error cases resulting from
2515             --  previous errors.
2516
2517             elsif No (Etyp) then
2518                Check_Error_Detected;
2519                return T;
2520
2521             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
2522                return T;
2523
2524             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
2525                return T;
2526             end if;
2527
2528             T := Etyp;
2529
2530             --  Return if there is a circularity in the inheritance chain. This
2531             --  happens in some error situations and we do not want to get
2532             --  stuck in this loop.
2533
2534             if T = Base_Type (Id) then
2535                return T;
2536             end if;
2537          end loop;
2538       end if;
2539    end Root_Type;
2540
2541    ---------------------
2542    -- Safe_Emax_Value --
2543    ---------------------
2544
2545    function Safe_Emax_Value (Id : E) return Uint is
2546    begin
2547       return Machine_Emax_Value (Id);
2548    end Safe_Emax_Value;
2549
2550    ----------------------
2551    -- Safe_First_Value --
2552    ----------------------
2553
2554    function Safe_First_Value (Id : E) return Ureal is
2555    begin
2556       return -Safe_Last_Value (Id);
2557    end Safe_First_Value;
2558
2559    ---------------------
2560    -- Safe_Last_Value --
2561    ---------------------
2562
2563    function Safe_Last_Value (Id : E) return Ureal is
2564       Radix       : constant Uint := Machine_Radix_Value (Id);
2565       Mantissa    : constant Uint := Machine_Mantissa_Value (Id);
2566       Emax        : constant Uint := Safe_Emax_Value (Id);
2567       Significand : constant Uint := Radix ** Mantissa - 1;
2568       Exponent    : constant Uint := Emax - Mantissa;
2569
2570    begin
2571       if Radix = 2 then
2572          return
2573            UR_From_Components
2574              (Num   => Significand * 2 ** (Exponent mod 4),
2575               Den   => -Exponent / 4,
2576               Rbase => 16);
2577       else
2578          return
2579            UR_From_Components
2580              (Num => Significand,
2581               Den => -Exponent,
2582               Rbase => 16);
2583       end if;
2584    end Safe_Last_Value;
2585
2586    -----------------
2587    -- Scope_Depth --
2588    -----------------
2589
2590    function Scope_Depth (Id : E) return Uint is
2591       Scop : Entity_Id;
2592
2593    begin
2594       Scop := Id;
2595       while Is_Record_Type (Scop) loop
2596          Scop := Scope (Scop);
2597       end loop;
2598
2599       return Scope_Depth_Value (Scop);
2600    end Scope_Depth;
2601
2602    function Scope_Depth_Default_0 (Id : E) return U is
2603    begin
2604       if Scope_Depth_Set (Id) then
2605          return Scope_Depth (Id);
2606
2607       else
2608          return Uint_0;
2609       end if;
2610    end Scope_Depth_Default_0;
2611
2612    ---------------------
2613    -- Scope_Depth_Set --
2614    ---------------------
2615
2616    function Scope_Depth_Set (Id : E) return B is
2617    begin
2618       return not Is_Record_Type (Id)
2619         and then not Field_Is_Initial_Zero (Id, F_Scope_Depth_Value);
2620       --  We can't call Scope_Depth_Value here, because Empty is not a valid
2621       --  value of type Uint.
2622    end Scope_Depth_Set;
2623
2624    --------------------
2625    -- Set_Convention --
2626    --------------------
2627
2628    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
2629    begin
2630       Set_Basic_Convention (E, Val);
2631
2632       if Ekind (E) in Access_Subprogram_Kind
2633         and then Has_Foreign_Convention (E)
2634       then
2635          Set_Can_Use_Internal_Rep (E, False);
2636       end if;
2637
2638       --  If E is an object, including a component, and the type of E is an
2639       --  anonymous access type with no convention set, then also set the
2640       --  convention of the anonymous access type. We do not do this for
2641       --  anonymous protected types, since protected types always have the
2642       --  default convention.
2643
2644       if Present (Etype (E))
2645         and then (Is_Object (E)
2646
2647                    --  Allow E_Void (happens for pragma Convention appearing
2648                    --  in the middle of a record applying to a component)
2649
2650                    or else Ekind (E) = E_Void)
2651       then
2652          declare
2653             Typ : constant Entity_Id := Etype (E);
2654
2655          begin
2656             if Ekind (Typ) in E_Anonymous_Access_Type
2657                             | E_Anonymous_Access_Subprogram_Type
2658               and then not Has_Convention_Pragma (Typ)
2659             then
2660                Set_Convention (Typ, Val);
2661                Set_Has_Convention_Pragma (Typ);
2662
2663                --  And for the access subprogram type, deal similarly with the
2664                --  designated E_Subprogram_Type, which is always internal.
2665
2666                if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
2667                   declare
2668                      Dtype : constant Entity_Id := Designated_Type (Typ);
2669                   begin
2670                      if Ekind (Dtype) = E_Subprogram_Type then
2671                         pragma Assert (not Has_Convention_Pragma (Dtype));
2672                         Set_Convention (Dtype, Val);
2673                         Set_Has_Convention_Pragma (Dtype);
2674                      end if;
2675                   end;
2676                end if;
2677             end if;
2678          end;
2679       end if;
2680    end Set_Convention;
2681
2682    -----------------------
2683    -- Set_DIC_Procedure --
2684    -----------------------
2685
2686    procedure Set_DIC_Procedure (Id : E; V : E) is
2687       Base_Typ  : Entity_Id;
2688       Subps     : Elist_Id;
2689
2690    begin
2691       pragma Assert (Is_Type (Id));
2692
2693       Base_Typ := Base_Type (Id);
2694       Subps    := Subprograms_For_Type (Base_Typ);
2695
2696       if No (Subps) then
2697          Subps := New_Elmt_List;
2698          Set_Subprograms_For_Type (Base_Typ, Subps);
2699       end if;
2700
2701       Prepend_Elmt (V, Subps);
2702    end Set_DIC_Procedure;
2703
2704    procedure Set_Partial_DIC_Procedure (Id : E; V : E) is
2705    begin
2706       Set_DIC_Procedure (Id, V);
2707    end Set_Partial_DIC_Procedure;
2708
2709    -------------------
2710    -- Set_Float_Rep --
2711    -------------------
2712
2713    procedure Set_Float_Rep
2714      (Ignore_N : Entity_Id; Ignore_Val : Float_Rep_Kind) is
2715    begin
2716       pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last);
2717       --  There is only one value, so we don't need to store it (see
2718       --  types.ads).
2719    end Set_Float_Rep;
2720
2721    -----------------------------
2722    -- Set_Invariant_Procedure --
2723    -----------------------------
2724
2725    procedure Set_Invariant_Procedure (Id : E; V : E) is
2726       Base_Typ  : Entity_Id;
2727       Subp_Elmt : Elmt_Id;
2728       Subp_Id   : Entity_Id;
2729       Subps     : Elist_Id;
2730
2731    begin
2732       pragma Assert (Is_Type (Id));
2733
2734       Base_Typ := Base_Type (Id);
2735       Subps    := Subprograms_For_Type (Base_Typ);
2736
2737       if No (Subps) then
2738          Subps := New_Elmt_List;
2739          Set_Subprograms_For_Type (Base_Typ, Subps);
2740       end if;
2741
2742       Subp_Elmt := First_Elmt (Subps);
2743       Prepend_Elmt (V, Subps);
2744
2745       --  Check for a duplicate invariant procedure
2746
2747       while Present (Subp_Elmt) loop
2748          Subp_Id := Node (Subp_Elmt);
2749
2750          if Is_Invariant_Procedure (Subp_Id) then
2751             raise Program_Error;
2752          end if;
2753
2754          Next_Elmt (Subp_Elmt);
2755       end loop;
2756    end Set_Invariant_Procedure;
2757
2758    -------------------------------------
2759    -- Set_Partial_Invariant_Procedure --
2760    -------------------------------------
2761
2762    procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
2763       Base_Typ  : Entity_Id;
2764       Subp_Elmt : Elmt_Id;
2765       Subp_Id   : Entity_Id;
2766       Subps     : Elist_Id;
2767
2768    begin
2769       pragma Assert (Is_Type (Id));
2770
2771       Base_Typ := Base_Type (Id);
2772       Subps    := Subprograms_For_Type (Base_Typ);
2773
2774       if No (Subps) then
2775          Subps := New_Elmt_List;
2776          Set_Subprograms_For_Type (Base_Typ, Subps);
2777       end if;
2778
2779       Subp_Elmt := First_Elmt (Subps);
2780       Prepend_Elmt (V, Subps);
2781
2782       --  Check for a duplicate partial invariant procedure
2783
2784       while Present (Subp_Elmt) loop
2785          Subp_Id := Node (Subp_Elmt);
2786
2787          if Is_Partial_Invariant_Procedure (Subp_Id) then
2788             raise Program_Error;
2789          end if;
2790
2791          Next_Elmt (Subp_Elmt);
2792       end loop;
2793    end Set_Partial_Invariant_Procedure;
2794
2795    ----------------------------
2796    -- Set_Predicate_Function --
2797    ----------------------------
2798
2799    procedure Set_Predicate_Function (Id : E; V : E) is
2800       Subp_Elmt : Elmt_Id;
2801       Subp_Id   : Entity_Id;
2802       Subps     : Elist_Id;
2803
2804    begin
2805       pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
2806
2807       Subps := Subprograms_For_Type (Id);
2808
2809       if No (Subps) then
2810          Subps := New_Elmt_List;
2811          Set_Subprograms_For_Type (Id, Subps);
2812       end if;
2813
2814       Subp_Elmt := First_Elmt (Subps);
2815       Prepend_Elmt (V, Subps);
2816
2817       --  Check for a duplicate predication function
2818
2819       while Present (Subp_Elmt) loop
2820          Subp_Id := Node (Subp_Elmt);
2821
2822          if Ekind (Subp_Id) = E_Function
2823            and then Is_Predicate_Function (Subp_Id)
2824          then
2825             raise Program_Error;
2826          end if;
2827
2828          Next_Elmt (Subp_Elmt);
2829       end loop;
2830    end Set_Predicate_Function;
2831
2832    -----------------
2833    -- Size_Clause --
2834    -----------------
2835
2836    function Size_Clause (Id : E) return Node_Id is
2837       Result : Node_Id := Get_Attribute_Definition_Clause (Id, Attribute_Size);
2838    begin
2839       if No (Result) then
2840          Result := Get_Attribute_Definition_Clause (Id, Attribute_Value_Size);
2841       end if;
2842
2843       return Result;
2844    end Size_Clause;
2845
2846    ------------------------
2847    -- Stream_Size_Clause --
2848    ------------------------
2849
2850    function Stream_Size_Clause (Id : E) return N is
2851    begin
2852       return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
2853    end Stream_Size_Clause;
2854
2855    ------------------
2856    -- Subtype_Kind --
2857    ------------------
2858
2859    function Subtype_Kind (K : Entity_Kind) return Entity_Kind is
2860       Kind : Entity_Kind;
2861
2862    begin
2863       case K is
2864          when Access_Kind =>
2865             Kind := E_Access_Subtype;
2866
2867          when E_Array_Subtype
2868             | E_Array_Type
2869          =>
2870             Kind := E_Array_Subtype;
2871
2872          when E_Class_Wide_Subtype
2873             | E_Class_Wide_Type
2874          =>
2875             Kind := E_Class_Wide_Subtype;
2876
2877          when E_Decimal_Fixed_Point_Subtype
2878             | E_Decimal_Fixed_Point_Type
2879          =>
2880             Kind := E_Decimal_Fixed_Point_Subtype;
2881
2882          when E_Ordinary_Fixed_Point_Subtype
2883             | E_Ordinary_Fixed_Point_Type
2884          =>
2885             Kind := E_Ordinary_Fixed_Point_Subtype;
2886
2887          when E_Private_Subtype
2888             | E_Private_Type
2889          =>
2890             Kind := E_Private_Subtype;
2891
2892          when E_Limited_Private_Subtype
2893             | E_Limited_Private_Type
2894          =>
2895             Kind := E_Limited_Private_Subtype;
2896
2897          when E_Record_Subtype_With_Private
2898             | E_Record_Type_With_Private
2899          =>
2900             Kind := E_Record_Subtype_With_Private;
2901
2902          when E_Record_Subtype
2903             | E_Record_Type
2904          =>
2905             Kind := E_Record_Subtype;
2906
2907          when Enumeration_Kind =>
2908             Kind := E_Enumeration_Subtype;
2909
2910          when E_Incomplete_Type =>
2911             Kind := E_Incomplete_Subtype;
2912
2913          when Float_Kind =>
2914             Kind := E_Floating_Point_Subtype;
2915
2916          when Signed_Integer_Kind =>
2917             Kind := E_Signed_Integer_Subtype;
2918
2919          when Modular_Integer_Kind =>
2920             Kind := E_Modular_Integer_Subtype;
2921
2922          when Protected_Kind =>
2923             Kind := E_Protected_Subtype;
2924
2925          when Task_Kind =>
2926             Kind := E_Task_Subtype;
2927
2928          when others =>
2929             raise Program_Error;
2930       end case;
2931
2932       return Kind;
2933    end Subtype_Kind;
2934
2935    ---------------------
2936    -- Type_High_Bound --
2937    ---------------------
2938
2939    function Type_High_Bound (Id : E) return N is
2940       Rng : constant Node_Id := Scalar_Range (Id);
2941    begin
2942       if Nkind (Rng) = N_Subtype_Indication then
2943          return High_Bound (Range_Expression (Constraint (Rng)));
2944       else
2945          return High_Bound (Rng);
2946       end if;
2947    end Type_High_Bound;
2948
2949    --------------------
2950    -- Type_Low_Bound --
2951    --------------------
2952
2953    function Type_Low_Bound (Id : E) return N is
2954       Rng : constant Node_Id := Scalar_Range (Id);
2955    begin
2956       if Nkind (Rng) = N_Subtype_Indication then
2957          return Low_Bound (Range_Expression (Constraint (Rng)));
2958       else
2959          return Low_Bound (Rng);
2960       end if;
2961    end Type_Low_Bound;
2962
2963    ---------------------
2964    -- Underlying_Type --
2965    ---------------------
2966
2967    function Underlying_Type (Id : E) return Entity_Id is
2968    begin
2969       --  For record_with_private the underlying type is always the direct full
2970       --  view. Never try to take the full view of the parent it does not make
2971       --  sense.
2972
2973       if Ekind (Id) = E_Record_Type_With_Private then
2974          return Full_View (Id);
2975
2976       --  If we have a class-wide type that comes from the limited view then we
2977       --  return the Underlying_Type of its nonlimited view.
2978
2979       elsif Ekind (Id) = E_Class_Wide_Type
2980         and then From_Limited_With (Id)
2981         and then Present (Non_Limited_View (Id))
2982       then
2983          return Underlying_Type (Non_Limited_View (Id));
2984
2985       elsif Ekind (Id) in Incomplete_Or_Private_Kind then
2986
2987          --  If we have an incomplete or private type with a full view, then we
2988          --  return the Underlying_Type of this full view.
2989
2990          if Present (Full_View (Id)) then
2991             if Id = Full_View (Id) then
2992
2993                --  Previous error in declaration
2994
2995                return Empty;
2996
2997             else
2998                return Underlying_Type (Full_View (Id));
2999             end if;
3000
3001          --  If we have a private type with an underlying full view, then we
3002          --  return the Underlying_Type of this underlying full view.
3003
3004          elsif Ekind (Id) in Private_Kind
3005            and then Present (Underlying_Full_View (Id))
3006          then
3007             return Underlying_Type (Underlying_Full_View (Id));
3008
3009          --  If we have an incomplete entity that comes from the limited view
3010          --  then we return the Underlying_Type of its nonlimited view.
3011
3012          elsif From_Limited_With (Id)
3013            and then Present (Non_Limited_View (Id))
3014          then
3015             return Underlying_Type (Non_Limited_View (Id));
3016
3017          --  Otherwise check for the case where we have a derived type or
3018          --  subtype, and if so get the Underlying_Type of the parent type.
3019
3020          elsif Etype (Id) /= Id then
3021             return Underlying_Type (Etype (Id));
3022
3023          --  Otherwise we have an incomplete or private type that has no full
3024          --  view, which means that we have not encountered the completion, so
3025          --  return Empty to indicate the underlying type is not yet known.
3026
3027          else
3028             return Empty;
3029          end if;
3030
3031       --  For non-incomplete, non-private types, return the type itself. Also
3032       --  for entities that are not types at all return the entity itself.
3033
3034       else
3035          return Id;
3036       end if;
3037    end Underlying_Type;
3038
3039    ------------------------
3040    -- Unlink_Next_Entity --
3041    ------------------------
3042
3043    procedure Unlink_Next_Entity (Id : Entity_Id) is
3044       Next : constant Entity_Id := Next_Entity (Id);
3045
3046    begin
3047       if Present (Next) then
3048          Set_Prev_Entity (Next, Empty);  --  Empty <-- Next
3049       end if;
3050
3051       Set_Next_Entity (Id, Empty);       --  Id --> Empty
3052    end Unlink_Next_Entity;
3053
3054    ----------------------------------
3055    -- Is_Volatile, Set_Is_Volatile --
3056    ----------------------------------
3057
3058    function Is_Volatile (Id : E) return B is
3059    begin
3060       pragma Assert (Nkind (Id) in N_Entity);
3061
3062       if Is_Type (Id) then
3063          return Is_Volatile_Type (Base_Type (Id));
3064       else
3065          return Is_Volatile_Object (Id);
3066       end if;
3067    end Is_Volatile;
3068
3069    procedure Set_Is_Volatile (Id : E; V : B := True) is
3070    begin
3071       pragma Assert (Nkind (Id) in N_Entity);
3072
3073       if Is_Type (Id) then
3074          Set_Is_Volatile_Type (Id, V);
3075       else
3076          Set_Is_Volatile_Object (Id, V);
3077       end if;
3078    end Set_Is_Volatile;
3079
3080    -----------------------
3081    -- Write_Entity_Info --
3082    -----------------------
3083
3084    procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is
3085
3086       procedure Write_Attribute (Which : String; Nam : E);
3087       --  Write attribute value with given string name
3088
3089       procedure Write_Kind (Id : Entity_Id);
3090       --  Write Ekind field of entity
3091
3092       ---------------------
3093       -- Write_Attribute --
3094       ---------------------
3095
3096       procedure Write_Attribute (Which : String; Nam : E) is
3097       begin
3098          Write_Str (Prefix);
3099          Write_Str (Which);
3100          Write_Int (Int (Nam));
3101          Write_Str (" ");
3102          Write_Name (Chars (Nam));
3103          Write_Str (" ");
3104       end Write_Attribute;
3105
3106       ----------------
3107       -- Write_Kind --
3108       ----------------
3109
3110       procedure Write_Kind (Id : Entity_Id) is
3111          K : constant String := Entity_Kind'Image (Ekind (Id));
3112
3113       begin
3114          Write_Str (Prefix);
3115          Write_Str ("   Kind    ");
3116
3117          if Is_Type (Id) and then Is_Tagged_Type (Id) then
3118             Write_Str ("TAGGED ");
3119          end if;
3120
3121          Write_Str (K (3 .. K'Length));
3122          Write_Str (" ");
3123
3124          if Is_Type (Id) and then Depends_On_Private (Id) then
3125             Write_Str ("Depends_On_Private ");
3126          end if;
3127       end Write_Kind;
3128
3129    --  Start of processing for Write_Entity_Info
3130
3131    begin
3132       Write_Eol;
3133       Write_Attribute ("Name ", Id);
3134       Write_Int (Int (Id));
3135       Write_Eol;
3136       Write_Kind (Id);
3137       Write_Eol;
3138       Write_Attribute ("   Type    ", Etype (Id));
3139       Write_Eol;
3140       if Id /= Standard_Standard then
3141          Write_Attribute ("   Scope   ", Scope (Id));
3142       end if;
3143       Write_Eol;
3144
3145       case Ekind (Id) is
3146          when Discrete_Kind =>
3147             Write_Str ("Bounds: Id = ");
3148
3149             if Present (Scalar_Range (Id)) then
3150                Write_Int (Int (Type_Low_Bound (Id)));
3151                Write_Str (" .. Id = ");
3152                Write_Int (Int (Type_High_Bound (Id)));
3153             else
3154                Write_Str ("Empty");
3155             end if;
3156
3157             Write_Eol;
3158
3159          when Array_Kind =>
3160             declare
3161                Index : Entity_Id;
3162
3163             begin
3164                Write_Attribute
3165                  ("   Component Type    ", Component_Type (Id));
3166                Write_Eol;
3167                Write_Str (Prefix);
3168                Write_Str ("   Indexes ");
3169
3170                Index := First_Index (Id);
3171                while Present (Index) loop
3172                   Write_Attribute (" ", Etype (Index));
3173                   Index := Next_Index (Index);
3174                end loop;
3175
3176                Write_Eol;
3177             end;
3178
3179          when Access_Kind =>
3180                Write_Attribute
3181                  ("   Directly Designated Type ",
3182                   Directly_Designated_Type (Id));
3183                Write_Eol;
3184
3185          when Overloadable_Kind =>
3186             if Present (Homonym (Id)) then
3187                Write_Str ("   Homonym   ");
3188                Write_Name (Chars (Homonym (Id)));
3189                Write_Str ("   ");
3190                Write_Int (Int (Homonym (Id)));
3191                Write_Eol;
3192             end if;
3193
3194             Write_Eol;
3195
3196          when E_Component =>
3197             if Ekind (Scope (Id)) in Record_Kind then
3198                Write_Attribute (
3199                   "   Original_Record_Component   ",
3200                   Original_Record_Component (Id));
3201                Write_Int (Int (Original_Record_Component (Id)));
3202                Write_Eol;
3203             end if;
3204
3205          when others =>
3206             null;
3207       end case;
3208    end Write_Entity_Info;
3209
3210    -------------------------
3211    -- Iterator Procedures --
3212    -------------------------
3213
3214    procedure Next_Component                 (N : in out Node_Id) is
3215    begin
3216       N := Next_Component (N);
3217    end Next_Component;
3218
3219    procedure Next_Component_Or_Discriminant (N : in out Node_Id) is
3220    begin
3221       N := Next_Component_Or_Discriminant (N);
3222    end Next_Component_Or_Discriminant;
3223
3224    procedure Next_Discriminant              (N : in out Node_Id) is
3225    begin
3226       N := Next_Discriminant (N);
3227    end Next_Discriminant;
3228
3229    procedure Next_Formal                    (N : in out Node_Id) is
3230    begin
3231       N := Next_Formal (N);
3232    end Next_Formal;
3233
3234    procedure Next_Formal_With_Extras        (N : in out Node_Id) is
3235    begin
3236       N := Next_Formal_With_Extras (N);
3237    end Next_Formal_With_Extras;
3238
3239    procedure Next_Index                     (N : in out Node_Id) is
3240    begin
3241       N := Next_Index (N);
3242    end Next_Index;
3243
3244    procedure Next_Inlined_Subprogram        (N : in out Node_Id) is
3245    begin
3246       N := Next_Inlined_Subprogram (N);
3247    end Next_Inlined_Subprogram;
3248
3249    procedure Next_Literal                   (N : in out Node_Id) is
3250    begin
3251       N := Next_Literal (N);
3252    end Next_Literal;
3253
3254    procedure Next_Stored_Discriminant       (N : in out Node_Id) is
3255    begin
3256       N := Next_Stored_Discriminant (N);
3257    end Next_Stored_Discriminant;
3258
3259 end Einfo.Utils;