gcc/ada/lib.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  L I B                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2016, 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Style_Checks (All_Checks);
  33 --  Subprogram ordering not enforced in this unit
  34 --  (because of some logical groupings).
  35
  36 with Atree;    use Atree;
  37 with Csets;    use Csets;
  38 with Einfo;    use Einfo;
  39 with Fname;    use Fname;
  40 with Nlists;   use Nlists;
  41 with Opt;      use Opt;
  42 with Output;   use Output;
  43 with Sinfo;    use Sinfo;
  44 with Sinput;   use Sinput;
  45 with Stand;    use Stand;
  46 with Stringt;  use Stringt;
  47 with Tree_IO;  use Tree_IO;
  48 with Uname;    use Uname;
  49 with Widechar; use Widechar;
  50
  51 package body Lib is
  52
  53    Switch_Storing_Enabled : Boolean := True;
  54    --  Controlled by Enable_Switch_Storing/Disable_Switch_Storing
  55
  56    -----------------------
  57    -- Local Subprograms --
  58    -----------------------
  59
  60    type SEU_Result is (
  61       Yes_Before, -- S1 is in same extended unit as S2 and appears before it
  62       Yes_Same,   -- S1 is in same extended unit as S2, Slocs are the same
  63       Yes_After,  -- S1 is in same extended unit as S2, and appears after it
  64       No);        -- S2 is not in same extended unit as S2
  65
  66    function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result;
  67    --  Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
  68    --  value as described above.
  69
  70    function Get_Code_Or_Source_Unit
  71      (S                : Source_Ptr;
  72       Unwind_Instances : Boolean;
  73       Unwind_Subunits  : Boolean) return Unit_Number_Type;
  74    --  Common processing for routines Get_Code_Unit, Get_Source_Unit, and
  75    --  Get_Top_Level_Code_Unit. Unwind_Instances is True when the unit for the
  76    --  top-level instantiation should be returned instead of the unit for the
  77    --  template, in the case of an instantiation. Unwind_Subunits is True when
  78    --  the corresponding top-level unit should be returned instead of a
  79    --  subunit, in the case of a subunit.
  80
  81    --------------------------------------------
  82    -- Access Functions for Unit Table Fields --
  83    --------------------------------------------
  84
  85    function Cunit (U : Unit_Number_Type) return Node_Id is
  86    begin
  87       return Units.Table (U).Cunit;
  88    end Cunit;
  89
  90    function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is
  91    begin
  92       return Units.Table (U).Cunit_Entity;
  93    end Cunit_Entity;
  94
  95    function Dependency_Num (U : Unit_Number_Type) return Nat is
  96    begin
  97       return Units.Table (U).Dependency_Num;
  98    end Dependency_Num;
  99
 100    function Dynamic_Elab (U : Unit_Number_Type) return Boolean is
 101    begin
 102       return Units.Table (U).Dynamic_Elab;
 103    end Dynamic_Elab;
 104
 105    function Error_Location (U : Unit_Number_Type) return Source_Ptr is
 106    begin
 107       return Units.Table (U).Error_Location;
 108    end Error_Location;
 109
 110    function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is
 111    begin
 112       return Units.Table (U).Expected_Unit;
 113    end Expected_Unit;
 114
 115    function Fatal_Error (U : Unit_Number_Type) return Fatal_Type is
 116    begin
 117       return Units.Table (U).Fatal_Error;
 118    end Fatal_Error;
 119
 120    function Generate_Code (U : Unit_Number_Type) return Boolean is
 121    begin
 122       return Units.Table (U).Generate_Code;
 123    end Generate_Code;
 124
 125    function Has_RACW (U : Unit_Number_Type) return Boolean is
 126    begin
 127       return Units.Table (U).Has_RACW;
 128    end Has_RACW;
 129
 130    function Ident_String (U : Unit_Number_Type) return Node_Id is
 131    begin
 132       return Units.Table (U).Ident_String;
 133    end Ident_String;
 134
 135    function Loading (U : Unit_Number_Type) return Boolean is
 136    begin
 137       return Units.Table (U).Loading;
 138    end Loading;
 139
 140    function Main_CPU (U : Unit_Number_Type) return Int is
 141    begin
 142       return Units.Table (U).Main_CPU;
 143    end Main_CPU;
 144
 145    function Main_Priority (U : Unit_Number_Type) return Int is
 146    begin
 147       return Units.Table (U).Main_Priority;
 148    end Main_Priority;
 149
 150    function Munit_Index (U : Unit_Number_Type) return Nat is
 151    begin
 152       return Units.Table (U).Munit_Index;
 153    end Munit_Index;
 154
 155    function No_Elab_Code_All (U : Unit_Number_Type) return Boolean is
 156    begin
 157       return Units.Table (U).No_Elab_Code_All;
 158    end No_Elab_Code_All;
 159
 160    function OA_Setting (U : Unit_Number_Type) return Character is
 161    begin
 162       return Units.Table (U).OA_Setting;
 163    end OA_Setting;
 164
 165    function Source_Index (U : Unit_Number_Type) return Source_File_Index is
 166    begin
 167       return Units.Table (U).Source_Index;
 168    end Source_Index;
 169
 170    function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is
 171    begin
 172       return Units.Table (U).Unit_File_Name;
 173    end Unit_File_Name;
 174
 175    function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is
 176    begin
 177       return Units.Table (U).Unit_Name;
 178    end Unit_Name;
 179
 180    ------------------------------------------
 181    -- Subprograms to Set Unit Table Fields --
 182    ------------------------------------------
 183
 184    procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is
 185    begin
 186       Units.Table (U).Cunit := N;
 187    end Set_Cunit;
 188
 189    procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is
 190    begin
 191       Units.Table (U).Cunit_Entity := E;
 192       Set_Is_Compilation_Unit (E);
 193    end Set_Cunit_Entity;
 194
 195    procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is
 196    begin
 197       Units.Table (U).Dynamic_Elab := B;
 198    end Set_Dynamic_Elab;
 199
 200    procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is
 201    begin
 202       Units.Table (U).Error_Location := W;
 203    end Set_Error_Location;
 204
 205    procedure Set_Fatal_Error (U : Unit_Number_Type; V : Fatal_Type) is
 206    begin
 207       Units.Table (U).Fatal_Error := V;
 208    end Set_Fatal_Error;
 209
 210    procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is
 211    begin
 212       Units.Table (U).Generate_Code := B;
 213    end Set_Generate_Code;
 214
 215    procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is
 216    begin
 217       Units.Table (U).Has_RACW := B;
 218    end Set_Has_RACW;
 219
 220    procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is
 221    begin
 222       Units.Table (U).Ident_String := N;
 223    end Set_Ident_String;
 224
 225    procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is
 226    begin
 227       Units.Table (U).Loading := B;
 228    end Set_Loading;
 229
 230    procedure Set_Main_CPU (U : Unit_Number_Type; P : Int) is
 231    begin
 232       Units.Table (U).Main_CPU := P;
 233    end Set_Main_CPU;
 234
 235    procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is
 236    begin
 237       Units.Table (U).Main_Priority := P;
 238    end Set_Main_Priority;
 239
 240    procedure Set_No_Elab_Code_All
 241      (U : Unit_Number_Type;
 242       B : Boolean := True)
 243    is
 244    begin
 245       Units.Table (U).No_Elab_Code_All := B;
 246    end Set_No_Elab_Code_All;
 247
 248    procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is
 249    begin
 250       Units.Table (U).OA_Setting := C;
 251    end Set_OA_Setting;
 252
 253    procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is
 254    begin
 255       Units.Table (U).Unit_Name := N;
 256    end Set_Unit_Name;
 257
 258    ------------------------------
 259    -- Check_Same_Extended_Unit --
 260    ------------------------------
 261
 262    function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
 263       Max_Iterations : constant Nat := Maximum_Instantiations * 2;
 264       --  Limit to prevent a potential infinite loop
 265
 266       Counter : Nat := 0;
 267       Depth1  : Nat;
 268       Depth2  : Nat;
 269       Inst1   : Source_Ptr;
 270       Inst2   : Source_Ptr;
 271       Sind1   : Source_File_Index;
 272       Sind2   : Source_File_Index;
 273       Sloc1   : Source_Ptr;
 274       Sloc2   : Source_Ptr;
 275       Unit1   : Node_Id;
 276       Unit2   : Node_Id;
 277       Unum1   : Unit_Number_Type;
 278       Unum2   : Unit_Number_Type;
 279
 280    begin
 281       if S1 = No_Location or else S2 = No_Location then
 282          return No;
 283
 284       elsif S1 = Standard_Location then
 285          if S2 = Standard_Location then
 286             return Yes_Same;
 287          else
 288             return No;
 289          end if;
 290
 291       elsif S2 = Standard_Location then
 292          return No;
 293       end if;
 294
 295       Sloc1 := S1;
 296       Sloc2 := S2;
 297
 298       Unum1 := Get_Source_Unit (Sloc1);
 299       Unum2 := Get_Source_Unit (Sloc2);
 300
 301       loop
 302          --  Step 1: Check whether the two locations are in the same source
 303          --  file.
 304
 305          Sind1 := Get_Source_File_Index (Sloc1);
 306          Sind2 := Get_Source_File_Index (Sloc2);
 307
 308          if Sind1 = Sind2 then
 309             if Sloc1 < Sloc2 then
 310                return Yes_Before;
 311             elsif Sloc1 > Sloc2 then
 312                return Yes_After;
 313             else
 314                return Yes_Same;
 315             end if;
 316          end if;
 317
 318          --  Step 2: Check subunits. If a subunit is instantiated, follow the
 319          --  instantiation chain rather than the stub chain.
 320
 321          Unit1 := Unit (Cunit (Unum1));
 322          Unit2 := Unit (Cunit (Unum2));
 323          Inst1 := Instantiation (Sind1);
 324          Inst2 := Instantiation (Sind2);
 325
 326          if Nkind (Unit1) = N_Subunit
 327            and then Present (Corresponding_Stub (Unit1))
 328            and then Inst1 = No_Location
 329          then
 330             if Nkind (Unit2) = N_Subunit
 331               and then Present (Corresponding_Stub (Unit2))
 332               and then Inst2 = No_Location
 333             then
 334                --  Both locations refer to subunits which may have a common
 335                --  ancestor. If they do, the deeper subunit must have a longer
 336                --  unit name. Replace the deeper one with its corresponding
 337                --  stub in order to find the nearest ancestor.
 338
 339                if Length_Of_Name (Unit_Name (Unum1)) <
 340                   Length_Of_Name (Unit_Name (Unum2))
 341                then
 342                   Sloc2 := Sloc (Corresponding_Stub (Unit2));
 343                   Unum2 := Get_Source_Unit (Sloc2);
 344                   goto Continue;
 345
 346                else
 347                   Sloc1 := Sloc (Corresponding_Stub (Unit1));
 348                   Unum1 := Get_Source_Unit (Sloc1);
 349                   goto Continue;
 350                end if;
 351
 352             --  Sloc1 in subunit, Sloc2 not
 353
 354             else
 355                Sloc1 := Sloc (Corresponding_Stub (Unit1));
 356                Unum1 := Get_Source_Unit (Sloc1);
 357                goto Continue;
 358             end if;
 359
 360          --  Sloc2 in subunit, Sloc1 not
 361
 362          elsif Nkind (Unit2) = N_Subunit
 363            and then Present (Corresponding_Stub (Unit2))
 364            and then Inst2 = No_Location
 365          then
 366             Sloc2 := Sloc (Corresponding_Stub (Unit2));
 367             Unum2 := Get_Source_Unit (Sloc2);
 368             goto Continue;
 369          end if;
 370
 371          --  Step 3: Check instances. The two locations may yield a common
 372          --  ancestor.
 373
 374          if Inst1 /= No_Location then
 375             if Inst2 /= No_Location then
 376
 377                --  Both locations denote instantiations
 378
 379                Depth1 := Instantiation_Depth (Sloc1);
 380                Depth2 := Instantiation_Depth (Sloc2);
 381
 382                if Depth1 < Depth2 then
 383                   Sloc2 := Inst2;
 384                   Unum2 := Get_Source_Unit (Sloc2);
 385                   goto Continue;
 386
 387                elsif Depth1 > Depth2 then
 388                   Sloc1 := Inst1;
 389                   Unum1 := Get_Source_Unit (Sloc1);
 390                   goto Continue;
 391
 392                else
 393                   Sloc1 := Inst1;
 394                   Sloc2 := Inst2;
 395                   Unum1 := Get_Source_Unit (Sloc1);
 396                   Unum2 := Get_Source_Unit (Sloc2);
 397                   goto Continue;
 398                end if;
 399
 400             --  Sloc1 is an instantiation
 401
 402             else
 403                Sloc1 := Inst1;
 404                Unum1 := Get_Source_Unit (Sloc1);
 405                goto Continue;
 406             end if;
 407
 408          --  Sloc2 is an instantiation
 409
 410          elsif Inst2 /= No_Location then
 411             Sloc2 := Inst2;
 412             Unum2 := Get_Source_Unit (Sloc2);
 413             goto Continue;
 414          end if;
 415
 416          --  Step 4: One location in the spec, the other in the corresponding
 417          --  body of the same unit. The location in the spec is considered
 418          --  earlier.
 419
 420          if Nkind (Unit1) = N_Subprogram_Body
 421               or else
 422             Nkind (Unit1) = N_Package_Body
 423          then
 424             if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then
 425                return Yes_After;
 426             end if;
 427
 428          elsif Nkind (Unit2) = N_Subprogram_Body
 429                  or else
 430                Nkind (Unit2) = N_Package_Body
 431          then
 432             if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then
 433                return Yes_Before;
 434             end if;
 435          end if;
 436
 437          --  At this point it is certain that the two locations denote two
 438          --  entirely separate units.
 439
 440          return No;
 441
 442          <<Continue>>
 443          Counter := Counter + 1;
 444
 445          --  Prevent looping forever
 446
 447          if Counter > Max_Iterations then
 448             --  ??? Not quite right, but return a value to be able to generate
 449             --  SCIL files and hope for the best.
 450
 451             if CodePeer_Mode then
 452                return No;
 453             else
 454                raise Program_Error;
 455             end if;
 456          end if;
 457       end loop;
 458    end Check_Same_Extended_Unit;
 459
 460    -------------------------------
 461    -- Compilation_Switches_Last --
 462    -------------------------------
 463
 464    function Compilation_Switches_Last return Nat is
 465    begin
 466       return Compilation_Switches.Last;
 467    end Compilation_Switches_Last;
 468
 469    ---------------------------
 470    -- Enable_Switch_Storing --
 471    ---------------------------
 472
 473    procedure Enable_Switch_Storing is
 474    begin
 475       Switch_Storing_Enabled := True;
 476    end Enable_Switch_Storing;
 477
 478    ----------------------------
 479    -- Disable_Switch_Storing --
 480    ----------------------------
 481
 482    procedure Disable_Switch_Storing is
 483    begin
 484       Switch_Storing_Enabled := False;
 485    end Disable_Switch_Storing;
 486
 487    ------------------------------
 488    -- Earlier_In_Extended_Unit --
 489    ------------------------------
 490
 491    function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
 492    begin
 493       return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
 494    end Earlier_In_Extended_Unit;
 495
 496    -----------------------
 497    -- Exact_Source_Name --
 498    -----------------------
 499
 500    function Exact_Source_Name (Loc : Source_Ptr) return String is
 501       U    : constant Unit_Number_Type  := Get_Source_Unit (Loc);
 502       Buf  : constant Source_Buffer_Ptr := Source_Text (Source_Index (U));
 503       Orig : constant Source_Ptr        := Original_Location (Loc);
 504       P    : Source_Ptr;
 505
 506       WC   : Char_Code;
 507       Err  : Boolean;
 508       pragma Warnings (Off, WC);
 509       pragma Warnings (Off, Err);
 510
 511    begin
 512       --  Entity is character literal
 513
 514       if Buf (Orig) = ''' then
 515          return String (Buf (Orig .. Orig + 2));
 516
 517       --  Entity is operator symbol
 518
 519       elsif Buf (Orig) = '"' or else Buf (Orig) = '%' then
 520          P := Orig;
 521
 522          loop
 523             P := P + 1;
 524             exit when Buf (P) = Buf (Orig);
 525          end loop;
 526
 527          return String (Buf (Orig .. P));
 528
 529       --  Entity is identifier
 530
 531       else
 532          P := Orig;
 533
 534          loop
 535             if Is_Start_Of_Wide_Char (Buf, P) then
 536                Scan_Wide (Buf, P, WC, Err);
 537             elsif not Identifier_Char (Buf (P)) then
 538                exit;
 539             else
 540                P := P + 1;
 541             end if;
 542          end loop;
 543
 544          --  Write out the identifier by copying the exact source characters
 545          --  used in its declaration. Note that this means wide characters will
 546          --  be in their original encoded form.
 547
 548          return String (Buf (Orig .. P - 1));
 549       end if;
 550    end Exact_Source_Name;
 551
 552    ----------------------------
 553    -- Entity_Is_In_Main_Unit --
 554    ----------------------------
 555
 556    function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is
 557       S : Entity_Id;
 558
 559    begin
 560       S := Scope (E);
 561
 562       while S /= Standard_Standard loop
 563          if S = Main_Unit_Entity then
 564             return True;
 565          elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then
 566             return False;
 567          else
 568             S := Scope (S);
 569          end if;
 570       end loop;
 571
 572       return False;
 573    end Entity_Is_In_Main_Unit;
 574
 575    --------------------------
 576    -- Generic_May_Lack_ALI --
 577    --------------------------
 578
 579    function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is
 580    begin
 581       --  We allow internal generic units to be used without having a
 582       --  corresponding ALI files to help bootstrapping with older compilers
 583       --  that did not support generating ALIs for such generics. It is safe
 584       --  to do so because the only thing the generated code would contain
 585       --  is the elaboration boolean, and we are careful to elaborate all
 586       --  predefined units first anyway.
 587
 588       return Is_Internal_File_Name
 589                (Fname              => Sfile,
 590                 Renamings_Included => True);
 591    end Generic_May_Lack_ALI;
 592
 593    -----------------------------
 594    -- Get_Code_Or_Source_Unit --
 595    -----------------------------
 596
 597    function Get_Code_Or_Source_Unit
 598      (S                : Source_Ptr;
 599       Unwind_Instances : Boolean;
 600       Unwind_Subunits  : Boolean) return Unit_Number_Type
 601    is
 602    begin
 603       --  Search table unless we have No_Location, which can happen if the
 604       --  relevant location has not been set yet. Happens for example when
 605       --  we obtain Sloc (Cunit (Main_Unit)) before it is set.
 606
 607       if S /= No_Location then
 608          declare
 609             Source_File : Source_File_Index;
 610             Source_Unit : Unit_Number_Type;
 611             Unit_Node   : Node_Id;
 612
 613          begin
 614             Source_File := Get_Source_File_Index (S);
 615
 616             if Unwind_Instances then
 617                while Template (Source_File) /= No_Source_File loop
 618                   Source_File := Template (Source_File);
 619                end loop;
 620             end if;
 621
 622             Source_Unit := Unit (Source_File);
 623
 624             if Unwind_Subunits then
 625                Unit_Node := Unit (Cunit (Source_Unit));
 626
 627                while Nkind (Unit_Node) = N_Subunit
 628                  and then Present (Corresponding_Stub (Unit_Node))
 629                loop
 630                   Source_Unit :=
 631                     Get_Code_Or_Source_Unit
 632                       (Sloc (Corresponding_Stub (Unit_Node)),
 633                        Unwind_Instances => Unwind_Instances,
 634                        Unwind_Subunits  => Unwind_Subunits);
 635                   Unit_Node := Unit (Cunit (Source_Unit));
 636                end loop;
 637             end if;
 638
 639             if Source_Unit /= No_Unit then
 640                return Source_Unit;
 641             end if;
 642          end;
 643       end if;
 644
 645       --  If S was No_Location, or was not in the table, we must be in the main
 646       --  source unit (and the value has not been placed in the table yet),
 647       --  or in one of the configuration pragma files.
 648
 649       return Main_Unit;
 650    end Get_Code_Or_Source_Unit;
 651
 652    -------------------
 653    -- Get_Code_Unit --
 654    -------------------
 655
 656    function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
 657    begin
 658       return
 659         Get_Code_Or_Source_Unit
 660           (Top_Level_Location (S),
 661            Unwind_Instances => False,
 662            Unwind_Subunits  => False);
 663    end Get_Code_Unit;
 664
 665    function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
 666    begin
 667       return Get_Code_Unit (Sloc (N));
 668    end Get_Code_Unit;
 669
 670    ----------------------------
 671    -- Get_Compilation_Switch --
 672    ----------------------------
 673
 674    function Get_Compilation_Switch (N : Pos) return String_Ptr is
 675    begin
 676       if N <= Compilation_Switches.Last then
 677          return Compilation_Switches.Table (N);
 678       else
 679          return null;
 680       end if;
 681    end Get_Compilation_Switch;
 682
 683    ----------------------------------
 684    -- Get_Cunit_Entity_Unit_Number --
 685    ----------------------------------
 686
 687    function Get_Cunit_Entity_Unit_Number
 688      (E : Entity_Id) return Unit_Number_Type
 689    is
 690    begin
 691       for U in Units.First .. Units.Last loop
 692          if Cunit_Entity (U) = E then
 693             return U;
 694          end if;
 695       end loop;
 696
 697       --  If not in the table, must be the main source unit, and we just
 698       --  have not got it put into the table yet.
 699
 700       return Main_Unit;
 701    end Get_Cunit_Entity_Unit_Number;
 702
 703    ---------------------------
 704    -- Get_Cunit_Unit_Number --
 705    ---------------------------
 706
 707    function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is
 708    begin
 709       for U in Units.First .. Units.Last loop
 710          if Cunit (U) = N then
 711             return U;
 712          end if;
 713       end loop;
 714
 715       --  If not in the table, must be a spec created for a main unit that is a
 716       --  child subprogram body which we have not inserted into the table yet.
 717
 718       if N = Library_Unit (Cunit (Main_Unit)) then
 719          return Main_Unit;
 720
 721       --  If it is anything else, something is seriously wrong, and we really
 722       --  don't want to proceed, even if assertions are off, so we explicitly
 723       --  raise an exception in this case to terminate compilation.
 724
 725       else
 726          raise Program_Error;
 727       end if;
 728    end Get_Cunit_Unit_Number;
 729
 730    ---------------------
 731    -- Get_Source_Unit --
 732    ---------------------
 733
 734    function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
 735    begin
 736       return
 737         Get_Code_Or_Source_Unit
 738           (S, Unwind_Instances => True, Unwind_Subunits => False);
 739    end Get_Source_Unit;
 740
 741    function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
 742    begin
 743       return Get_Source_Unit (Sloc (N));
 744    end Get_Source_Unit;
 745
 746    -----------------------------
 747    -- Get_Top_Level_Code_Unit --
 748    -----------------------------
 749
 750    function Get_Top_Level_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
 751    begin
 752       return
 753         Get_Code_Or_Source_Unit
 754           (Top_Level_Location (S),
 755            Unwind_Instances => False,
 756            Unwind_Subunits  => True);
 757    end Get_Top_Level_Code_Unit;
 758
 759    function Get_Top_Level_Code_Unit
 760      (N : Node_Or_Entity_Id) return Unit_Number_Type is
 761    begin
 762       return Get_Top_Level_Code_Unit (Sloc (N));
 763    end Get_Top_Level_Code_Unit;
 764
 765    --------------------------------
 766    -- In_Extended_Main_Code_Unit --
 767    --------------------------------
 768
 769    function In_Extended_Main_Code_Unit
 770      (N : Node_Or_Entity_Id) return Boolean
 771    is
 772    begin
 773       if Sloc (N) = Standard_Location then
 774          return False;
 775
 776       elsif Sloc (N) = No_Location then
 777          return False;
 778
 779       --  Special case Itypes to test the Sloc of the associated node. The
 780       --  reason we do this is for possible calls from gigi after -gnatD
 781       --  processing is complete in sprint. This processing updates the
 782       --  sloc fields of all nodes in the tree, but itypes are not in the
 783       --  tree so their slocs do not get updated.
 784
 785       elsif Nkind (N) = N_Defining_Identifier
 786         and then Is_Itype (N)
 787       then
 788          return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N));
 789
 790       --  Otherwise see if we are in the main unit
 791
 792       elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then
 793          return True;
 794
 795       --  Node may be in spec (or subunit etc) of main unit
 796
 797       else
 798          return
 799            In_Same_Extended_Unit (N, Cunit (Main_Unit));
 800       end if;
 801    end In_Extended_Main_Code_Unit;
 802
 803    function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
 804    begin
 805       if Loc = Standard_Location then
 806          return False;
 807
 808       elsif Loc = No_Location then
 809          return False;
 810
 811       --  Otherwise see if we are in the main unit
 812
 813       elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then
 814          return True;
 815
 816       --  Location may be in spec (or subunit etc) of main unit
 817
 818       else
 819          return
 820            In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
 821       end if;
 822    end In_Extended_Main_Code_Unit;
 823
 824    ----------------------------------
 825    -- In_Extended_Main_Source_Unit --
 826    ----------------------------------
 827
 828    function In_Extended_Main_Source_Unit
 829      (N : Node_Or_Entity_Id) return Boolean
 830    is
 831       Nloc : constant Source_Ptr := Sloc (N);
 832       Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
 833
 834    begin
 835       --  If parsing, then use the global flag to indicate result
 836
 837       if Compiler_State = Parsing then
 838          return Parsing_Main_Extended_Source;
 839
 840       --  Special value cases
 841
 842       elsif Nloc = Standard_Location then
 843          return False;
 844
 845       elsif Nloc = No_Location then
 846          return False;
 847
 848       --  Special case Itypes to test the Sloc of the associated node. The
 849       --  reason we do this is for possible calls from gigi after -gnatD
 850       --  processing is complete in sprint. This processing updates the
 851       --  sloc fields of all nodes in the tree, but itypes are not in the
 852       --  tree so their slocs do not get updated.
 853
 854       elsif Nkind (N) = N_Defining_Identifier
 855         and then Is_Itype (N)
 856       then
 857          return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N));
 858
 859       --  Otherwise compare original locations to see if in same unit
 860
 861       else
 862          return
 863            In_Same_Extended_Unit
 864              (Original_Location (Nloc), Original_Location (Mloc));
 865       end if;
 866    end In_Extended_Main_Source_Unit;
 867
 868    function In_Extended_Main_Source_Unit
 869      (Loc : Source_Ptr) return Boolean
 870    is
 871       Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
 872
 873    begin
 874       --  If parsing, then use the global flag to indicate result
 875
 876       if Compiler_State = Parsing then
 877          return Parsing_Main_Extended_Source;
 878
 879       --  Special value cases
 880
 881       elsif Loc = Standard_Location then
 882          return False;
 883
 884       elsif Loc = No_Location then
 885          return False;
 886
 887       --  Otherwise compare original locations to see if in same unit
 888
 889       else
 890          return
 891            In_Same_Extended_Unit
 892              (Original_Location (Loc), Original_Location (Mloc));
 893       end if;
 894    end In_Extended_Main_Source_Unit;
 895
 896    ------------------------
 897    -- In_Predefined_Unit --
 898    ------------------------
 899
 900    function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is
 901    begin
 902       return In_Predefined_Unit (Sloc (N));
 903    end In_Predefined_Unit;
 904
 905    function In_Predefined_Unit (S : Source_Ptr) return Boolean is
 906       Unit : constant Unit_Number_Type := Get_Source_Unit (S);
 907       File : constant File_Name_Type   := Unit_File_Name (Unit);
 908    begin
 909       return Is_Predefined_File_Name (File);
 910    end In_Predefined_Unit;
 911
 912    -----------------------
 913    -- In_Same_Code_Unit --
 914    -----------------------
 915
 916    function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
 917       S1 : constant Source_Ptr := Sloc (N1);
 918       S2 : constant Source_Ptr := Sloc (N2);
 919
 920    begin
 921       if S1 = No_Location or else S2 = No_Location then
 922          return False;
 923
 924       elsif S1 = Standard_Location then
 925          return S2 = Standard_Location;
 926
 927       elsif S2 = Standard_Location then
 928          return False;
 929       end if;
 930
 931       return Get_Code_Unit (N1) = Get_Code_Unit (N2);
 932    end In_Same_Code_Unit;
 933
 934    ---------------------------
 935    -- In_Same_Extended_Unit --
 936    ---------------------------
 937
 938    function In_Same_Extended_Unit
 939      (N1, N2 : Node_Or_Entity_Id) return Boolean
 940    is
 941    begin
 942       return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No;
 943    end In_Same_Extended_Unit;
 944
 945    function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
 946    begin
 947       return Check_Same_Extended_Unit (S1, S2) /= No;
 948    end In_Same_Extended_Unit;
 949
 950    -------------------------
 951    -- In_Same_Source_Unit --
 952    -------------------------
 953
 954    function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
 955       S1 : constant Source_Ptr := Sloc (N1);
 956       S2 : constant Source_Ptr := Sloc (N2);
 957
 958    begin
 959       if S1 = No_Location or else S2 = No_Location then
 960          return False;
 961
 962       elsif S1 = Standard_Location then
 963          return S2 = Standard_Location;
 964
 965       elsif S2 = Standard_Location then
 966          return False;
 967       end if;
 968
 969       return Get_Source_Unit (N1) = Get_Source_Unit (N2);
 970    end In_Same_Source_Unit;
 971
 972    -----------------------------
 973    -- Increment_Serial_Number --
 974    -----------------------------
 975
 976    function Increment_Serial_Number return Nat is
 977       TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
 978    begin
 979       TSN := TSN + 1;
 980       return TSN;
 981    end Increment_Serial_Number;
 982
 983    ----------------
 984    -- Initialize --
 985    ----------------
 986
 987    procedure Initialize is
 988    begin
 989       Linker_Option_Lines.Init;
 990       Notes.Init;
 991       Load_Stack.Init;
 992       Units.Init;
 993       Compilation_Switches.Init;
 994    end Initialize;
 995
 996    ---------------
 997    -- Is_Loaded --
 998    ---------------
 999
1000    function Is_Loaded (Uname : Unit_Name_Type) return Boolean is
1001    begin
1002       for Unum in Units.First .. Units.Last loop
1003          if Uname = Unit_Name (Unum) then
1004             return True;
1005          end if;
1006       end loop;
1007
1008       return False;
1009    end Is_Loaded;
1010
1011    ---------------
1012    -- Last_Unit --
1013    ---------------
1014
1015    function Last_Unit return Unit_Number_Type is
1016    begin
1017       return Units.Last;
1018    end Last_Unit;
1019
1020    ----------
1021    -- List --
1022    ----------
1023
1024    procedure List (File_Names_Only : Boolean := False) is separate;
1025
1026    ----------
1027    -- Lock --
1028    ----------
1029
1030    procedure Lock is
1031    begin
1032       Linker_Option_Lines.Locked := True;
1033       Load_Stack.Locked := True;
1034       Units.Locked := True;
1035       Linker_Option_Lines.Release;
1036       Load_Stack.Release;
1037       Units.Release;
1038    end Lock;
1039
1040    ---------------
1041    -- Num_Units --
1042    ---------------
1043
1044    function Num_Units return Nat is
1045    begin
1046       return Int (Units.Last) - Int (Main_Unit) + 1;
1047    end Num_Units;
1048
1049    -----------------
1050    -- Remove_Unit --
1051    -----------------
1052
1053    procedure Remove_Unit (U : Unit_Number_Type) is
1054    begin
1055       if U = Units.Last then
1056          Units.Decrement_Last;
1057       end if;
1058    end Remove_Unit;
1059
1060    ----------------------------------
1061    -- Replace_Linker_Option_String --
1062    ----------------------------------
1063
1064    procedure Replace_Linker_Option_String
1065      (S : String_Id; Match_String : String)
1066    is
1067    begin
1068       if Match_String'Length > 0 then
1069          for J in 1 .. Linker_Option_Lines.Last loop
1070             String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option);
1071
1072             if Match_String = Name_Buffer (1 .. Match_String'Length) then
1073                Linker_Option_Lines.Table (J).Option := S;
1074                return;
1075             end if;
1076          end loop;
1077       end if;
1078
1079       Store_Linker_Option_String (S);
1080    end Replace_Linker_Option_String;
1081
1082    ----------
1083    -- Sort --
1084    ----------
1085
1086    procedure Sort (Tbl : in out Unit_Ref_Table) is separate;
1087
1088    ------------------------------
1089    -- Store_Compilation_Switch --
1090    ------------------------------
1091
1092    procedure Store_Compilation_Switch (Switch : String) is
1093    begin
1094       if Switch_Storing_Enabled then
1095          Compilation_Switches.Increment_Last;
1096          Compilation_Switches.Table (Compilation_Switches.Last) :=
1097            new String'(Switch);
1098
1099          --  Fix up --RTS flag which has been transformed by the gcc driver
1100          --  into -fRTS
1101
1102          if Switch'Last >= Switch'First + 4
1103            and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
1104          then
1105             Compilation_Switches.Table
1106               (Compilation_Switches.Last) (Switch'First + 1) := '-';
1107          end if;
1108       end if;
1109    end Store_Compilation_Switch;
1110
1111    --------------------------------
1112    -- Store_Linker_Option_String --
1113    --------------------------------
1114
1115    procedure Store_Linker_Option_String (S : String_Id) is
1116    begin
1117       Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
1118    end Store_Linker_Option_String;
1119
1120    ----------------
1121    -- Store_Note --
1122    ----------------
1123
1124    procedure Store_Note (N : Node_Id) is
1125       Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N));
1126
1127    begin
1128       --  Notes for a generic are emitted when processing the template, never
1129       --  in instances.
1130
1131       if In_Extended_Main_Code_Unit (N)
1132         and then Instance (Sfile) = No_Instance_Id
1133       then
1134          Notes.Append (N);
1135       end if;
1136    end Store_Note;
1137
1138    -------------------------------
1139    -- Synchronize_Serial_Number --
1140    -------------------------------
1141
1142    procedure Synchronize_Serial_Number is
1143       TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
1144    begin
1145       TSN := TSN + 1;
1146    end Synchronize_Serial_Number;
1147
1148    ---------------
1149    -- Tree_Read --
1150    ---------------
1151
1152    procedure Tree_Read is
1153       N : Nat;
1154       S : String_Ptr;
1155
1156    begin
1157       Units.Tree_Read;
1158
1159       --  Read Compilation_Switches table. First release the memory occupied
1160       --  by the previously loaded switches.
1161
1162       for J in Compilation_Switches.First .. Compilation_Switches.Last loop
1163          Free (Compilation_Switches.Table (J));
1164       end loop;
1165
1166       Tree_Read_Int (N);
1167       Compilation_Switches.Set_Last (N);
1168
1169       for J in 1 .. N loop
1170          Tree_Read_Str (S);
1171          Compilation_Switches.Table (J) := S;
1172       end loop;
1173    end Tree_Read;
1174
1175    ----------------
1176    -- Tree_Write --
1177    ----------------
1178
1179    procedure Tree_Write is
1180    begin
1181       Units.Tree_Write;
1182
1183       --  Write Compilation_Switches table
1184
1185       Tree_Write_Int (Compilation_Switches.Last);
1186
1187       for J in 1 .. Compilation_Switches.Last loop
1188          Tree_Write_Str (Compilation_Switches.Table (J));
1189       end loop;
1190    end Tree_Write;
1191
1192    ------------
1193    -- Unlock --
1194    ------------
1195
1196    procedure Unlock is
1197    begin
1198       Linker_Option_Lines.Locked := False;
1199       Load_Stack.Locked := False;
1200       Units.Locked := False;
1201    end Unlock;
1202
1203    -----------------
1204    -- Version_Get --
1205    -----------------
1206
1207    function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
1208    begin
1209       return Get_Hex_String (Units.Table (U).Version);
1210    end Version_Get;
1211
1212    ------------------------
1213    -- Version_Referenced --
1214    ------------------------
1215
1216    procedure Version_Referenced (S : String_Id) is
1217    begin
1218       Version_Ref.Append (S);
1219    end Version_Referenced;
1220
1221    ---------------------
1222    -- Write_Unit_Info --
1223    ---------------------
1224
1225    procedure Write_Unit_Info
1226      (Unit_Num : Unit_Number_Type;
1227       Item     : Node_Id;
1228       Prefix   : String := "";
1229       Withs    : Boolean := False)
1230    is
1231    begin
1232       Write_Str (Prefix);
1233       Write_Unit_Name (Unit_Name (Unit_Num));
1234       Write_Str (", unit ");
1235       Write_Int (Int (Unit_Num));
1236       Write_Str (", ");
1237       Write_Int (Int (Item));
1238       Write_Str ("=");
1239       Write_Str (Node_Kind'Image (Nkind (Item)));
1240
1241       if Item /= Original_Node (Item) then
1242          Write_Str (", orig = ");
1243          Write_Int (Int (Original_Node (Item)));
1244          Write_Str ("=");
1245          Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1246       end if;
1247
1248       Write_Eol;
1249
1250       --  Skip the rest if we're not supposed to print the withs
1251
1252       if not Withs then
1253          return;
1254       end if;
1255
1256       declare
1257          Context_Item : Node_Id;
1258
1259       begin
1260          Context_Item := First (Context_Items (Cunit (Unit_Num)));
1261          while Present (Context_Item)
1262            and then (Nkind (Context_Item) /= N_With_Clause
1263                       or else Limited_Present (Context_Item))
1264          loop
1265             Context_Item := Next (Context_Item);
1266          end loop;
1267
1268          if Present (Context_Item) then
1269             Indent;
1270             Write_Line ("withs:");
1271             Indent;
1272
1273             while Present (Context_Item) loop
1274                if Nkind (Context_Item) = N_With_Clause
1275                  and then not Limited_Present (Context_Item)
1276                then
1277                   pragma Assert (Present (Library_Unit (Context_Item)));
1278                   Write_Unit_Name
1279                     (Unit_Name
1280                        (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
1281
1282                   if Implicit_With (Context_Item) then
1283                      Write_Str (" -- implicit");
1284                   end if;
1285
1286                   Write_Eol;
1287                end if;
1288
1289                Context_Item := Next (Context_Item);
1290             end loop;
1291
1292             Outdent;
1293             Write_Line ("end withs");
1294             Outdent;
1295          end if;
1296       end;
1297    end Write_Unit_Info;
1298
1299 end Lib;