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_Always_Terminates         or else
1021                   Id = Pragma_Contract_Cases            or else
1022                   Id = Pragma_Exceptional_Cases         or else
1023                   Id = Pragma_Subprogram_Variant        or else
1024                   Id = Pragma_Test_Case;
1025
1026       --  Pre / postcondition pragmas
1027
1028       Is_PPC : constant Boolean :=
1029                   Id = Pragma_Precondition              or else
1030                   Id = Pragma_Postcondition             or else
1031                   Id = Pragma_Refined_Post;
1032
1033       In_Contract : constant Boolean := Is_CLS or Is_CTC or Is_PPC;
1034
1035       Item  : Node_Id;
1036       Items : Node_Id;
1037
1038    begin
1039       --  Handle pragmas that appear in N_Contract nodes. Those have to be
1040       --  extracted from their specialized list.
1041
1042       if In_Contract then
1043          Items := Contract (E);
1044
1045          if No (Items) then
1046             return Empty;
1047
1048          elsif Is_CLS then
1049             Item := Classifications (Items);
1050
1051          elsif Is_CTC then
1052             Item := Contract_Test_Cases (Items);
1053
1054          else
1055             Item := Pre_Post_Conditions (Items);
1056          end if;
1057
1058       --  Regular pragmas
1059
1060       else
1061          Item := First_Rep_Item (E);
1062       end if;
1063
1064       while Present (Item) loop
1065          if Nkind (Item) = N_Pragma
1066            and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
1067          then
1068             return Item;
1069
1070          --  All nodes in N_Contract are chained using Next_Pragma
1071
1072          elsif In_Contract then
1073             Item := Next_Pragma (Item);
1074
1075          --  Regular pragmas
1076
1077          else
1078             Next_Rep_Item (Item);
1079          end if;
1080       end loop;
1081
1082       return Empty;
1083    end Get_Pragma;
1084
1085    --------------------------------------
1086    -- Get_Record_Representation_Clause --
1087    --------------------------------------
1088
1089    function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id is
1090       N : Node_Id;
1091
1092    begin
1093       N := First_Rep_Item (E);
1094       while Present (N) loop
1095          if Nkind (N) = N_Record_Representation_Clause then
1096             return N;
1097          end if;
1098
1099          Next_Rep_Item (N);
1100       end loop;
1101
1102       return Empty;
1103    end Get_Record_Representation_Clause;
1104
1105    ------------------------
1106    -- Has_Attach_Handler --
1107    ------------------------
1108
1109    function Has_Attach_Handler (Id : E) return B is
1110       Ritem : Node_Id;
1111
1112    begin
1113       pragma Assert (Is_Protected_Type (Id));
1114
1115       Ritem := First_Rep_Item (Id);
1116       while Present (Ritem) loop
1117          if Nkind (Ritem) = N_Pragma
1118            and then Pragma_Name (Ritem) = Name_Attach_Handler
1119          then
1120             return True;
1121          else
1122             Next_Rep_Item (Ritem);
1123          end if;
1124       end loop;
1125
1126       return False;
1127    end Has_Attach_Handler;
1128
1129    -------------
1130    -- Has_DIC --
1131    -------------
1132
1133    function Has_DIC (Id : E) return B is
1134    begin
1135       return Has_Own_DIC (Id) or else Has_Inherited_DIC (Id);
1136    end Has_DIC;
1137
1138    -----------------
1139    -- Has_Entries --
1140    -----------------
1141
1142    function Has_Entries (Id : E) return B is
1143       Ent : Entity_Id;
1144
1145    begin
1146       pragma Assert (Is_Concurrent_Type (Id));
1147
1148       Ent := First_Entity (Id);
1149       while Present (Ent) loop
1150          if Is_Entry (Ent) then
1151             return True;
1152          end if;
1153
1154          Next_Entity (Ent);
1155       end loop;
1156
1157       return False;
1158    end Has_Entries;
1159
1160    ----------------------------
1161    -- Has_Foreign_Convention --
1162    ----------------------------
1163
1164    function Has_Foreign_Convention (Id : E) return B is
1165    begin
1166       --  While regular Intrinsics such as the Standard operators fit in the
1167       --  "Ada" convention, those with an Interface_Name materialize GCC
1168       --  builtin imports for which Ada special treatments shouldn't apply.
1169
1170       return Convention (Id) in Foreign_Convention
1171         or else (Convention (Id) = Convention_Intrinsic
1172                    and then Present (Interface_Name (Id)));
1173    end Has_Foreign_Convention;
1174
1175    ---------------------------
1176    -- Has_Interrupt_Handler --
1177    ---------------------------
1178
1179    function Has_Interrupt_Handler (Id : E) return B is
1180       Ritem : Node_Id;
1181
1182    begin
1183       pragma Assert (Is_Protected_Type (Id));
1184
1185       Ritem := First_Rep_Item (Id);
1186       while Present (Ritem) loop
1187          if Nkind (Ritem) = N_Pragma
1188            and then Pragma_Name (Ritem) = Name_Interrupt_Handler
1189          then
1190             return True;
1191          else
1192             Next_Rep_Item (Ritem);
1193          end if;
1194       end loop;
1195
1196       return False;
1197    end Has_Interrupt_Handler;
1198
1199    --------------------
1200    -- Has_Invariants --
1201    --------------------
1202
1203    function Has_Invariants (Id : E) return B is
1204    begin
1205       return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
1206    end Has_Invariants;
1207
1208    --------------------------
1209    -- Has_Limited_View --
1210    --------------------------
1211
1212    function Has_Limited_View (Id : E) return B is
1213    begin
1214       return Ekind (Id) = E_Package
1215         and then not Is_Generic_Instance (Id)
1216         and then Present (Limited_View (Id));
1217    end Has_Limited_View;
1218
1219    --------------------------
1220    -- Has_Non_Limited_View --
1221    --------------------------
1222
1223    function Has_Non_Limited_View (Id : E) return B is
1224    begin
1225       return (Ekind (Id) in Incomplete_Kind
1226                or else Ekind (Id) in Class_Wide_Kind
1227                or else Ekind (Id) = E_Abstract_State)
1228         and then Present (Non_Limited_View (Id));
1229    end Has_Non_Limited_View;
1230
1231    ---------------------------------
1232    -- Has_Non_Null_Abstract_State --
1233    ---------------------------------
1234
1235    function Has_Non_Null_Abstract_State (Id : E) return B is
1236    begin
1237       pragma Assert (Is_Package_Or_Generic_Package (Id));
1238
1239       return
1240         Present (Abstract_States (Id))
1241           and then
1242             not Is_Null_State (Node (First_Elmt (Abstract_States (Id))));
1243    end Has_Non_Null_Abstract_State;
1244
1245    -------------------------------------
1246    -- Has_Non_Null_Visible_Refinement --
1247    -------------------------------------
1248
1249    function Has_Non_Null_Visible_Refinement (Id : E) return B is
1250       Constits : Elist_Id;
1251
1252    begin
1253       --  "Refinement" is a concept applicable only to abstract states
1254
1255       pragma Assert (Ekind (Id) = E_Abstract_State);
1256       Constits := Refinement_Constituents (Id);
1257
1258       --  A partial refinement is always non-null. For a full refinement to be
1259       --  non-null, the first constituent must be anything other than null.
1260
1261       return
1262         Has_Partial_Visible_Refinement (Id)
1263           or else (Has_Visible_Refinement (Id)
1264                     and then Present (Constits)
1265                     and then Nkind (Node (First_Elmt (Constits))) /= N_Null);
1266    end Has_Non_Null_Visible_Refinement;
1267
1268    -----------------------------
1269    -- Has_Null_Abstract_State --
1270    -----------------------------
1271
1272    function Has_Null_Abstract_State (Id : E) return B is
1273       pragma Assert (Is_Package_Or_Generic_Package (Id));
1274
1275       States : constant Elist_Id := Abstract_States (Id);
1276
1277    begin
1278       --  Check first available state of related package. A null abstract
1279       --  state always appears as the sole element of the state list.
1280
1281       return
1282         Present (States)
1283           and then Is_Null_State (Node (First_Elmt (States)));
1284    end Has_Null_Abstract_State;
1285
1286    ---------------------------------
1287    -- Has_Null_Visible_Refinement --
1288    ---------------------------------
1289
1290    function Has_Null_Visible_Refinement (Id : E) return B is
1291       Constits : Elist_Id;
1292
1293    begin
1294       --  "Refinement" is a concept applicable only to abstract states
1295
1296       pragma Assert (Ekind (Id) = E_Abstract_State);
1297       Constits := Refinement_Constituents (Id);
1298
1299       --  For a refinement to be null, the state's sole constituent must be a
1300       --  null.
1301
1302       return
1303         Has_Visible_Refinement (Id)
1304           and then Present (Constits)
1305           and then Nkind (Node (First_Elmt (Constits))) = N_Null;
1306    end Has_Null_Visible_Refinement;
1307
1308    --------------------
1309    -- Has_Unmodified --
1310    --------------------
1311
1312    function Has_Unmodified (E : Entity_Id) return Boolean is
1313    begin
1314       if Has_Pragma_Unmodified (E) then
1315          return True;
1316       elsif Warnings_Off (E) then
1317          Set_Warnings_Off_Used_Unmodified (E);
1318          return True;
1319       else
1320          return False;
1321       end if;
1322    end Has_Unmodified;
1323
1324    ---------------------
1325    -- Has_Unreferenced --
1326    ---------------------
1327
1328    function Has_Unreferenced (E : Entity_Id) return Boolean is
1329    begin
1330       if Has_Pragma_Unreferenced (E) then
1331          return True;
1332       elsif Warnings_Off (E) then
1333          Set_Warnings_Off_Used_Unreferenced (E);
1334          return True;
1335       else
1336          return False;
1337       end if;
1338    end Has_Unreferenced;
1339
1340    ----------------------
1341    -- Has_Warnings_Off --
1342    ----------------------
1343
1344    function Has_Warnings_Off (E : Entity_Id) return Boolean is
1345    begin
1346       if Warnings_Off (E) then
1347          Set_Warnings_Off_Used (E);
1348          return True;
1349       else
1350          return False;
1351       end if;
1352    end Has_Warnings_Off;
1353
1354    ------------------------------
1355    -- Implementation_Base_Type --
1356    ------------------------------
1357
1358    function Implementation_Base_Type (Id : E) return E is
1359       Bastyp : Entity_Id;
1360       Imptyp : Entity_Id;
1361
1362    begin
1363       Bastyp := Base_Type (Id);
1364
1365       if Is_Incomplete_Or_Private_Type (Bastyp) then
1366          Imptyp := Underlying_Type (Bastyp);
1367
1368          --  If we have an implementation type, then just return it,
1369          --  otherwise we return the Base_Type anyway. This can only
1370          --  happen in error situations and should avoid some error bombs.
1371
1372          if Present (Imptyp) then
1373             return Base_Type (Imptyp);
1374          else
1375             return Bastyp;
1376          end if;
1377
1378       else
1379          return Bastyp;
1380       end if;
1381    end Implementation_Base_Type;
1382
1383    -------------------------
1384    -- Invariant_Procedure --
1385    -------------------------
1386
1387    function Invariant_Procedure (Id : E) return Entity_Id is
1388       Subp_Elmt : Elmt_Id;
1389       Subp_Id   : Entity_Id;
1390       Subps     : Elist_Id;
1391
1392    begin
1393       pragma Assert (Is_Type (Id));
1394
1395       Subps := Subprograms_For_Type (Base_Type (Id));
1396
1397       if Present (Subps) then
1398          Subp_Elmt := First_Elmt (Subps);
1399          while Present (Subp_Elmt) loop
1400             Subp_Id := Node (Subp_Elmt);
1401
1402             if Is_Invariant_Procedure (Subp_Id) then
1403                return Subp_Id;
1404             end if;
1405
1406             Next_Elmt (Subp_Elmt);
1407          end loop;
1408       end if;
1409
1410       return Empty;
1411    end Invariant_Procedure;
1412
1413    ------------------
1414    -- Is_Base_Type --
1415    ------------------
1416
1417    --  Global flag table allowing rapid computation of this function
1418
1419    Entity_Is_Base_Type : constant array (Entity_Kind) of Boolean :=
1420      (E_Enumeration_Subtype          |
1421       E_Incomplete_Subtype           |
1422       E_Signed_Integer_Subtype       |
1423       E_Modular_Integer_Subtype      |
1424       E_Floating_Point_Subtype       |
1425       E_Ordinary_Fixed_Point_Subtype |
1426       E_Decimal_Fixed_Point_Subtype  |
1427       E_Array_Subtype                |
1428       E_Record_Subtype               |
1429       E_Private_Subtype              |
1430       E_Record_Subtype_With_Private  |
1431       E_Limited_Private_Subtype      |
1432       E_Access_Subtype               |
1433       E_Protected_Subtype            |
1434       E_Task_Subtype                 |
1435       E_String_Literal_Subtype       |
1436       E_Class_Wide_Subtype           => False,
1437       others                         => True);
1438
1439    function Is_Base_Type (Id : E) return Boolean is
1440    begin
1441       return Entity_Is_Base_Type (Ekind (Id));
1442    end Is_Base_Type;
1443
1444    ---------------------
1445    -- Is_Boolean_Type --
1446    ---------------------
1447
1448    function Is_Boolean_Type (Id : E) return B is
1449    begin
1450       return Root_Type (Id) = Standard_Boolean;
1451    end Is_Boolean_Type;
1452
1453    ------------------------
1454    -- Is_Constant_Object --
1455    ------------------------
1456
1457    function Is_Constant_Object (Id : E) return B is
1458    begin
1459       return Ekind (Id) in E_Constant | E_In_Parameter | E_Loop_Parameter;
1460    end Is_Constant_Object;
1461
1462    -------------------
1463    -- Is_Controlled --
1464    -------------------
1465
1466    function Is_Controlled (Id : E) return B is
1467    begin
1468       return Is_Controlled_Active (Id) and then not Disable_Controlled (Id);
1469    end Is_Controlled;
1470
1471    --------------------
1472    -- Is_Discriminal --
1473    --------------------
1474
1475    function Is_Discriminal (Id : E) return B is
1476    begin
1477       return Ekind (Id) in E_Constant | E_In_Parameter
1478                and then Present (Discriminal_Link (Id));
1479    end Is_Discriminal;
1480
1481    ----------------------
1482    -- Is_Dynamic_Scope --
1483    ----------------------
1484
1485    function Is_Dynamic_Scope (Id : E) return B is
1486    begin
1487       return Ekind (Id) in E_Block
1488       --  Including an E_Block that came from an N_Expression_With_Actions
1489                          | E_Entry
1490                          | E_Entry_Family
1491                          | E_Function
1492                          | E_Procedure
1493                          | E_Return_Statement
1494                          | E_Subprogram_Body
1495                          | E_Task_Type
1496           or else
1497         (Ekind (Id) = E_Limited_Private_Type
1498           and then Present (Full_View (Id))
1499           and then Ekind (Full_View (Id)) = E_Task_Type);
1500    end Is_Dynamic_Scope;
1501
1502    --------------------
1503    -- Is_Entity_Name --
1504    --------------------
1505
1506    function Is_Entity_Name (N : Node_Id) return Boolean is
1507       Kind : constant Node_Kind := Nkind (N);
1508
1509    begin
1510       --  Identifiers, operator symbols, expanded names are entity names.
1511       --  (But not N_Character_Literal.)
1512
1513       return Kind in N_Identifier | N_Operator_Symbol | N_Expanded_Name
1514
1515       --  Attribute references are entity names if they refer to an entity.
1516       --  Note that we don't do this by testing for the presence of the
1517       --  Entity field in the N_Attribute_Reference node, since it may not
1518       --  have been set yet.
1519
1520         or else (Kind = N_Attribute_Reference
1521                   and then Is_Entity_Attribute_Name (Attribute_Name (N)));
1522    end Is_Entity_Name;
1523
1524    ---------------------------
1525    -- Is_Elaboration_Target --
1526    ---------------------------
1527
1528    function Is_Elaboration_Target (Id : E) return Boolean is
1529    begin
1530       return
1531         Ekind (Id) in E_Constant | E_Package | E_Variable
1532           or else Is_Entry        (Id)
1533           or else Is_Generic_Unit (Id)
1534           or else Is_Subprogram   (Id)
1535           or else Is_Task_Type    (Id);
1536    end Is_Elaboration_Target;
1537
1538    -----------------------
1539    -- Is_External_State --
1540    -----------------------
1541
1542    function Is_External_State (Id : E) return B is
1543    begin
1544       --  To qualify, the abstract state must appear with option "external" or
1545       --  "synchronous" (SPARK RM 7.1.4(7) and (9)).
1546
1547       return
1548         Ekind (Id) = E_Abstract_State
1549           and then (Has_Option (Id, Name_External)
1550                       or else
1551                     Has_Option (Id, Name_Synchronous));
1552    end Is_External_State;
1553
1554    ------------------
1555    -- Is_Finalizer --
1556    ------------------
1557
1558    function Is_Finalizer (Id : E) return B is
1559    begin
1560       return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
1561    end Is_Finalizer;
1562
1563    ----------------------
1564    -- Is_Full_Access --
1565    ----------------------
1566
1567    function Is_Full_Access (Id : E) return B is
1568    begin
1569       return Is_Atomic (Id) or else Is_Volatile_Full_Access (Id);
1570    end Is_Full_Access;
1571
1572    -------------------
1573    -- Is_Null_State --
1574    -------------------
1575
1576    function Is_Null_State (Id : E) return B is
1577    begin
1578       return
1579         Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null;
1580    end Is_Null_State;
1581
1582    -----------------------------------
1583    -- Is_Package_Or_Generic_Package --
1584    -----------------------------------
1585
1586    function Is_Package_Or_Generic_Package (Id : E) return B is
1587    begin
1588       return Ekind (Id) in E_Generic_Package | E_Package;
1589    end Is_Package_Or_Generic_Package;
1590
1591    ---------------------
1592    -- Is_Packed_Array --
1593    ---------------------
1594
1595    function Is_Packed_Array (Id : E) return B is
1596    begin
1597       return Is_Array_Type (Id) and then Is_Packed (Id);
1598    end Is_Packed_Array;
1599
1600    ---------------
1601    -- Is_Prival --
1602    ---------------
1603
1604    function Is_Prival (Id : E) return B is
1605    begin
1606       return Ekind (Id) in E_Constant | E_Variable
1607                and then Present (Prival_Link (Id));
1608    end Is_Prival;
1609
1610    ----------------------------
1611    -- Is_Protected_Component --
1612    ----------------------------
1613
1614    function Is_Protected_Component (Id : E) return B is
1615    begin
1616       return Ekind (Id) = E_Component and then Is_Protected_Type (Scope (Id));
1617    end Is_Protected_Component;
1618
1619    ----------------------------
1620    -- Is_Protected_Interface --
1621    ----------------------------
1622
1623    function Is_Protected_Interface (Id : E) return B is
1624       Typ : constant Entity_Id := Base_Type (Id);
1625    begin
1626       if not Is_Interface (Typ) then
1627          return False;
1628       elsif Is_Class_Wide_Type (Typ) then
1629          return Is_Protected_Interface (Etype (Typ));
1630       else
1631          return Protected_Present (Type_Definition (Parent (Typ)));
1632       end if;
1633    end Is_Protected_Interface;
1634
1635    ------------------------------
1636    -- Is_Protected_Record_Type --
1637    ------------------------------
1638
1639    function Is_Protected_Record_Type (Id : E) return B is
1640    begin
1641       return
1642         Is_Concurrent_Record_Type (Id)
1643           and then Is_Protected_Type (Corresponding_Concurrent_Type (Id));
1644    end Is_Protected_Record_Type;
1645
1646    -------------------------------------
1647    -- Is_Relaxed_Initialization_State --
1648    -------------------------------------
1649
1650    function Is_Relaxed_Initialization_State (Id : E) return B is
1651    begin
1652       --  To qualify, the abstract state must appear with simple option
1653       --  "Relaxed_Initialization" (SPARK RM 6.10).
1654
1655       return
1656         Ekind (Id) = E_Abstract_State
1657           and then Has_Option (Id, Name_Relaxed_Initialization);
1658    end Is_Relaxed_Initialization_State;
1659
1660    --------------------------------
1661    -- Is_Standard_Character_Type --
1662    --------------------------------
1663
1664    function Is_Standard_Character_Type (Id : E) return B is
1665    begin
1666       return Is_Type (Id)
1667         and then Root_Type (Id) in Standard_Character
1668                                  | Standard_Wide_Character
1669                                  | Standard_Wide_Wide_Character;
1670    end Is_Standard_Character_Type;
1671
1672    -----------------------------
1673    -- Is_Standard_String_Type --
1674    -----------------------------
1675
1676    function Is_Standard_String_Type (Id : E) return B is
1677    begin
1678       return Is_Type (Id)
1679         and then Root_Type (Id) in Standard_String
1680                                  | Standard_Wide_String
1681                                  | Standard_Wide_Wide_String;
1682    end Is_Standard_String_Type;
1683
1684    --------------------
1685    -- Is_String_Type --
1686    --------------------
1687
1688    function Is_String_Type (Id : E) return B is
1689    begin
1690       return Is_Array_Type (Id)
1691         and then Id /= Any_Composite
1692         and then Number_Dimensions (Id) = 1
1693         and then Is_Character_Type (Component_Type (Id));
1694    end Is_String_Type;
1695
1696    -------------------------------
1697    -- Is_Synchronized_Interface --
1698    -------------------------------
1699
1700    function Is_Synchronized_Interface (Id : E) return B is
1701       Typ : constant Entity_Id := Base_Type (Id);
1702
1703    begin
1704       if not Is_Interface (Typ) then
1705          return False;
1706
1707       elsif Is_Class_Wide_Type (Typ) then
1708          return Is_Synchronized_Interface (Etype (Typ));
1709
1710       else
1711          return    Protected_Present    (Type_Definition (Parent (Typ)))
1712            or else Synchronized_Present (Type_Definition (Parent (Typ)))
1713            or else Task_Present         (Type_Definition (Parent (Typ)));
1714       end if;
1715    end Is_Synchronized_Interface;
1716
1717    ---------------------------
1718    -- Is_Synchronized_State --
1719    ---------------------------
1720
1721    function Is_Synchronized_State (Id : E) return B is
1722    begin
1723       --  To qualify, the abstract state must appear with simple option
1724       --  "synchronous" (SPARK RM 7.1.4(9)).
1725
1726       return
1727         Ekind (Id) = E_Abstract_State
1728           and then Has_Option (Id, Name_Synchronous);
1729    end Is_Synchronized_State;
1730
1731    -----------------------
1732    -- Is_Task_Interface --
1733    -----------------------
1734
1735    function Is_Task_Interface (Id : E) return B is
1736       Typ : constant Entity_Id := Base_Type (Id);
1737    begin
1738       if not Is_Interface (Typ) then
1739          return False;
1740       elsif Is_Class_Wide_Type (Typ) then
1741          return Is_Task_Interface (Etype (Typ));
1742       else
1743          return Task_Present (Type_Definition (Parent (Typ)));
1744       end if;
1745    end Is_Task_Interface;
1746
1747    -------------------------
1748    -- Is_Task_Record_Type --
1749    -------------------------
1750
1751    function Is_Task_Record_Type (Id : E) return B is
1752    begin
1753       return
1754         Is_Concurrent_Record_Type (Id)
1755           and then Is_Task_Type (Corresponding_Concurrent_Type (Id));
1756    end Is_Task_Record_Type;
1757
1758    ------------------------
1759    -- Is_Wrapper_Package --
1760    ------------------------
1761
1762    function Is_Wrapper_Package (Id : E) return B is
1763    begin
1764       return Ekind (Id) = E_Package and then Present (Related_Instance (Id));
1765    end Is_Wrapper_Package;
1766
1767    -----------------
1768    -- Last_Formal --
1769    -----------------
1770
1771    function Last_Formal (Id : E) return Entity_Id is
1772       Formal : Entity_Id;
1773
1774    begin
1775       pragma Assert
1776         (Is_Overloadable (Id)
1777           or else Ekind (Id) in E_Entry_Family
1778                               | E_Subprogram_Body
1779                               | E_Subprogram_Type);
1780
1781       if Ekind (Id) = E_Enumeration_Literal then
1782          return Empty;
1783
1784       else
1785          Formal := First_Formal (Id);
1786
1787          if Present (Formal) then
1788             while Present (Next_Formal (Formal)) loop
1789                Next_Formal (Formal);
1790             end loop;
1791          end if;
1792
1793          return Formal;
1794       end if;
1795    end Last_Formal;
1796
1797    -------------------
1798    -- Link_Entities --
1799    -------------------
1800
1801    procedure Link_Entities (First, Second : Entity_Id) is
1802    begin
1803       if Present (Second) then
1804          Set_Prev_Entity (Second, First);  --  First <-- Second
1805       end if;
1806
1807       Set_Next_Entity (First, Second);     --  First --> Second
1808    end Link_Entities;
1809
1810    ------------------------
1811    -- Machine_Emax_Value --
1812    ------------------------
1813
1814    function Machine_Emax_Value (Id : E) return Uint is
1815       Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
1816
1817    begin
1818       case Float_Rep (Id) is
1819          when IEEE_Binary =>
1820             case Digs is
1821                when  1 ..  6 => return Uint_128;
1822                when  7 .. 15 => return 2**10;
1823                when 16 .. 33 => return 2**14;
1824                when others   => return No_Uint;
1825             end case;
1826       end case;
1827    end Machine_Emax_Value;
1828
1829    ------------------------
1830    -- Machine_Emin_Value --
1831    ------------------------
1832
1833    function Machine_Emin_Value (Id : E) return Uint is
1834    begin
1835       case Float_Rep (Id) is
1836          when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
1837       end case;
1838    end Machine_Emin_Value;
1839
1840    ----------------------------
1841    -- Machine_Mantissa_Value --
1842    ----------------------------
1843
1844    function Machine_Mantissa_Value (Id : E) return Uint is
1845       Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
1846
1847    begin
1848       case Float_Rep (Id) is
1849          when IEEE_Binary =>
1850             case Digs is
1851                when  1 ..  6 => return Uint_24;
1852                when  7 .. 15 => return UI_From_Int (53);
1853                when 16 .. 18 => return Uint_64;
1854                when 19 .. 33 => return UI_From_Int (113);
1855                when others   => return No_Uint;
1856             end case;
1857       end case;
1858    end Machine_Mantissa_Value;
1859
1860    -------------------------
1861    -- Machine_Radix_Value --
1862    -------------------------
1863
1864    function Machine_Radix_Value (Id : E) return U is
1865    begin
1866       case Float_Rep (Id) is
1867          when IEEE_Binary =>
1868             return Uint_2;
1869       end case;
1870    end Machine_Radix_Value;
1871
1872    ----------------------
1873    -- Model_Emin_Value --
1874    ----------------------
1875
1876    function Model_Emin_Value (Id : E) return Uint is
1877    begin
1878       return Machine_Emin_Value (Id);
1879    end Model_Emin_Value;
1880
1881    -------------------------
1882    -- Model_Epsilon_Value --
1883    -------------------------
1884
1885    function Model_Epsilon_Value (Id : E) return Ureal is
1886       Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
1887    begin
1888       return Radix ** (1 - Model_Mantissa_Value (Id));
1889    end Model_Epsilon_Value;
1890
1891    --------------------------
1892    -- Model_Mantissa_Value --
1893    --------------------------
1894
1895    function Model_Mantissa_Value (Id : E) return Uint is
1896    begin
1897       return Machine_Mantissa_Value (Id);
1898    end Model_Mantissa_Value;
1899
1900    -----------------------
1901    -- Model_Small_Value --
1902    -----------------------
1903
1904    function Model_Small_Value (Id : E) return Ureal is
1905       Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
1906    begin
1907       return Radix ** (Model_Emin_Value (Id) - 1);
1908    end Model_Small_Value;
1909
1910    --------------------
1911    -- Next_Component --
1912    --------------------
1913
1914    function Next_Component (Id : E) return Entity_Id is
1915       Comp_Id : Entity_Id;
1916
1917    begin
1918       Comp_Id := Next_Entity (Id);
1919       while Present (Comp_Id) loop
1920          exit when Ekind (Comp_Id) = E_Component;
1921          Next_Entity (Comp_Id);
1922       end loop;
1923
1924       return Comp_Id;
1925    end Next_Component;
1926
1927    ------------------------------------
1928    -- Next_Component_Or_Discriminant --
1929    ------------------------------------
1930
1931    function Next_Component_Or_Discriminant (Id : E) return Entity_Id is
1932       Comp_Id : Entity_Id;
1933
1934    begin
1935       Comp_Id := Next_Entity (Id);
1936       while Present (Comp_Id) loop
1937          exit when Ekind (Comp_Id) in E_Component | E_Discriminant;
1938          Next_Entity (Comp_Id);
1939       end loop;
1940
1941       return Comp_Id;
1942    end Next_Component_Or_Discriminant;
1943
1944    -----------------------
1945    -- Next_Discriminant --
1946    -----------------------
1947
1948    --  This function actually implements both Next_Discriminant and
1949    --  Next_Stored_Discriminant by making sure that the Discriminant
1950    --  returned is of the same variety as Id.
1951
1952    function Next_Discriminant (Id : E) return Entity_Id is
1953
1954       --  Derived Tagged types with private extensions look like this...
1955
1956       --       E_Discriminant d1
1957       --       E_Discriminant d2
1958       --       E_Component    _tag
1959       --       E_Discriminant d1
1960       --       E_Discriminant d2
1961       --       ...
1962
1963       --  so it is critical not to go past the leading discriminants
1964
1965       D : Entity_Id := Id;
1966
1967    begin
1968       pragma Assert (Ekind (Id) = E_Discriminant);
1969
1970       loop
1971          Next_Entity (D);
1972          if No (D)
1973            or else (Ekind (D) /= E_Discriminant
1974                       and then not Is_Itype (D))
1975          then
1976             return Empty;
1977          end if;
1978
1979          exit when Ekind (D) = E_Discriminant
1980            and then Is_Completely_Hidden (D) = Is_Completely_Hidden (Id);
1981       end loop;
1982
1983       return D;
1984    end Next_Discriminant;
1985
1986    -----------------
1987    -- Next_Formal --
1988    -----------------
1989
1990    function Next_Formal (Id : E) return Entity_Id is
1991       P : Entity_Id;
1992
1993    begin
1994       --  Follow the chain of declared entities as long as the kind of the
1995       --  entity corresponds to a formal parameter. Skip internal entities
1996       --  that may have been created for implicit subtypes, in the process
1997       --  of analyzing default expressions.
1998
1999       P := Id;
2000       loop
2001          Next_Entity (P);
2002
2003          if No (P) or else Is_Formal (P) then
2004             return P;
2005          elsif not Is_Internal (P) then
2006             return Empty;
2007          end if;
2008       end loop;
2009    end Next_Formal;
2010
2011    -----------------------------
2012    -- Next_Formal_With_Extras --
2013    -----------------------------
2014
2015    function Next_Formal_With_Extras (Id : E) return Entity_Id is
2016    begin
2017       if Present (Extra_Formal (Id)) then
2018          return Extra_Formal (Id);
2019       else
2020          return Next_Formal (Id);
2021       end if;
2022    end Next_Formal_With_Extras;
2023
2024    ----------------
2025    -- Next_Index --
2026    ----------------
2027
2028    function Next_Index (Id : N) return Node_Id is
2029    begin
2030       pragma Assert (Nkind (Id) in N_Is_Index);
2031       pragma Assert (No (Next (Id)) or else Nkind (Next (Id)) in N_Is_Index);
2032       return Next (Id);
2033    end Next_Index;
2034
2035    ------------------
2036    -- Next_Literal --
2037    ------------------
2038
2039    function Next_Literal (Id : E) return Entity_Id is
2040    begin
2041       pragma Assert (Nkind (Id) in N_Entity);
2042       return Next (Id);
2043    end Next_Literal;
2044
2045    ------------------------------
2046    -- Next_Stored_Discriminant --
2047    ------------------------------
2048
2049    function Next_Stored_Discriminant (Id : E) return Entity_Id is
2050    begin
2051       --  See comment in Next_Discriminant
2052
2053       return Next_Discriminant (Id);
2054    end Next_Stored_Discriminant;
2055
2056    -----------------------
2057    -- Number_Dimensions --
2058    -----------------------
2059
2060    function Number_Dimensions (Id : E) return Pos is
2061       N : Int;
2062       T : Node_Id;
2063
2064    begin
2065       if Ekind (Id) = E_String_Literal_Subtype then
2066          return 1;
2067
2068       else
2069          N := 0;
2070          T := First_Index (Id);
2071          while Present (T) loop
2072             N := N + 1;
2073             Next_Index (T);
2074          end loop;
2075
2076          return N;
2077       end if;
2078    end Number_Dimensions;
2079
2080    --------------------
2081    -- Number_Entries --
2082    --------------------
2083
2084    function Number_Entries (Id : E) return Nat is
2085       N   : Nat;
2086       Ent : Entity_Id;
2087
2088    begin
2089       pragma Assert (Is_Concurrent_Type (Id));
2090
2091       N := 0;
2092       Ent := First_Entity (Id);
2093       while Present (Ent) loop
2094          if Is_Entry (Ent) then
2095             N := N + 1;
2096          end if;
2097
2098          Next_Entity (Ent);
2099       end loop;
2100
2101       return N;
2102    end Number_Entries;
2103
2104    --------------------
2105    -- Number_Formals --
2106    --------------------
2107
2108    function Number_Formals (Id : E) return Nat is
2109       N      : Nat;
2110       Formal : Entity_Id;
2111
2112    begin
2113       N := 0;
2114       Formal := First_Formal (Id);
2115       while Present (Formal) loop
2116          N := N + 1;
2117          Next_Formal (Formal);
2118       end loop;
2119
2120       return N;
2121    end Number_Formals;
2122
2123    ------------------------
2124    -- Object_Size_Clause --
2125    ------------------------
2126
2127    function Object_Size_Clause (Id : E) return Node_Id is
2128    begin
2129       return Get_Attribute_Definition_Clause (Id, Attribute_Object_Size);
2130    end Object_Size_Clause;
2131
2132    --------------------
2133    -- Parameter_Mode --
2134    --------------------
2135
2136    function Parameter_Mode (Id : E) return Formal_Kind is
2137    begin
2138       return Ekind (Id);
2139    end Parameter_Mode;
2140
2141    -------------------
2142    -- DIC_Procedure --
2143    -------------------
2144
2145    function DIC_Procedure (Id : E) return Entity_Id is
2146       Subp_Elmt : Elmt_Id;
2147       Subp_Id   : Entity_Id;
2148       Subps     : Elist_Id;
2149
2150    begin
2151       pragma Assert (Is_Type (Id));
2152
2153       Subps := Subprograms_For_Type (Base_Type (Id));
2154
2155       if Present (Subps) then
2156          Subp_Elmt := First_Elmt (Subps);
2157          while Present (Subp_Elmt) loop
2158             Subp_Id := Node (Subp_Elmt);
2159
2160             --  Currently the flag Is_DIC_Procedure is set for both normal DIC
2161             --  check procedures as well as for partial DIC check procedures,
2162             --  and we don't have a flag for the partial procedures.
2163
2164             if Is_DIC_Procedure (Subp_Id)
2165               and then not Is_Partial_DIC_Procedure (Subp_Id)
2166             then
2167                return Subp_Id;
2168             end if;
2169
2170             Next_Elmt (Subp_Elmt);
2171          end loop;
2172       end if;
2173
2174       return Empty;
2175    end DIC_Procedure;
2176
2177    function Partial_DIC_Procedure (Id : E) return Entity_Id is
2178       Subp_Elmt : Elmt_Id;
2179       Subp_Id   : Entity_Id;
2180       Subps     : Elist_Id;
2181
2182    begin
2183       pragma Assert (Is_Type (Id));
2184
2185       Subps := Subprograms_For_Type (Base_Type (Id));
2186
2187       if Present (Subps) then
2188          Subp_Elmt := First_Elmt (Subps);
2189          while Present (Subp_Elmt) loop
2190             Subp_Id := Node (Subp_Elmt);
2191
2192             if Is_Partial_DIC_Procedure (Subp_Id) then
2193                return Subp_Id;
2194             end if;
2195
2196             Next_Elmt (Subp_Elmt);
2197          end loop;
2198       end if;
2199
2200       return Empty;
2201    end Partial_DIC_Procedure;
2202
2203    function Is_Partial_DIC_Procedure (Id : E) return B is
2204       Partial_DIC_Suffix : constant String := "Partial_DIC";
2205       DIC_Nam            : constant String := Get_Name_String (Chars (Id));
2206
2207    begin
2208       pragma Assert (Ekind (Id) in E_Function | E_Procedure);
2209
2210       --  Instead of adding a new Entity_Id flag (which are in short supply),
2211       --  we test the form of the subprogram name. When the node field and flag
2212       --  situation is eased, this should be replaced with a flag. ???
2213
2214       if DIC_Nam'Length > Partial_DIC_Suffix'Length
2215         and then
2216           DIC_Nam
2217             (DIC_Nam'Last - Partial_DIC_Suffix'Length + 1 .. DIC_Nam'Last) =
2218                Partial_DIC_Suffix
2219       then
2220          return True;
2221       else
2222          return False;
2223       end if;
2224    end Is_Partial_DIC_Procedure;
2225
2226    ---------------------------------
2227    -- Partial_Invariant_Procedure --
2228    ---------------------------------
2229
2230    function Partial_Invariant_Procedure (Id : E) return Entity_Id is
2231       Subp_Elmt : Elmt_Id;
2232       Subp_Id   : Entity_Id;
2233       Subps     : Elist_Id;
2234
2235    begin
2236       pragma Assert (Is_Type (Id));
2237
2238       Subps := Subprograms_For_Type (Base_Type (Id));
2239
2240       if Present (Subps) then
2241          Subp_Elmt := First_Elmt (Subps);
2242          while Present (Subp_Elmt) loop
2243             Subp_Id := Node (Subp_Elmt);
2244
2245             if Is_Partial_Invariant_Procedure (Subp_Id) then
2246                return Subp_Id;
2247             end if;
2248
2249             Next_Elmt (Subp_Elmt);
2250          end loop;
2251       end if;
2252
2253       return Empty;
2254    end Partial_Invariant_Procedure;
2255
2256    -------------------------------------
2257    -- Partial_Refinement_Constituents --
2258    -------------------------------------
2259
2260    function Partial_Refinement_Constituents (Id : E) return L is
2261       Constits : Elist_Id := No_Elist;
2262
2263       procedure Add_Usable_Constituents (Item : E);
2264       --  Add global item Item and/or its constituents to list Constits when
2265       --  they can be used in a global refinement within the current scope. The
2266       --  criteria are:
2267       --    1) If Item is an abstract state with full refinement visible, add
2268       --       its constituents.
2269       --    2) If Item is an abstract state with only partial refinement
2270       --       visible, add both Item and its constituents.
2271       --    3) If Item is an abstract state without a visible refinement, add
2272       --       it.
2273       --    4) If Id is not an abstract state, add it.
2274
2275       procedure Add_Usable_Constituents (List : Elist_Id);
2276       --  Apply Add_Usable_Constituents to every constituent in List
2277
2278       -----------------------------
2279       -- Add_Usable_Constituents --
2280       -----------------------------
2281
2282       procedure Add_Usable_Constituents (Item : E) is
2283       begin
2284          if Ekind (Item) = E_Abstract_State then
2285             if Has_Visible_Refinement (Item) then
2286                Add_Usable_Constituents (Refinement_Constituents (Item));
2287
2288             elsif Has_Partial_Visible_Refinement (Item) then
2289                Append_New_Elmt (Item, Constits);
2290                Add_Usable_Constituents (Part_Of_Constituents (Item));
2291
2292             else
2293                Append_New_Elmt (Item, Constits);
2294             end if;
2295
2296          else
2297             Append_New_Elmt (Item, Constits);
2298          end if;
2299       end Add_Usable_Constituents;
2300
2301       procedure Add_Usable_Constituents (List : Elist_Id) is
2302          Constit_Elmt : Elmt_Id;
2303       begin
2304          if Present (List) then
2305             Constit_Elmt := First_Elmt (List);
2306             while Present (Constit_Elmt) loop
2307                Add_Usable_Constituents (Node (Constit_Elmt));
2308                Next_Elmt (Constit_Elmt);
2309             end loop;
2310          end if;
2311       end Add_Usable_Constituents;
2312
2313    --  Start of processing for Partial_Refinement_Constituents
2314
2315    begin
2316       --  "Refinement" is a concept applicable only to abstract states
2317
2318       pragma Assert (Ekind (Id) = E_Abstract_State);
2319
2320       if Has_Visible_Refinement (Id) then
2321          Constits := Refinement_Constituents (Id);
2322
2323       --  A refinement may be partially visible when objects declared in the
2324       --  private part of a package are subject to a Part_Of indicator.
2325
2326       elsif Has_Partial_Visible_Refinement (Id) then
2327          Add_Usable_Constituents (Part_Of_Constituents (Id));
2328
2329       --  Function should only be called when full or partial refinement is
2330       --  visible.
2331
2332       else
2333          raise Program_Error;
2334       end if;
2335
2336       return Constits;
2337    end Partial_Refinement_Constituents;
2338
2339    ------------------------
2340    -- Predicate_Function --
2341    ------------------------
2342
2343    function Predicate_Function (Id : E) return Entity_Id is
2344       Subp_Elmt : Elmt_Id;
2345       Subp_Id   : Entity_Id;
2346       Subps     : Elist_Id;
2347       Typ       : Entity_Id;
2348
2349    begin
2350       pragma Assert (Is_Type (Id));
2351
2352       --  If type is private and has a completion, predicate may be defined on
2353       --  the full view.
2354
2355       if Is_Private_Type (Id)
2356          and then
2357            (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
2358          and then Present (Full_View (Id))
2359       then
2360          Typ := Full_View (Id);
2361
2362       elsif Ekind (Id) in E_Array_Subtype
2363                         | E_Record_Subtype
2364                         | E_Record_Subtype_With_Private
2365         and then Present (Predicated_Parent (Id))
2366       then
2367          Typ := Predicated_Parent (Id);
2368
2369       else
2370          Typ := Id;
2371       end if;
2372
2373       Subps := Subprograms_For_Type (Typ);
2374
2375       if Present (Subps) then
2376          Subp_Elmt := First_Elmt (Subps);
2377          while Present (Subp_Elmt) loop
2378             Subp_Id := Node (Subp_Elmt);
2379
2380             if Ekind (Subp_Id) = E_Function
2381               and then Is_Predicate_Function (Subp_Id)
2382             then
2383                return Subp_Id;
2384             end if;
2385
2386             Next_Elmt (Subp_Elmt);
2387          end loop;
2388       end if;
2389
2390       return Empty;
2391    end Predicate_Function;
2392
2393    -------------------------
2394    -- Present_In_Rep_Item --
2395    -------------------------
2396
2397    function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
2398       Ritem : Node_Id;
2399
2400    begin
2401       Ritem := First_Rep_Item (E);
2402
2403       while Present (Ritem) loop
2404          if Ritem = N then
2405             return True;
2406          end if;
2407
2408          Next_Rep_Item (Ritem);
2409       end loop;
2410
2411       return False;
2412    end Present_In_Rep_Item;
2413
2414    --------------------------
2415    -- Primitive_Operations --
2416    --------------------------
2417
2418    function Primitive_Operations (Id : E) return L is
2419    begin
2420       if Is_Concurrent_Type (Id) then
2421          if Present (Corresponding_Record_Type (Id)) then
2422             return Direct_Primitive_Operations
2423               (Corresponding_Record_Type (Id));
2424
2425          --  When expansion is disabled, the corresponding record type is
2426          --  absent, but if this is a tagged type with ancestors, or if the
2427          --  extension of prefixed calls for untagged types is enabled, then
2428          --  it may have associated primitive operations.
2429
2430          else
2431             return Direct_Primitive_Operations (Id);
2432          end if;
2433
2434       else
2435          return Direct_Primitive_Operations (Id);
2436       end if;
2437    end Primitive_Operations;
2438
2439    ---------------------
2440    -- Record_Rep_Item --
2441    ---------------------
2442
2443    procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is
2444    begin
2445       Set_Next_Rep_Item (N, First_Rep_Item (E));
2446       Set_First_Rep_Item (E, N);
2447    end Record_Rep_Item;
2448
2449    -------------------
2450    -- Remove_Entity --
2451    -------------------
2452
2453    procedure Remove_Entity (Id : Entity_Id) is
2454       Next  : constant Entity_Id := Next_Entity (Id);
2455       Prev  : constant Entity_Id := Prev_Entity (Id);
2456       Scop  : constant Entity_Id := Scope (Id);
2457       First : constant Entity_Id := First_Entity (Scop);
2458       Last  : constant Entity_Id := Last_Entity  (Scop);
2459
2460    begin
2461       --  Eliminate any existing linkages from the entity
2462
2463       Set_Prev_Entity (Id, Empty);  --  Empty <-- Id
2464       Set_Next_Entity (Id, Empty);  --  Id --> Empty
2465
2466       --  The eliminated entity was the only element in the entity chain
2467
2468       if Id = First and then Id = Last then
2469          Set_First_Entity (Scop, Empty);
2470          Set_Last_Entity  (Scop, Empty);
2471
2472       --  The eliminated entity was the head of the entity chain
2473
2474       elsif Id = First then
2475          Set_First_Entity (Scop, Next);
2476          Set_Prev_Entity (Next, Empty);  --  Empty <-- First_Entity
2477
2478       --  The eliminated entity was the tail of the entity chain
2479
2480       elsif Id = Last then
2481          Set_Last_Entity (Scop, Prev);
2482          Set_Next_Entity (Prev, Empty);  --  Last_Entity --> Empty
2483
2484       --  Otherwise the eliminated entity comes from the middle of the entity
2485       --  chain.
2486
2487       else
2488          Link_Entities (Prev, Next);  --  Prev <-- Next, Prev --> Next
2489       end if;
2490    end Remove_Entity;
2491
2492    ---------------
2493    -- Root_Type --
2494    ---------------
2495
2496    function Root_Type (Id : E) return E is
2497       T, Etyp : Entity_Id;
2498
2499    begin
2500       pragma Assert (Nkind (Id) in N_Entity);
2501
2502       T := Base_Type (Id);
2503
2504       if Ekind (T) = E_Class_Wide_Type then
2505          return Etype (T);
2506
2507       --  Other cases
2508
2509       else
2510          loop
2511             Etyp := Etype (T);
2512
2513             if T = Etyp then
2514                return T;
2515
2516             --  Following test catches some error cases resulting from
2517             --  previous errors.
2518
2519             elsif No (Etyp) then
2520                Check_Error_Detected;
2521                return T;
2522
2523             elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
2524                return T;
2525
2526             elsif Is_Private_Type (Etyp) and then Full_View (Etyp) = T then
2527                return T;
2528             end if;
2529
2530             T := Etyp;
2531
2532             --  Return if there is a circularity in the inheritance chain. This
2533             --  happens in some error situations and we do not want to get
2534             --  stuck in this loop.
2535
2536             if T = Base_Type (Id) then
2537                return T;
2538             end if;
2539          end loop;
2540       end if;
2541    end Root_Type;
2542
2543    ---------------------
2544    -- Safe_Emax_Value --
2545    ---------------------
2546
2547    function Safe_Emax_Value (Id : E) return Uint is
2548    begin
2549       return Machine_Emax_Value (Id);
2550    end Safe_Emax_Value;
2551
2552    ----------------------
2553    -- Safe_First_Value --
2554    ----------------------
2555
2556    function Safe_First_Value (Id : E) return Ureal is
2557    begin
2558       return -Safe_Last_Value (Id);
2559    end Safe_First_Value;
2560
2561    ---------------------
2562    -- Safe_Last_Value --
2563    ---------------------
2564
2565    function Safe_Last_Value (Id : E) return Ureal is
2566       Radix       : constant Uint := Machine_Radix_Value (Id);
2567       Mantissa    : constant Uint := Machine_Mantissa_Value (Id);
2568       Emax        : constant Uint := Safe_Emax_Value (Id);
2569       Significand : constant Uint := Radix ** Mantissa - 1;
2570       Exponent    : constant Uint := Emax - Mantissa;
2571
2572    begin
2573       if Radix = 2 then
2574          return
2575            UR_From_Components
2576              (Num   => Significand * 2 ** (Exponent mod 4),
2577               Den   => -Exponent / 4,
2578               Rbase => 16);
2579       else
2580          return
2581            UR_From_Components
2582              (Num => Significand,
2583               Den => -Exponent,
2584               Rbase => 16);
2585       end if;
2586    end Safe_Last_Value;
2587
2588    -----------------
2589    -- Scope_Depth --
2590    -----------------
2591
2592    function Scope_Depth (Id : Scope_Kind_Id) return Uint is
2593       Scop : Entity_Id;
2594
2595    begin
2596       Scop := Id;
2597       while Is_Record_Type (Scop) loop
2598          Scop := Scope (Scop);
2599       end loop;
2600
2601       return Scope_Depth_Value (Scop);
2602    end Scope_Depth;
2603
2604    function Scope_Depth_Default_0 (Id : Scope_Kind_Id) return U is
2605    begin
2606       if Scope_Depth_Set (Id) then
2607          return Scope_Depth (Id);
2608
2609       else
2610          return Uint_0;
2611       end if;
2612    end Scope_Depth_Default_0;
2613
2614    ---------------------
2615    -- Scope_Depth_Set --
2616    ---------------------
2617
2618    function Scope_Depth_Set (Id : Scope_Kind_Id) return B is
2619    begin
2620       return not Is_Record_Type (Id)
2621         and then not Field_Is_Initial_Zero (Id, F_Scope_Depth_Value);
2622       --  We can't call Scope_Depth_Value here, because Empty is not a valid
2623       --  value of type Uint.
2624    end Scope_Depth_Set;
2625
2626    --------------------
2627    -- Set_Convention --
2628    --------------------
2629
2630    procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is
2631    begin
2632       Set_Basic_Convention (E, Val);
2633
2634       if Ekind (E) in Access_Subprogram_Kind
2635         and then Has_Foreign_Convention (E)
2636       then
2637          Set_Can_Use_Internal_Rep (E, False);
2638       end if;
2639
2640       --  If E is an object, including a component, and the type of E is an
2641       --  anonymous access type with no convention set, then also set the
2642       --  convention of the anonymous access type. We do not do this for
2643       --  anonymous protected types, since protected types always have the
2644       --  default convention.
2645
2646       if Present (Etype (E))
2647         and then (Is_Object (E)
2648
2649                    --  Allow E_Void (happens for pragma Convention appearing
2650                    --  in the middle of a record applying to a component)
2651
2652                    or else Ekind (E) = E_Void)
2653       then
2654          declare
2655             Typ : constant Entity_Id := Etype (E);
2656
2657          begin
2658             if Ekind (Typ) in E_Anonymous_Access_Type
2659                             | E_Anonymous_Access_Subprogram_Type
2660               and then not Has_Convention_Pragma (Typ)
2661             then
2662                Set_Convention (Typ, Val);
2663                Set_Has_Convention_Pragma (Typ);
2664
2665                --  And for the access subprogram type, deal similarly with the
2666                --  designated E_Subprogram_Type, which is always internal.
2667
2668                if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
2669                   declare
2670                      Dtype : constant Entity_Id := Designated_Type (Typ);
2671                   begin
2672                      if Ekind (Dtype) = E_Subprogram_Type then
2673                         pragma Assert (not Has_Convention_Pragma (Dtype));
2674                         Set_Convention (Dtype, Val);
2675                         Set_Has_Convention_Pragma (Dtype);
2676                      end if;
2677                   end;
2678                end if;
2679             end if;
2680          end;
2681       end if;
2682    end Set_Convention;
2683
2684    -----------------------
2685    -- Set_DIC_Procedure --
2686    -----------------------
2687
2688    procedure Set_DIC_Procedure (Id : E; V : E) is
2689       Base_Typ  : Entity_Id;
2690       Subps     : Elist_Id;
2691
2692    begin
2693       pragma Assert (Is_Type (Id));
2694
2695       Base_Typ := Base_Type (Id);
2696       Subps    := Subprograms_For_Type (Base_Typ);
2697
2698       if No (Subps) then
2699          Subps := New_Elmt_List;
2700          Set_Subprograms_For_Type (Base_Typ, Subps);
2701       end if;
2702
2703       Prepend_Elmt (V, Subps);
2704    end Set_DIC_Procedure;
2705
2706    procedure Set_Partial_DIC_Procedure (Id : E; V : E) is
2707    begin
2708       Set_DIC_Procedure (Id, V);
2709    end Set_Partial_DIC_Procedure;
2710
2711    -------------------
2712    -- Set_Float_Rep --
2713    -------------------
2714
2715    procedure Set_Float_Rep
2716      (Ignore_N : Entity_Id; Ignore_Val : Float_Rep_Kind) is
2717    begin
2718       pragma Assert (Float_Rep_Kind'First = Float_Rep_Kind'Last);
2719       --  There is only one value, so we don't need to store it (see
2720       --  types.ads).
2721    end Set_Float_Rep;
2722
2723    -----------------------------
2724    -- Set_Invariant_Procedure --
2725    -----------------------------
2726
2727    procedure Set_Invariant_Procedure (Id : E; V : E) is
2728       Base_Typ  : Entity_Id;
2729       Subp_Elmt : Elmt_Id;
2730       Subp_Id   : Entity_Id;
2731       Subps     : Elist_Id;
2732
2733    begin
2734       pragma Assert (Is_Type (Id));
2735
2736       Base_Typ := Base_Type (Id);
2737       Subps    := Subprograms_For_Type (Base_Typ);
2738
2739       if No (Subps) then
2740          Subps := New_Elmt_List;
2741          Set_Subprograms_For_Type (Base_Typ, Subps);
2742       end if;
2743
2744       Subp_Elmt := First_Elmt (Subps);
2745       Prepend_Elmt (V, Subps);
2746
2747       --  Check for a duplicate invariant procedure
2748
2749       while Present (Subp_Elmt) loop
2750          Subp_Id := Node (Subp_Elmt);
2751
2752          if Is_Invariant_Procedure (Subp_Id) then
2753             raise Program_Error;
2754          end if;
2755
2756          Next_Elmt (Subp_Elmt);
2757       end loop;
2758    end Set_Invariant_Procedure;
2759
2760    -------------------------------------
2761    -- Set_Partial_Invariant_Procedure --
2762    -------------------------------------
2763
2764    procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
2765       Base_Typ  : Entity_Id;
2766       Subp_Elmt : Elmt_Id;
2767       Subp_Id   : Entity_Id;
2768       Subps     : Elist_Id;
2769
2770    begin
2771       pragma Assert (Is_Type (Id));
2772
2773       Base_Typ := Base_Type (Id);
2774       Subps    := Subprograms_For_Type (Base_Typ);
2775
2776       if No (Subps) then
2777          Subps := New_Elmt_List;
2778          Set_Subprograms_For_Type (Base_Typ, Subps);
2779       end if;
2780
2781       Subp_Elmt := First_Elmt (Subps);
2782       Prepend_Elmt (V, Subps);
2783
2784       --  Check for a duplicate partial invariant procedure
2785
2786       while Present (Subp_Elmt) loop
2787          Subp_Id := Node (Subp_Elmt);
2788
2789          if Is_Partial_Invariant_Procedure (Subp_Id) then
2790             raise Program_Error;
2791          end if;
2792
2793          Next_Elmt (Subp_Elmt);
2794       end loop;
2795    end Set_Partial_Invariant_Procedure;
2796
2797    ----------------------------
2798    -- Set_Predicate_Function --
2799    ----------------------------
2800
2801    procedure Set_Predicate_Function (Id : E; V : E) is
2802       Subp_Elmt : Elmt_Id;
2803       Subp_Id   : Entity_Id;
2804       Subps     : Elist_Id;
2805
2806    begin
2807       pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
2808
2809       Subps := Subprograms_For_Type (Id);
2810
2811       if No (Subps) then
2812          Subps := New_Elmt_List;
2813          Set_Subprograms_For_Type (Id, Subps);
2814       end if;
2815
2816       Subp_Elmt := First_Elmt (Subps);
2817       Prepend_Elmt (V, Subps);
2818
2819       --  Check for a duplicate predication function
2820
2821       while Present (Subp_Elmt) loop
2822          Subp_Id := Node (Subp_Elmt);
2823
2824          if Ekind (Subp_Id) = E_Function
2825            and then Is_Predicate_Function (Subp_Id)
2826          then
2827             raise Program_Error;
2828          end if;
2829
2830          Next_Elmt (Subp_Elmt);
2831       end loop;
2832    end Set_Predicate_Function;
2833
2834    -----------------
2835    -- Size_Clause --
2836    -----------------
2837
2838    function Size_Clause (Id : E) return Node_Id is
2839       Result : Node_Id := Get_Attribute_Definition_Clause (Id, Attribute_Size);
2840    begin
2841       if No (Result) then
2842          Result := Get_Attribute_Definition_Clause (Id, Attribute_Value_Size);
2843       end if;
2844
2845       return Result;
2846    end Size_Clause;
2847
2848    ------------------------
2849    -- Stream_Size_Clause --
2850    ------------------------
2851
2852    function Stream_Size_Clause (Id : E) return N is
2853    begin
2854       return Get_Attribute_Definition_Clause (Id, Attribute_Stream_Size);
2855    end Stream_Size_Clause;
2856
2857    ------------------
2858    -- Subtype_Kind --
2859    ------------------
2860
2861    function Subtype_Kind (K : Entity_Kind) return Entity_Kind is
2862       Kind : Entity_Kind;
2863
2864    begin
2865       case K is
2866          when Access_Kind =>
2867             Kind := E_Access_Subtype;
2868
2869          when E_Array_Subtype
2870             | E_Array_Type
2871          =>
2872             Kind := E_Array_Subtype;
2873
2874          when E_Class_Wide_Subtype
2875             | E_Class_Wide_Type
2876          =>
2877             Kind := E_Class_Wide_Subtype;
2878
2879          when E_Decimal_Fixed_Point_Subtype
2880             | E_Decimal_Fixed_Point_Type
2881          =>
2882             Kind := E_Decimal_Fixed_Point_Subtype;
2883
2884          when E_Ordinary_Fixed_Point_Subtype
2885             | E_Ordinary_Fixed_Point_Type
2886          =>
2887             Kind := E_Ordinary_Fixed_Point_Subtype;
2888
2889          when E_Private_Subtype
2890             | E_Private_Type
2891          =>
2892             Kind := E_Private_Subtype;
2893
2894          when E_Limited_Private_Subtype
2895             | E_Limited_Private_Type
2896          =>
2897             Kind := E_Limited_Private_Subtype;
2898
2899          when E_Record_Subtype_With_Private
2900             | E_Record_Type_With_Private
2901          =>
2902             Kind := E_Record_Subtype_With_Private;
2903
2904          when E_Record_Subtype
2905             | E_Record_Type
2906          =>
2907             Kind := E_Record_Subtype;
2908
2909          when Enumeration_Kind =>
2910             Kind := E_Enumeration_Subtype;
2911
2912          when E_Incomplete_Type =>
2913             Kind := E_Incomplete_Subtype;
2914
2915          when Float_Kind =>
2916             Kind := E_Floating_Point_Subtype;
2917
2918          when Signed_Integer_Kind =>
2919             Kind := E_Signed_Integer_Subtype;
2920
2921          when Modular_Integer_Kind =>
2922             Kind := E_Modular_Integer_Subtype;
2923
2924          when Protected_Kind =>
2925             Kind := E_Protected_Subtype;
2926
2927          when Task_Kind =>
2928             Kind := E_Task_Subtype;
2929
2930          when others =>
2931             raise Program_Error;
2932       end case;
2933
2934       return Kind;
2935    end Subtype_Kind;
2936
2937    ---------------------
2938    -- Type_High_Bound --
2939    ---------------------
2940
2941    function Type_High_Bound (Id : E) return N is
2942       Rng : constant Node_Id := Scalar_Range (Id);
2943    begin
2944       if Nkind (Rng) = N_Subtype_Indication then
2945          return High_Bound (Range_Expression (Constraint (Rng)));
2946       else
2947          return High_Bound (Rng);
2948       end if;
2949    end Type_High_Bound;
2950
2951    --------------------
2952    -- Type_Low_Bound --
2953    --------------------
2954
2955    function Type_Low_Bound (Id : E) return N is
2956       Rng : constant Node_Id := Scalar_Range (Id);
2957    begin
2958       if Nkind (Rng) = N_Subtype_Indication then
2959          return Low_Bound (Range_Expression (Constraint (Rng)));
2960       else
2961          return Low_Bound (Rng);
2962       end if;
2963    end Type_Low_Bound;
2964
2965    ---------------------
2966    -- Underlying_Type --
2967    ---------------------
2968
2969    function Underlying_Type (Id : E) return Entity_Id is
2970    begin
2971       --  For record_with_private the underlying type is always the direct full
2972       --  view. Never try to take the full view of the parent it does not make
2973       --  sense.
2974
2975       if Ekind (Id) = E_Record_Type_With_Private then
2976          return Full_View (Id);
2977
2978       --  If we have a class-wide type that comes from the limited view then we
2979       --  return the Underlying_Type of its nonlimited view.
2980
2981       elsif Ekind (Id) = E_Class_Wide_Type
2982         and then From_Limited_With (Id)
2983         and then Present (Non_Limited_View (Id))
2984       then
2985          return Underlying_Type (Non_Limited_View (Id));
2986
2987       elsif Ekind (Id) in Incomplete_Or_Private_Kind then
2988
2989          --  If we have an incomplete or private type with a full view, then we
2990          --  return the Underlying_Type of this full view.
2991
2992          if Present (Full_View (Id)) then
2993             if Id = Full_View (Id) then
2994
2995                --  Previous error in declaration
2996
2997                return Empty;
2998
2999             else
3000                return Underlying_Type (Full_View (Id));
3001             end if;
3002
3003          --  If we have a private type with an underlying full view, then we
3004          --  return the Underlying_Type of this underlying full view.
3005
3006          elsif Ekind (Id) in Private_Kind
3007            and then Present (Underlying_Full_View (Id))
3008          then
3009             return Underlying_Type (Underlying_Full_View (Id));
3010
3011          --  If we have an incomplete entity that comes from the limited view
3012          --  then we return the Underlying_Type of its nonlimited view.
3013
3014          elsif From_Limited_With (Id)
3015            and then Present (Non_Limited_View (Id))
3016          then
3017             return Underlying_Type (Non_Limited_View (Id));
3018
3019          --  Otherwise check for the case where we have a derived type or
3020          --  subtype, and if so get the Underlying_Type of the parent type.
3021
3022          elsif Present (Etype (Id)) and then Etype (Id) /= Id then
3023             return Underlying_Type (Etype (Id));
3024
3025          --  Otherwise we have an incomplete or private type that has no full
3026          --  view, which means that we have not encountered the completion, so
3027          --  return Empty to indicate the underlying type is not yet known.
3028
3029          else
3030             return Empty;
3031          end if;
3032
3033       --  For non-incomplete, non-private types, return the type itself. Also
3034       --  for entities that are not types at all return the entity itself.
3035
3036       else
3037          return Id;
3038       end if;
3039    end Underlying_Type;
3040
3041    ------------------------
3042    -- Unlink_Next_Entity --
3043    ------------------------
3044
3045    procedure Unlink_Next_Entity (Id : Entity_Id) is
3046       Next : constant Entity_Id := Next_Entity (Id);
3047
3048    begin
3049       if Present (Next) then
3050          Set_Prev_Entity (Next, Empty);  --  Empty <-- Next
3051       end if;
3052
3053       Set_Next_Entity (Id, Empty);       --  Id --> Empty
3054    end Unlink_Next_Entity;
3055
3056    ----------------------------------
3057    -- Is_Volatile, Set_Is_Volatile --
3058    ----------------------------------
3059
3060    function Is_Volatile (Id : E) return B is
3061    begin
3062       pragma Assert (Nkind (Id) in N_Entity);
3063
3064       if Is_Type (Id) then
3065          return Is_Volatile_Type (Base_Type (Id));
3066       else
3067          return Is_Volatile_Object (Id);
3068       end if;
3069    end Is_Volatile;
3070
3071    procedure Set_Is_Volatile (Id : E; V : B := True) is
3072    begin
3073       pragma Assert (Nkind (Id) in N_Entity);
3074
3075       if Is_Type (Id) then
3076          Set_Is_Volatile_Type (Id, V);
3077       else
3078          Set_Is_Volatile_Object (Id, V);
3079       end if;
3080    end Set_Is_Volatile;
3081
3082    -----------------------
3083    -- Write_Entity_Info --
3084    -----------------------
3085
3086    procedure Write_Entity_Info (Id : Entity_Id; Prefix : String) is
3087
3088       procedure Write_Attribute (Which : String; Nam : E);
3089       --  Write attribute value with given string name
3090
3091       procedure Write_Kind (Id : Entity_Id);
3092       --  Write Ekind field of entity
3093
3094       ---------------------
3095       -- Write_Attribute --
3096       ---------------------
3097
3098       procedure Write_Attribute (Which : String; Nam : E) is
3099       begin
3100          Write_Str (Prefix);
3101          Write_Str (Which);
3102          Write_Int (Int (Nam));
3103          Write_Str (" ");
3104          Write_Name (Chars (Nam));
3105          Write_Str (" ");
3106       end Write_Attribute;
3107
3108       ----------------
3109       -- Write_Kind --
3110       ----------------
3111
3112       procedure Write_Kind (Id : Entity_Id) is
3113          K : constant String := Entity_Kind'Image (Ekind (Id));
3114
3115       begin
3116          Write_Str (Prefix);
3117          Write_Str ("   Kind    ");
3118
3119          if Is_Type (Id) and then Is_Tagged_Type (Id) then
3120             Write_Str ("TAGGED ");
3121          end if;
3122
3123          Write_Str (K (3 .. K'Length));
3124          Write_Str (" ");
3125
3126          if Is_Type (Id) and then Depends_On_Private (Id) then
3127             Write_Str ("Depends_On_Private ");
3128          end if;
3129       end Write_Kind;
3130
3131    --  Start of processing for Write_Entity_Info
3132
3133    begin
3134       Write_Eol;
3135       Write_Attribute ("Name ", Id);
3136       Write_Int (Int (Id));
3137       Write_Eol;
3138       Write_Kind (Id);
3139       Write_Eol;
3140       Write_Attribute ("   Type    ", Etype (Id));
3141       Write_Eol;
3142       if Id /= Standard_Standard then
3143          Write_Attribute ("   Scope   ", Scope (Id));
3144       end if;
3145       Write_Eol;
3146
3147       case Ekind (Id) is
3148          when Discrete_Kind =>
3149             Write_Str ("Bounds: Id = ");
3150
3151             if Present (Scalar_Range (Id)) then
3152                Write_Int (Int (Type_Low_Bound (Id)));
3153                Write_Str (" .. Id = ");
3154                Write_Int (Int (Type_High_Bound (Id)));
3155             else
3156                Write_Str ("Empty");
3157             end if;
3158
3159             Write_Eol;
3160
3161          when Array_Kind =>
3162             declare
3163                Index : Entity_Id;
3164
3165             begin
3166                Write_Attribute
3167                  ("   Component Type    ", Component_Type (Id));
3168                Write_Eol;
3169                Write_Str (Prefix);
3170                Write_Str ("   Indexes ");
3171
3172                Index := First_Index (Id);
3173                while Present (Index) loop
3174                   Write_Attribute (" ", Etype (Index));
3175                   Next_Index (Index);
3176                end loop;
3177
3178                Write_Eol;
3179             end;
3180
3181          when Access_Kind =>
3182                Write_Attribute
3183                  ("   Directly Designated Type ",
3184                   Directly_Designated_Type (Id));
3185                Write_Eol;
3186
3187          when Overloadable_Kind =>
3188             if Present (Homonym (Id)) then
3189                Write_Str ("   Homonym   ");
3190                Write_Name (Chars (Homonym (Id)));
3191                Write_Str ("   ");
3192                Write_Int (Int (Homonym (Id)));
3193                Write_Eol;
3194             end if;
3195
3196             Write_Eol;
3197
3198          when E_Component =>
3199             if Ekind (Scope (Id)) in Record_Kind then
3200                Write_Attribute (
3201                   "   Original_Record_Component   ",
3202                   Original_Record_Component (Id));
3203                Write_Int (Int (Original_Record_Component (Id)));
3204                Write_Eol;
3205             end if;
3206
3207          when others =>
3208             null;
3209       end case;
3210    end Write_Entity_Info;
3211
3212    -------------------------
3213    -- Iterator Procedures --
3214    -------------------------
3215
3216    procedure Next_Component                 (N : in out Node_Id) is
3217    begin
3218       N := Next_Component (N);
3219    end Next_Component;
3220
3221    procedure Next_Component_Or_Discriminant (N : in out Node_Id) is
3222    begin
3223       N := Next_Component_Or_Discriminant (N);
3224    end Next_Component_Or_Discriminant;
3225
3226    procedure Next_Discriminant              (N : in out Node_Id) is
3227    begin
3228       N := Next_Discriminant (N);
3229    end Next_Discriminant;
3230
3231    procedure Next_Formal                    (N : in out Node_Id) is
3232    begin
3233       N := Next_Formal (N);
3234    end Next_Formal;
3235
3236    procedure Next_Formal_With_Extras        (N : in out Node_Id) is
3237    begin
3238       N := Next_Formal_With_Extras (N);
3239    end Next_Formal_With_Extras;
3240
3241    procedure Next_Index                     (N : in out Node_Id) is
3242    begin
3243       N := Next_Index (N);
3244    end Next_Index;
3245
3246    procedure Next_Inlined_Subprogram        (N : in out Node_Id) is
3247    begin
3248       N := Next_Inlined_Subprogram (N);
3249    end Next_Inlined_Subprogram;
3250
3251    procedure Next_Literal                   (N : in out Node_Id) is
3252    begin
3253       N := Next_Literal (N);
3254    end Next_Literal;
3255
3256    procedure Next_Stored_Discriminant       (N : in out Node_Id) is
3257    begin
3258       N := Next_Stored_Discriminant (N);
3259    end Next_Stored_Discriminant;
3260
3261 end Einfo.Utils;