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-2004 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 pragma Style_Checks (All_Checks);
  35 --  Subprogram ordering not enforced in this unit
  36 --  (because of some logical groupings).
  37
  38 with Atree;   use Atree;
  39 with Einfo;   use Einfo;
  40 with Fname;   use Fname;
  41 with Namet;   use Namet;
  42 with Namet;   use Namet;
  43 with Output;  use Output;
  44 with Sinfo;   use Sinfo;
  45 with Sinput;  use Sinput;
  46 with Stand;   use Stand;
  47 with Stringt; use Stringt;
  48 with Tree_IO; use Tree_IO;
  49 with Uname;   use Uname;
  50
  51 package body Lib is
  52
  53    -----------------------
  54    -- Local Subprograms --
  55    -----------------------
  56
  57    type SEU_Result is (
  58       Yes_Before, -- S1 is in same extended unit as S2 and appears before it
  59       Yes_Same,   -- S1 is in same extended unit as S2, Slocs are the same
  60       Yes_After,  -- S1 is in same extended unit as S2, and appears after it
  61       No);        -- S2 is not in same extended unit as S2
  62
  63    function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result;
  64    --  Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns
  65    --  value as described above.
  66
  67    --------------------------------------------
  68    -- Access Functions for Unit Table Fields --
  69    --------------------------------------------
  70
  71    function Cunit (U : Unit_Number_Type) return Node_Id is
  72    begin
  73       return Units.Table (U).Cunit;
  74    end Cunit;
  75
  76    function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is
  77    begin
  78       return Units.Table (U).Cunit_Entity;
  79    end Cunit_Entity;
  80
  81    function Dependency_Num (U : Unit_Number_Type) return Nat is
  82    begin
  83       return Units.Table (U).Dependency_Num;
  84    end Dependency_Num;
  85
  86    function Dependent_Unit (U : Unit_Number_Type) return Boolean is
  87    begin
  88       return Units.Table (U).Dependent_Unit;
  89    end Dependent_Unit;
  90
  91    function Dynamic_Elab (U : Unit_Number_Type) return Boolean is
  92    begin
  93       return Units.Table (U).Dynamic_Elab;
  94    end Dynamic_Elab;
  95
  96    function Error_Location (U : Unit_Number_Type) return Source_Ptr is
  97    begin
  98       return Units.Table (U).Error_Location;
  99    end Error_Location;
 100
 101    function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is
 102    begin
 103       return Units.Table (U).Expected_Unit;
 104    end Expected_Unit;
 105
 106    function Fatal_Error (U : Unit_Number_Type) return Boolean is
 107    begin
 108       return Units.Table (U).Fatal_Error;
 109    end Fatal_Error;
 110
 111    function Generate_Code (U : Unit_Number_Type) return Boolean is
 112    begin
 113       return Units.Table (U).Generate_Code;
 114    end Generate_Code;
 115
 116    function Has_RACW (U : Unit_Number_Type) return Boolean is
 117    begin
 118       return Units.Table (U).Has_RACW;
 119    end Has_RACW;
 120
 121    function Ident_String (U : Unit_Number_Type) return Node_Id is
 122    begin
 123       return Units.Table (U).Ident_String;
 124    end Ident_String;
 125
 126    function Loading (U : Unit_Number_Type) return Boolean is
 127    begin
 128       return Units.Table (U).Loading;
 129    end Loading;
 130
 131    function Main_Priority (U : Unit_Number_Type) return Int is
 132    begin
 133       return Units.Table (U).Main_Priority;
 134    end Main_Priority;
 135
 136    function Munit_Index (U : Unit_Number_Type) return Nat is
 137    begin
 138       return Units.Table (U).Munit_Index;
 139    end Munit_Index;
 140
 141    function Source_Index (U : Unit_Number_Type) return Source_File_Index is
 142    begin
 143       return Units.Table (U).Source_Index;
 144    end Source_Index;
 145
 146    function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is
 147    begin
 148       return Units.Table (U).Unit_File_Name;
 149    end Unit_File_Name;
 150
 151    function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is
 152    begin
 153       return Units.Table (U).Unit_Name;
 154    end Unit_Name;
 155
 156    ------------------------------------------
 157    -- Subprograms to Set Unit Table Fields --
 158    ------------------------------------------
 159
 160    procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is
 161    begin
 162       Units.Table (U).Cunit := N;
 163    end Set_Cunit;
 164
 165    procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is
 166    begin
 167       Units.Table (U).Cunit_Entity := E;
 168       Set_Is_Compilation_Unit (E);
 169    end Set_Cunit_Entity;
 170
 171    procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is
 172    begin
 173       Units.Table (U).Dynamic_Elab := B;
 174    end Set_Dynamic_Elab;
 175
 176    procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is
 177    begin
 178       Units.Table (U).Error_Location := W;
 179    end Set_Error_Location;
 180
 181    procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is
 182    begin
 183       Units.Table (U).Fatal_Error := B;
 184    end Set_Fatal_Error;
 185
 186    procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is
 187    begin
 188       Units.Table (U).Generate_Code := B;
 189    end Set_Generate_Code;
 190
 191    procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is
 192    begin
 193       Units.Table (U).Has_RACW := B;
 194    end Set_Has_RACW;
 195
 196    procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is
 197    begin
 198       Units.Table (U).Ident_String := N;
 199    end Set_Ident_String;
 200
 201    procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is
 202    begin
 203       Units.Table (U).Loading := B;
 204    end Set_Loading;
 205
 206    procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is
 207    begin
 208       Units.Table (U).Main_Priority := P;
 209    end Set_Main_Priority;
 210
 211    procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is
 212    begin
 213       Units.Table (U).Unit_Name := N;
 214    end Set_Unit_Name;
 215
 216    ------------------------------
 217    -- Check_Same_Extended_Unit --
 218    ------------------------------
 219
 220    function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
 221       Sloc1  : Source_Ptr;
 222       Sloc2  : Source_Ptr;
 223       Sind1  : Source_File_Index;
 224       Sind2  : Source_File_Index;
 225       Inst1  : Source_Ptr;
 226       Inst2  : Source_Ptr;
 227       Unum1  : Unit_Number_Type;
 228       Unum2  : Unit_Number_Type;
 229       Unit1  : Node_Id;
 230       Unit2  : Node_Id;
 231       Depth1 : Nat;
 232       Depth2 : Nat;
 233
 234    begin
 235       if S1 = No_Location or else S2 = No_Location then
 236          return No;
 237
 238       elsif S1 = Standard_Location then
 239          if S2 = Standard_Location then
 240             return Yes_Same;
 241          else
 242             return No;
 243          end if;
 244
 245       elsif S2 = Standard_Location then
 246          return No;
 247       end if;
 248
 249       Sloc1 := S1;
 250       Sloc2 := S2;
 251       Unum1 := Get_Code_Unit (Sloc1);
 252       Unum2 := Get_Code_Unit (Sloc2);
 253
 254       loop
 255          Sind1 := Get_Source_File_Index (Sloc1);
 256          Sind2 := Get_Source_File_Index (Sloc2);
 257
 258          if Sind1 = Sind2 then
 259             if Sloc1 < Sloc2 then
 260                return Yes_Before;
 261             elsif Sloc1 > Sloc2 then
 262                return Yes_After;
 263             else
 264                return Yes_Same;
 265             end if;
 266          end if;
 267
 268          --  OK, the two nodes are in separate source elements, but this is not
 269          --  decisive, because of the issue of subunits and instantiations.
 270
 271          --  First we deal with subunits, since if the subunit is in an
 272          --  instantiation, we know that the parent is in the corresponding
 273          --  instantiation, since that is the only way we can have a subunit
 274          --  that is part of an instantiation.
 275
 276          Unit1 := Unit (Cunit (Unum1));
 277          Unit2 := Unit (Cunit (Unum2));
 278
 279          if Nkind (Unit1) = N_Subunit
 280            and then Present (Corresponding_Stub (Unit1))
 281          then
 282             --  Both in subunits. They could have a common ancestor. If they
 283             --  do, then the deeper one must have a longer unit name. Replace
 284             --  the deeper one with its corresponding stub, in order to find
 285             --  nearest common ancestor, if any.
 286
 287             if Nkind (Unit2) = N_Subunit
 288               and then Present (Corresponding_Stub (Unit2))
 289             then
 290                if Length_Of_Name (Unit_Name (Unum1)) <
 291                   Length_Of_Name (Unit_Name (Unum2))
 292                then
 293                   Sloc2 := Sloc (Corresponding_Stub (Unit2));
 294                   Unum2 := Get_Source_Unit (Sloc2);
 295                   goto Continue;
 296
 297                else
 298                   Sloc1 := Sloc (Corresponding_Stub (Unit1));
 299                   Unum1 := Get_Source_Unit (Sloc1);
 300                   goto Continue;
 301                end if;
 302
 303             --  Nod1 in subunit, Nod2 not
 304
 305             else
 306                Sloc1 := Sloc (Corresponding_Stub (Unit1));
 307                Unum1 := Get_Source_Unit (Sloc1);
 308                goto Continue;
 309             end if;
 310
 311          --  Nod2 in subunit, Nod1 not
 312
 313          elsif Nkind (Unit2) = N_Subunit
 314            and then Present (Corresponding_Stub (Unit2))
 315          then
 316             Sloc2 := Sloc (Corresponding_Stub (Unit2));
 317             Unum2 := Get_Source_Unit (Sloc2);
 318             goto Continue;
 319          end if;
 320
 321          --  At this stage we know that neither is a subunit, so we deal
 322          --  with instantiations, since we culd have a common ancestor
 323
 324          Inst1 := Instantiation (Sind1);
 325          Inst2 := Instantiation (Sind2);
 326
 327          if Inst1 /= No_Location then
 328
 329             --  Both are instantiations
 330
 331             if Inst2 /= No_Location then
 332
 333                Depth1 := Instantiation_Depth (Sloc1);
 334                Depth2 := Instantiation_Depth (Sloc2);
 335
 336                if Depth1 < Depth2 then
 337                   Sloc2 := Inst2;
 338                   Unum2 := Get_Source_Unit (Sloc2);
 339                   goto Continue;
 340
 341                elsif Depth1 > Depth2 then
 342                   Sloc1 := Inst1;
 343                   Unum1 := Get_Source_Unit (Sloc1);
 344                   goto Continue;
 345
 346                else
 347                   Sloc1 := Inst1;
 348                   Sloc2 := Inst2;
 349                   Unum1 := Get_Source_Unit (Sloc1);
 350                   Unum2 := Get_Source_Unit (Sloc2);
 351                   goto Continue;
 352                end if;
 353
 354             --  Only first node is in instantiation
 355
 356             else
 357                Sloc1 := Inst1;
 358                Unum1 := Get_Source_Unit (Sloc1);
 359                goto Continue;
 360             end if;
 361
 362          --  Only second node is instantiation
 363
 364          elsif Inst2 /= No_Location then
 365             Sloc2 := Inst2;
 366             Unum2 := Get_Source_Unit (Sloc2);
 367             goto Continue;
 368          end if;
 369
 370          --  No instantiations involved, so we are not in the same unit
 371          --  However, there is one case still to check, namely the case
 372          --  where one location is in the spec, and the other in the
 373          --  corresponding body (the spec location is earlier).
 374
 375          if Nkind (Unit1) = N_Subprogram_Body
 376               or else
 377             Nkind (Unit1) = N_Package_Body
 378          then
 379             if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then
 380                return Yes_After;
 381             end if;
 382
 383          elsif Nkind (Unit2) = N_Subprogram_Body
 384                  or else
 385                Nkind (Unit2) = N_Package_Body
 386          then
 387             if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then
 388                return Yes_Before;
 389             end if;
 390          end if;
 391
 392          --  If that special case does not occur, then we are certain that
 393          --  the two locations are really in separate units.
 394
 395          return No;
 396
 397          <<Continue>>
 398             null;
 399       end loop;
 400    end Check_Same_Extended_Unit;
 401
 402    -------------------------------
 403    -- Compilation_Switches_Last --
 404    -------------------------------
 405
 406    function Compilation_Switches_Last return Nat is
 407    begin
 408       return Compilation_Switches.Last;
 409    end Compilation_Switches_Last;
 410
 411    ------------------------------
 412    -- Earlier_In_Extended_Unit --
 413    ------------------------------
 414
 415    function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
 416    begin
 417       return Check_Same_Extended_Unit (S1, S2) = Yes_Before;
 418    end Earlier_In_Extended_Unit;
 419
 420    ----------------------------
 421    -- Entity_Is_In_Main_Unit --
 422    ----------------------------
 423
 424    function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is
 425       S : Entity_Id;
 426
 427    begin
 428       S := Scope (E);
 429
 430       while S /= Standard_Standard loop
 431          if S = Main_Unit_Entity then
 432             return True;
 433          elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then
 434             return False;
 435          else
 436             S := Scope (S);
 437          end if;
 438       end loop;
 439
 440       return False;
 441    end Entity_Is_In_Main_Unit;
 442
 443    ---------------------------------
 444    -- Generic_Separately_Compiled --
 445    ---------------------------------
 446
 447    function Generic_Separately_Compiled (E : Entity_Id) return Boolean is
 448    begin
 449       --  We do not generate object files for internal generics, because
 450       --  the only thing they would contain is the elaboration boolean, and
 451       --  we are careful to elaborate all predefined units first anyway, so
 452       --  this boolean is not needed.
 453
 454       if Is_Internal_File_Name
 455           (Fname => Unit_File_Name (Get_Source_Unit (E)),
 456            Renamings_Included => True)
 457       then
 458          return False;
 459
 460       --  All other generic units do generate object files
 461
 462       else
 463          return True;
 464       end if;
 465    end Generic_Separately_Compiled;
 466
 467    function Generic_Separately_Compiled
 468      (Sfile : File_Name_Type) return Boolean
 469    is
 470    begin
 471       --  Exactly the same as previous function, but works directly on a file
 472       --  name.
 473
 474       if Is_Internal_File_Name
 475           (Fname              => Sfile,
 476            Renamings_Included => True)
 477       then
 478          return False;
 479
 480       --  All other generic units do generate object files
 481
 482       else
 483          return True;
 484       end if;
 485    end Generic_Separately_Compiled;
 486
 487    -------------------
 488    -- Get_Code_Unit --
 489    -------------------
 490
 491    function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
 492    begin
 493       --  Search table unless we have No_Location, which can happen if the
 494       --  relevant location has not been set yet. Happens for example when
 495       --  we obtain Sloc (Cunit (Main_Unit)) before it is set.
 496
 497       if S /= No_Location then
 498          declare
 499             Source_File : constant Source_File_Index :=
 500                             Get_Source_File_Index (Top_Level_Location (S));
 501
 502          begin
 503             for U in Units.First .. Units.Last loop
 504                if Source_Index (U) = Source_File then
 505                   return U;
 506                end if;
 507             end loop;
 508          end;
 509       end if;
 510
 511       --  If S was No_Location, or was not in the table, we must be in the
 512       --  main source unit (and the value has not been placed in the table yet)
 513
 514       return Main_Unit;
 515    end Get_Code_Unit;
 516
 517    function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
 518    begin
 519       return Get_Code_Unit (Sloc (N));
 520    end Get_Code_Unit;
 521
 522    ----------------------------
 523    -- Get_Compilation_Switch --
 524    ----------------------------
 525
 526    function Get_Compilation_Switch (N : Pos) return String_Ptr is
 527    begin
 528       if N <= Compilation_Switches.Last then
 529          return Compilation_Switches.Table (N);
 530
 531       else
 532          return null;
 533       end if;
 534    end Get_Compilation_Switch;
 535
 536    ----------------------------------
 537    -- Get_Cunit_Entity_Unit_Number --
 538    ----------------------------------
 539
 540    function Get_Cunit_Entity_Unit_Number
 541      (E : Entity_Id) return Unit_Number_Type
 542    is
 543    begin
 544       for U in Units.First .. Units.Last loop
 545          if Cunit_Entity (U) = E then
 546             return U;
 547          end if;
 548       end loop;
 549
 550       --  If not in the table, must be the main source unit, and we just
 551       --  have not got it put into the table yet.
 552
 553       return Main_Unit;
 554    end Get_Cunit_Entity_Unit_Number;
 555
 556    ---------------------------
 557    -- Get_Cunit_Unit_Number --
 558    ---------------------------
 559
 560    function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is
 561    begin
 562       for U in Units.First .. Units.Last loop
 563          if Cunit (U) = N then
 564             return U;
 565          end if;
 566       end loop;
 567
 568       --  If not in the table, must be the main source unit, and we just
 569       --  have not got it put into the table yet.
 570
 571       return Main_Unit;
 572    end Get_Cunit_Unit_Number;
 573
 574    ---------------------
 575    -- Get_Source_Unit --
 576    ---------------------
 577
 578    function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
 579    begin
 580       --  Search table unless we have No_Location, which can happen if the
 581       --  relevant location has not been set yet. Happens for example when
 582       --  we obtain Sloc (Cunit (Main_Unit)) before it is set.
 583
 584       if S /= No_Location then
 585          declare
 586             Source_File : Source_File_Index :=
 587                             Get_Source_File_Index (Top_Level_Location (S));
 588
 589          begin
 590             Source_File := Get_Source_File_Index (S);
 591             while Template (Source_File) /= No_Source_File loop
 592                Source_File := Template (Source_File);
 593             end loop;
 594
 595             for U in Units.First .. Units.Last loop
 596                if Source_Index (U) = Source_File then
 597                   return U;
 598                end if;
 599             end loop;
 600          end;
 601       end if;
 602
 603       --  If S was No_Location, or was not in the table, we must be in the
 604       --  main source unit (and the value has not got put into the table yet)
 605
 606       return Main_Unit;
 607    end Get_Source_Unit;
 608
 609    function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
 610    begin
 611       return Get_Source_Unit (Sloc (N));
 612    end Get_Source_Unit;
 613
 614    --------------------------------
 615    -- In_Extended_Main_Code_Unit --
 616    --------------------------------
 617
 618    function In_Extended_Main_Code_Unit
 619      (N : Node_Or_Entity_Id) return Boolean
 620    is
 621    begin
 622       if Sloc (N) = Standard_Location then
 623          return True;
 624
 625       elsif Sloc (N) = No_Location then
 626          return False;
 627
 628       --  Special case Itypes to test the Sloc of the associated node. The
 629       --  reason we do this is for possible calls from gigi after -gnatD
 630       --  processing is complete in sprint. This processing updates the
 631       --  sloc fields of all nodes in the tree, but itypes are not in the
 632       --  tree so their slocs do not get updated.
 633
 634       elsif Nkind (N) = N_Defining_Identifier
 635         and then Is_Itype (N)
 636       then
 637          return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N));
 638
 639       --  Otherwise see if we are in the main unit
 640
 641       elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then
 642          return True;
 643
 644       --  Node may be in spec (or subunit etc) of main unit
 645
 646       else
 647          return
 648            In_Same_Extended_Unit (Sloc (N), Sloc (Cunit (Main_Unit)));
 649       end if;
 650    end In_Extended_Main_Code_Unit;
 651
 652    function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is
 653    begin
 654       if Loc = Standard_Location then
 655          return True;
 656
 657       elsif Loc = No_Location then
 658          return False;
 659
 660       --  Otherwise see if we are in the main unit
 661
 662       elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then
 663          return True;
 664
 665       --  Location may be in spec (or subunit etc) of main unit
 666
 667       else
 668          return
 669            In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
 670       end if;
 671    end In_Extended_Main_Code_Unit;
 672
 673    ----------------------------------
 674    -- In_Extended_Main_Source_Unit --
 675    ----------------------------------
 676
 677    function In_Extended_Main_Source_Unit
 678      (N : Node_Or_Entity_Id) return Boolean
 679    is
 680       Nloc : constant Source_Ptr := Sloc (N);
 681       Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
 682
 683    begin
 684       --  If Mloc is not set, it means we are still parsing the main unit,
 685       --  so everything so far is in the extended main source unit.
 686
 687       if Mloc = No_Location then
 688          return True;
 689
 690       --  Special value cases
 691
 692       elsif Nloc = Standard_Location then
 693          return True;
 694
 695       elsif Nloc = No_Location then
 696          return False;
 697
 698       --  Special case Itypes to test the Sloc of the associated node. The
 699       --  reason we do this is for possible calls from gigi after -gnatD
 700       --  processing is complete in sprint. This processing updates the
 701       --  sloc fields of all nodes in the tree, but itypes are not in the
 702       --  tree so their slocs do not get updated.
 703
 704       elsif Nkind (N) = N_Defining_Identifier
 705         and then Is_Itype (N)
 706       then
 707          return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N));
 708
 709       --  Otherwise compare original locations to see if in same unit
 710
 711       else
 712          return
 713            In_Same_Extended_Unit
 714              (Original_Location (Nloc), Original_Location (Mloc));
 715       end if;
 716    end In_Extended_Main_Source_Unit;
 717
 718    function In_Extended_Main_Source_Unit
 719      (Loc : Source_Ptr) return Boolean
 720    is
 721       Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
 722
 723    begin
 724       --  If Mloc is not set, it means we are still parsing the main unit,
 725       --  so everything so far is in the extended main source unit.
 726
 727       if Mloc = No_Location then
 728          return True;
 729
 730       --  Special value cases
 731
 732       elsif Loc = Standard_Location then
 733          return True;
 734
 735       elsif Loc = No_Location then
 736          return False;
 737
 738       --  Otherwise compare original locations to see if in same unit
 739
 740       else
 741          return
 742            In_Same_Extended_Unit
 743              (Original_Location (Loc), Original_Location (Mloc));
 744       end if;
 745    end In_Extended_Main_Source_Unit;
 746
 747    -----------------------
 748    -- In_Same_Code_Unit --
 749    -----------------------
 750
 751    function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
 752       S1 : constant Source_Ptr := Sloc (N1);
 753       S2 : constant Source_Ptr := Sloc (N2);
 754
 755    begin
 756       if S1 = No_Location or else S2 = No_Location then
 757          return False;
 758
 759       elsif S1 = Standard_Location then
 760          return S2 = Standard_Location;
 761
 762       elsif S2 = Standard_Location then
 763          return False;
 764       end if;
 765
 766       return Get_Code_Unit (N1) = Get_Code_Unit (N2);
 767    end In_Same_Code_Unit;
 768
 769    ---------------------------
 770    -- In_Same_Extended_Unit --
 771    ---------------------------
 772
 773    function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is
 774    begin
 775       return Check_Same_Extended_Unit (S1, S2) /= No;
 776    end In_Same_Extended_Unit;
 777
 778    -------------------------
 779    -- In_Same_Source_Unit --
 780    -------------------------
 781
 782    function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is
 783       S1 : constant Source_Ptr := Sloc (N1);
 784       S2 : constant Source_Ptr := Sloc (N2);
 785
 786    begin
 787       if S1 = No_Location or else S2 = No_Location then
 788          return False;
 789
 790       elsif S1 = Standard_Location then
 791          return S2 = Standard_Location;
 792
 793       elsif S2 = Standard_Location then
 794          return False;
 795       end if;
 796
 797       return Get_Source_Unit (N1) = Get_Source_Unit (N2);
 798    end In_Same_Source_Unit;
 799
 800    -----------------------------
 801    -- Increment_Serial_Number --
 802    -----------------------------
 803
 804    function Increment_Serial_Number return Nat is
 805       TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number;
 806    begin
 807       TSN := TSN + 1;
 808       return TSN;
 809    end Increment_Serial_Number;
 810
 811    ----------------
 812    -- Initialize --
 813    ----------------
 814
 815    procedure Initialize is
 816    begin
 817       Linker_Option_Lines.Init;
 818       Load_Stack.Init;
 819       Units.Init;
 820       Unit_Exception_Table_Present := False;
 821       Compilation_Switches.Init;
 822    end Initialize;
 823
 824    ---------------
 825    -- Is_Loaded --
 826    ---------------
 827
 828    function Is_Loaded (Uname : Unit_Name_Type) return Boolean is
 829    begin
 830       for Unum in Units.First .. Units.Last loop
 831          if Uname = Unit_Name (Unum) then
 832             return True;
 833          end if;
 834       end loop;
 835
 836       return False;
 837    end Is_Loaded;
 838
 839    ---------------
 840    -- Last_Unit --
 841    ---------------
 842
 843    function Last_Unit return Unit_Number_Type is
 844    begin
 845       return Units.Last;
 846    end Last_Unit;
 847
 848    ----------
 849    -- List --
 850    ----------
 851
 852    procedure List (File_Names_Only : Boolean := False) is separate;
 853
 854    ----------
 855    -- Lock --
 856    ----------
 857
 858    procedure Lock is
 859    begin
 860       Linker_Option_Lines.Locked := True;
 861       Load_Stack.Locked := True;
 862       Units.Locked := True;
 863       Linker_Option_Lines.Release;
 864       Load_Stack.Release;
 865       Units.Release;
 866    end Lock;
 867
 868    ---------------
 869    -- Num_Units --
 870    ---------------
 871
 872    function Num_Units return Nat is
 873    begin
 874       return Int (Units.Last) - Int (Main_Unit) + 1;
 875    end Num_Units;
 876
 877    -----------------
 878    -- Remove_Unit --
 879    -----------------
 880
 881    procedure Remove_Unit (U : Unit_Number_Type) is
 882    begin
 883       if U = Units.Last then
 884          Units.Decrement_Last;
 885       end if;
 886    end Remove_Unit;
 887
 888    ----------------------------------
 889    -- Replace_Linker_Option_String --
 890    ----------------------------------
 891
 892    procedure Replace_Linker_Option_String
 893      (S : String_Id; Match_String : String)
 894    is
 895    begin
 896       if Match_String'Length > 0 then
 897          for J in 1 .. Linker_Option_Lines.Last loop
 898             String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option);
 899
 900             if Match_String = Name_Buffer (1 .. Match_String'Length) then
 901                Linker_Option_Lines.Table (J).Option := S;
 902                return;
 903             end if;
 904          end loop;
 905       end if;
 906
 907       Store_Linker_Option_String (S);
 908    end Replace_Linker_Option_String;
 909
 910    ----------
 911    -- Sort --
 912    ----------
 913
 914    procedure Sort (Tbl : in out Unit_Ref_Table) is separate;
 915
 916    ------------------------------
 917    -- Store_Compilation_Switch --
 918    ------------------------------
 919
 920    procedure Store_Compilation_Switch (Switch : String) is
 921    begin
 922       Compilation_Switches.Increment_Last;
 923       Compilation_Switches.Table (Compilation_Switches.Last) :=
 924         new String'(Switch);
 925
 926       --  Fix up --RTS flag which has been transformed by the gcc driver
 927       --  into -fRTS
 928
 929       if Switch'Last >= Switch'First + 4
 930         and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
 931       then
 932          Compilation_Switches.Table
 933            (Compilation_Switches.Last) (Switch'First + 1) := '-';
 934       end if;
 935    end Store_Compilation_Switch;
 936
 937    --------------------------------
 938    -- Store_Linker_Option_String --
 939    --------------------------------
 940
 941    procedure Store_Linker_Option_String (S : String_Id) is
 942    begin
 943       Linker_Option_Lines.Increment_Last;
 944       Linker_Option_Lines.Table (Linker_Option_Lines.Last) :=
 945         (Option => S, Unit => Current_Sem_Unit);
 946    end Store_Linker_Option_String;
 947
 948    ---------------
 949    -- Tree_Read --
 950    ---------------
 951
 952    procedure Tree_Read is
 953       N : Nat;
 954       S : String_Ptr;
 955
 956    begin
 957       Units.Tree_Read;
 958
 959       --  Read Compilation_Switches table
 960
 961       Tree_Read_Int (N);
 962       Compilation_Switches.Set_Last (N);
 963
 964       for J in 1 .. N loop
 965          Tree_Read_Str (S);
 966          Compilation_Switches.Table (J) := S;
 967       end loop;
 968    end Tree_Read;
 969
 970    ----------------
 971    -- Tree_Write --
 972    ----------------
 973
 974    procedure Tree_Write is
 975    begin
 976       Units.Tree_Write;
 977
 978       --  Write Compilation_Switches table
 979
 980       Tree_Write_Int (Compilation_Switches.Last);
 981
 982       for J in 1 .. Compilation_Switches.Last loop
 983          Tree_Write_Str (Compilation_Switches.Table (J));
 984       end loop;
 985    end Tree_Write;
 986
 987    -----------------
 988    -- Version_Get --
 989    -----------------
 990
 991    function Version_Get (U : Unit_Number_Type) return Word_Hex_String is
 992    begin
 993       return Get_Hex_String (Units.Table (U).Version);
 994    end Version_Get;
 995
 996    ------------------------
 997    -- Version_Referenced --
 998    ------------------------
 999
1000    procedure Version_Referenced (S : String_Id) is
1001    begin
1002       Version_Ref.Append (S);
1003    end Version_Referenced;
1004
1005 end Lib;