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