diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/lib.adb')
-rw-r--r-- | gcc-4.4.3/gcc/ada/lib.adb | 1066 |
1 files changed, 0 insertions, 1066 deletions
diff --git a/gcc-4.4.3/gcc/ada/lib.adb b/gcc-4.4.3/gcc/ada/lib.adb deleted file mode 100644 index 2ad3a4c88..000000000 --- a/gcc-4.4.3/gcc/ada/lib.adb +++ /dev/null @@ -1,1066 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- L I B -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Subprogram ordering not enforced in this unit --- (because of some logical groupings). - -with Atree; use Atree; -with Einfo; use Einfo; -with Fname; use Fname; -with Output; use Output; -with Sinfo; use Sinfo; -with Sinput; use Sinput; -with Stand; use Stand; -with Stringt; use Stringt; -with Tree_IO; use Tree_IO; -with Uname; use Uname; - -package body Lib is - - Switch_Storing_Enabled : Boolean := True; - -- Controlled by Enable_Switch_Storing/Disable_Switch_Storing - - ----------------------- - -- Local Subprograms -- - ----------------------- - - type SEU_Result is ( - Yes_Before, -- S1 is in same extended unit as S2 and appears before it - Yes_Same, -- S1 is in same extended unit as S2, Slocs are the same - Yes_After, -- S1 is in same extended unit as S2, and appears after it - No); -- S2 is not in same extended unit as S2 - - function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result; - -- Used by In_Same_Extended_Unit and Earlier_In_Extended_Unit. Returns - -- value as described above. - - function Get_Code_Or_Source_Unit - (S : Source_Ptr; - Unwind_Instances : Boolean) return Unit_Number_Type; - -- Common code for Get_Code_Unit (get unit of instantiation for location) - -- and Get_Source_Unit (get unit of template for location). - - -------------------------------------------- - -- Access Functions for Unit Table Fields -- - -------------------------------------------- - - function Cunit (U : Unit_Number_Type) return Node_Id is - begin - return Units.Table (U).Cunit; - end Cunit; - - function Cunit_Entity (U : Unit_Number_Type) return Entity_Id is - begin - return Units.Table (U).Cunit_Entity; - end Cunit_Entity; - - function Dependency_Num (U : Unit_Number_Type) return Nat is - begin - return Units.Table (U).Dependency_Num; - end Dependency_Num; - - function Dynamic_Elab (U : Unit_Number_Type) return Boolean is - begin - return Units.Table (U).Dynamic_Elab; - end Dynamic_Elab; - - function Error_Location (U : Unit_Number_Type) return Source_Ptr is - begin - return Units.Table (U).Error_Location; - end Error_Location; - - function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type is - begin - return Units.Table (U).Expected_Unit; - end Expected_Unit; - - function Fatal_Error (U : Unit_Number_Type) return Boolean is - begin - return Units.Table (U).Fatal_Error; - end Fatal_Error; - - function Generate_Code (U : Unit_Number_Type) return Boolean is - begin - return Units.Table (U).Generate_Code; - end Generate_Code; - - function Has_RACW (U : Unit_Number_Type) return Boolean is - begin - return Units.Table (U).Has_RACW; - end Has_RACW; - - function Is_Compiler_Unit (U : Unit_Number_Type) return Boolean is - begin - return Units.Table (U).Is_Compiler_Unit; - end Is_Compiler_Unit; - - function Ident_String (U : Unit_Number_Type) return Node_Id is - begin - return Units.Table (U).Ident_String; - end Ident_String; - - function Loading (U : Unit_Number_Type) return Boolean is - begin - return Units.Table (U).Loading; - end Loading; - - function Main_Priority (U : Unit_Number_Type) return Int is - begin - return Units.Table (U).Main_Priority; - end Main_Priority; - - function Munit_Index (U : Unit_Number_Type) return Nat is - begin - return Units.Table (U).Munit_Index; - end Munit_Index; - - function OA_Setting (U : Unit_Number_Type) return Character is - begin - return Units.Table (U).OA_Setting; - end OA_Setting; - - function Source_Index (U : Unit_Number_Type) return Source_File_Index is - begin - return Units.Table (U).Source_Index; - end Source_Index; - - function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type is - begin - return Units.Table (U).Unit_File_Name; - end Unit_File_Name; - - function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type is - begin - return Units.Table (U).Unit_Name; - end Unit_Name; - - ------------------------------------------ - -- Subprograms to Set Unit Table Fields -- - ------------------------------------------ - - procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id) is - begin - Units.Table (U).Cunit := N; - end Set_Cunit; - - procedure Set_Cunit_Entity (U : Unit_Number_Type; E : Entity_Id) is - begin - Units.Table (U).Cunit_Entity := E; - Set_Is_Compilation_Unit (E); - end Set_Cunit_Entity; - - procedure Set_Dynamic_Elab (U : Unit_Number_Type; B : Boolean := True) is - begin - Units.Table (U).Dynamic_Elab := B; - end Set_Dynamic_Elab; - - procedure Set_Error_Location (U : Unit_Number_Type; W : Source_Ptr) is - begin - Units.Table (U).Error_Location := W; - end Set_Error_Location; - - procedure Set_Fatal_Error (U : Unit_Number_Type; B : Boolean := True) is - begin - Units.Table (U).Fatal_Error := B; - end Set_Fatal_Error; - - procedure Set_Generate_Code (U : Unit_Number_Type; B : Boolean := True) is - begin - Units.Table (U).Generate_Code := B; - end Set_Generate_Code; - - procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is - begin - Units.Table (U).Has_RACW := B; - end Set_Has_RACW; - - procedure Set_Is_Compiler_Unit - (U : Unit_Number_Type; - B : Boolean := True) - is - begin - Units.Table (U).Is_Compiler_Unit := B; - end Set_Is_Compiler_Unit; - - procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id) is - begin - Units.Table (U).Ident_String := N; - end Set_Ident_String; - - procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True) is - begin - Units.Table (U).Loading := B; - end Set_Loading; - - procedure Set_Main_Priority (U : Unit_Number_Type; P : Int) is - begin - Units.Table (U).Main_Priority := P; - end Set_Main_Priority; - - procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is - begin - Units.Table (U).OA_Setting := C; - end Set_OA_Setting; - - procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is - begin - Units.Table (U).Unit_Name := N; - end Set_Unit_Name; - - ------------------------------ - -- Check_Same_Extended_Unit -- - ------------------------------ - - function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is - Sloc1 : Source_Ptr; - Sloc2 : Source_Ptr; - Sind1 : Source_File_Index; - Sind2 : Source_File_Index; - Inst1 : Source_Ptr; - Inst2 : Source_Ptr; - Unum1 : Unit_Number_Type; - Unum2 : Unit_Number_Type; - Unit1 : Node_Id; - Unit2 : Node_Id; - Depth1 : Nat; - Depth2 : Nat; - - begin - if S1 = No_Location or else S2 = No_Location then - return No; - - elsif S1 = Standard_Location then - if S2 = Standard_Location then - return Yes_Same; - else - return No; - end if; - - elsif S2 = Standard_Location then - return No; - end if; - - Sloc1 := S1; - Sloc2 := S2; - Unum1 := Get_Code_Unit (Sloc1); - Unum2 := Get_Code_Unit (Sloc2); - - loop - Sind1 := Get_Source_File_Index (Sloc1); - Sind2 := Get_Source_File_Index (Sloc2); - - if Sind1 = Sind2 then - if Sloc1 < Sloc2 then - return Yes_Before; - elsif Sloc1 > Sloc2 then - return Yes_After; - else - return Yes_Same; - end if; - end if; - - -- OK, the two nodes are in separate source elements, but this is not - -- decisive, because of the issue of subunits and instantiations. - - -- First we deal with subunits, since if the subunit is in an - -- instantiation, we know that the parent is in the corresponding - -- instantiation, since that is the only way we can have a subunit - -- that is part of an instantiation. - - Unit1 := Unit (Cunit (Unum1)); - Unit2 := Unit (Cunit (Unum2)); - - if Nkind (Unit1) = N_Subunit - and then Present (Corresponding_Stub (Unit1)) - then - -- Both in subunits. They could have a common ancestor. If they - -- do, then the deeper one must have a longer unit name. Replace - -- the deeper one with its corresponding stub, in order to find - -- nearest common ancestor, if any. - - if Nkind (Unit2) = N_Subunit - and then Present (Corresponding_Stub (Unit2)) - then - if Length_Of_Name (Unit_Name (Unum1)) < - Length_Of_Name (Unit_Name (Unum2)) - then - Sloc2 := Sloc (Corresponding_Stub (Unit2)); - Unum2 := Get_Source_Unit (Sloc2); - goto Continue; - - else - Sloc1 := Sloc (Corresponding_Stub (Unit1)); - Unum1 := Get_Source_Unit (Sloc1); - goto Continue; - end if; - - -- Nod1 in subunit, Nod2 not - - else - Sloc1 := Sloc (Corresponding_Stub (Unit1)); - Unum1 := Get_Source_Unit (Sloc1); - goto Continue; - end if; - - -- Nod2 in subunit, Nod1 not - - elsif Nkind (Unit2) = N_Subunit - and then Present (Corresponding_Stub (Unit2)) - then - Sloc2 := Sloc (Corresponding_Stub (Unit2)); - Unum2 := Get_Source_Unit (Sloc2); - goto Continue; - end if; - - -- At this stage we know that neither is a subunit, so we deal - -- with instantiations, since we could have a common ancestor - - Inst1 := Instantiation (Sind1); - Inst2 := Instantiation (Sind2); - - if Inst1 /= No_Location then - - -- Both are instantiations - - if Inst2 /= No_Location then - - Depth1 := Instantiation_Depth (Sloc1); - Depth2 := Instantiation_Depth (Sloc2); - - if Depth1 < Depth2 then - Sloc2 := Inst2; - Unum2 := Get_Source_Unit (Sloc2); - goto Continue; - - elsif Depth1 > Depth2 then - Sloc1 := Inst1; - Unum1 := Get_Source_Unit (Sloc1); - goto Continue; - - else - Sloc1 := Inst1; - Sloc2 := Inst2; - Unum1 := Get_Source_Unit (Sloc1); - Unum2 := Get_Source_Unit (Sloc2); - goto Continue; - end if; - - -- Only first node is in instantiation - - else - Sloc1 := Inst1; - Unum1 := Get_Source_Unit (Sloc1); - goto Continue; - end if; - - -- Only second node is instantiation - - elsif Inst2 /= No_Location then - Sloc2 := Inst2; - Unum2 := Get_Source_Unit (Sloc2); - goto Continue; - end if; - - -- No instantiations involved, so we are not in the same unit - -- However, there is one case still to check, namely the case - -- where one location is in the spec, and the other in the - -- corresponding body (the spec location is earlier). - - if Nkind (Unit1) = N_Subprogram_Body - or else - Nkind (Unit1) = N_Package_Body - then - if Library_Unit (Cunit (Unum1)) = Cunit (Unum2) then - return Yes_After; - end if; - - elsif Nkind (Unit2) = N_Subprogram_Body - or else - Nkind (Unit2) = N_Package_Body - then - if Library_Unit (Cunit (Unum2)) = Cunit (Unum1) then - return Yes_Before; - end if; - end if; - - -- If that special case does not occur, then we are certain that - -- the two locations are really in separate units. - - return No; - - <<Continue>> - null; - end loop; - end Check_Same_Extended_Unit; - - ------------------------------- - -- Compilation_Switches_Last -- - ------------------------------- - - function Compilation_Switches_Last return Nat is - begin - return Compilation_Switches.Last; - end Compilation_Switches_Last; - - --------------------------- - -- Enable_Switch_Storing -- - --------------------------- - - procedure Enable_Switch_Storing is - begin - Switch_Storing_Enabled := True; - end Enable_Switch_Storing; - - ---------------------------- - -- Disable_Switch_Storing -- - ---------------------------- - - procedure Disable_Switch_Storing is - begin - Switch_Storing_Enabled := False; - end Disable_Switch_Storing; - - ------------------------------ - -- Earlier_In_Extended_Unit -- - ------------------------------ - - function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is - begin - return Check_Same_Extended_Unit (S1, S2) = Yes_Before; - end Earlier_In_Extended_Unit; - - ---------------------------- - -- Entity_Is_In_Main_Unit -- - ---------------------------- - - function Entity_Is_In_Main_Unit (E : Entity_Id) return Boolean is - S : Entity_Id; - - begin - S := Scope (E); - - while S /= Standard_Standard loop - if S = Main_Unit_Entity then - return True; - elsif Ekind (S) = E_Package and then Is_Child_Unit (S) then - return False; - else - S := Scope (S); - end if; - end loop; - - return False; - end Entity_Is_In_Main_Unit; - - -------------------------- - -- Generic_May_Lack_ALI -- - -------------------------- - - function Generic_May_Lack_ALI (Sfile : File_Name_Type) return Boolean is - begin - -- We allow internal generic units to be used without having a - -- corresponding ALI files to help bootstrapping with older compilers - -- that did not support generating ALIs for such generics. It is safe - -- to do so because the only thing the generated code would contain - -- is the elaboration boolean, and we are careful to elaborate all - -- predefined units first anyway. - - return Is_Internal_File_Name - (Fname => Sfile, - Renamings_Included => True); - end Generic_May_Lack_ALI; - - ----------------------------- - -- Get_Code_Or_Source_Unit -- - ----------------------------- - - function Get_Code_Or_Source_Unit - (S : Source_Ptr; - Unwind_Instances : Boolean) return Unit_Number_Type - is - begin - -- Search table unless we have No_Location, which can happen if the - -- relevant location has not been set yet. Happens for example when - -- we obtain Sloc (Cunit (Main_Unit)) before it is set. - - if S /= No_Location then - declare - Source_File : Source_File_Index; - Source_Unit : Unit_Number_Type; - - begin - Source_File := Get_Source_File_Index (S); - - if Unwind_Instances then - while Template (Source_File) /= No_Source_File loop - Source_File := Template (Source_File); - end loop; - end if; - - Source_Unit := Unit (Source_File); - - if Source_Unit /= No_Unit then - return Source_Unit; - end if; - end; - end if; - - -- If S was No_Location, or was not in the table, we must be in the main - -- source unit (and the value has not been placed in the table yet), - -- or in one of the configuration pragma files. - - return Main_Unit; - end Get_Code_Or_Source_Unit; - - ------------------- - -- Get_Code_Unit -- - ------------------- - - function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is - begin - return Get_Code_Or_Source_Unit (Top_Level_Location (S), - Unwind_Instances => False); - end Get_Code_Unit; - - function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is - begin - return Get_Code_Unit (Sloc (N)); - end Get_Code_Unit; - - ---------------------------- - -- Get_Compilation_Switch -- - ---------------------------- - - function Get_Compilation_Switch (N : Pos) return String_Ptr is - begin - if N <= Compilation_Switches.Last then - return Compilation_Switches.Table (N); - - else - return null; - end if; - end Get_Compilation_Switch; - - ---------------------------------- - -- Get_Cunit_Entity_Unit_Number -- - ---------------------------------- - - function Get_Cunit_Entity_Unit_Number - (E : Entity_Id) return Unit_Number_Type - is - begin - for U in Units.First .. Units.Last loop - if Cunit_Entity (U) = E then - return U; - end if; - end loop; - - -- If not in the table, must be the main source unit, and we just - -- have not got it put into the table yet. - - return Main_Unit; - end Get_Cunit_Entity_Unit_Number; - - --------------------------- - -- Get_Cunit_Unit_Number -- - --------------------------- - - function Get_Cunit_Unit_Number (N : Node_Id) return Unit_Number_Type is - begin - for U in Units.First .. Units.Last loop - if Cunit (U) = N then - return U; - end if; - end loop; - - -- If not in the table, must be the main source unit, and we just - -- have not got it put into the table yet. - - return Main_Unit; - end Get_Cunit_Unit_Number; - - --------------------- - -- Get_Source_Unit -- - --------------------- - - function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is - begin - return Get_Code_Or_Source_Unit (S, Unwind_Instances => True); - end Get_Source_Unit; - - function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is - begin - return Get_Source_Unit (Sloc (N)); - end Get_Source_Unit; - - -------------------------------- - -- In_Extended_Main_Code_Unit -- - -------------------------------- - - function In_Extended_Main_Code_Unit - (N : Node_Or_Entity_Id) return Boolean - is - begin - if Sloc (N) = Standard_Location then - return True; - - elsif Sloc (N) = No_Location then - return False; - - -- Special case Itypes to test the Sloc of the associated node. The - -- reason we do this is for possible calls from gigi after -gnatD - -- processing is complete in sprint. This processing updates the - -- sloc fields of all nodes in the tree, but itypes are not in the - -- tree so their slocs do not get updated. - - elsif Nkind (N) = N_Defining_Identifier - and then Is_Itype (N) - then - return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N)); - - -- Otherwise see if we are in the main unit - - elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then - return True; - - -- Node may be in spec (or subunit etc) of main unit - - else - return - In_Same_Extended_Unit (N, Cunit (Main_Unit)); - end if; - end In_Extended_Main_Code_Unit; - - function In_Extended_Main_Code_Unit (Loc : Source_Ptr) return Boolean is - begin - if Loc = Standard_Location then - return True; - - elsif Loc = No_Location then - return False; - - -- Otherwise see if we are in the main unit - - elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then - return True; - - -- Location may be in spec (or subunit etc) of main unit - - else - return - In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit))); - end if; - end In_Extended_Main_Code_Unit; - - ---------------------------------- - -- In_Extended_Main_Source_Unit -- - ---------------------------------- - - function In_Extended_Main_Source_Unit - (N : Node_Or_Entity_Id) return Boolean - is - Nloc : constant Source_Ptr := Sloc (N); - Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); - - begin - -- If Mloc is not set, it means we are still parsing the main unit, - -- so everything so far is in the extended main source unit. - - if Mloc = No_Location then - return True; - - -- Special value cases - - elsif Nloc = Standard_Location then - return True; - - elsif Nloc = No_Location then - return False; - - -- Special case Itypes to test the Sloc of the associated node. The - -- reason we do this is for possible calls from gigi after -gnatD - -- processing is complete in sprint. This processing updates the - -- sloc fields of all nodes in the tree, but itypes are not in the - -- tree so their slocs do not get updated. - - elsif Nkind (N) = N_Defining_Identifier - and then Is_Itype (N) - then - return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N)); - - -- Otherwise compare original locations to see if in same unit - - else - return - In_Same_Extended_Unit - (Original_Location (Nloc), Original_Location (Mloc)); - end if; - end In_Extended_Main_Source_Unit; - - function In_Extended_Main_Source_Unit - (Loc : Source_Ptr) return Boolean - is - Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit)); - - begin - -- If Mloc is not set, it means we are still parsing the main unit, - -- so everything so far is in the extended main source unit. - - if Mloc = No_Location then - return True; - - -- Special value cases - - elsif Loc = Standard_Location then - return True; - - elsif Loc = No_Location then - return False; - - -- Otherwise compare original locations to see if in same unit - - else - return - In_Same_Extended_Unit - (Original_Location (Loc), Original_Location (Mloc)); - end if; - end In_Extended_Main_Source_Unit; - - ------------------------ - -- In_Predefined_Unit -- - ------------------------ - - function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean is - begin - return In_Predefined_Unit (Sloc (N)); - end In_Predefined_Unit; - - function In_Predefined_Unit (S : Source_Ptr) return Boolean is - Unit : constant Unit_Number_Type := Get_Source_Unit (S); - File : constant File_Name_Type := Unit_File_Name (Unit); - begin - return Is_Predefined_File_Name (File); - end In_Predefined_Unit; - - ----------------------- - -- In_Same_Code_Unit -- - ----------------------- - - function In_Same_Code_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is - S1 : constant Source_Ptr := Sloc (N1); - S2 : constant Source_Ptr := Sloc (N2); - - begin - if S1 = No_Location or else S2 = No_Location then - return False; - - elsif S1 = Standard_Location then - return S2 = Standard_Location; - - elsif S2 = Standard_Location then - return False; - end if; - - return Get_Code_Unit (N1) = Get_Code_Unit (N2); - end In_Same_Code_Unit; - - --------------------------- - -- In_Same_Extended_Unit -- - --------------------------- - - function In_Same_Extended_Unit - (N1, N2 : Node_Or_Entity_Id) return Boolean - is - begin - return Check_Same_Extended_Unit (Sloc (N1), Sloc (N2)) /= No; - end In_Same_Extended_Unit; - - function In_Same_Extended_Unit (S1, S2 : Source_Ptr) return Boolean is - begin - return Check_Same_Extended_Unit (S1, S2) /= No; - end In_Same_Extended_Unit; - - ------------------------- - -- In_Same_Source_Unit -- - ------------------------- - - function In_Same_Source_Unit (N1, N2 : Node_Or_Entity_Id) return Boolean is - S1 : constant Source_Ptr := Sloc (N1); - S2 : constant Source_Ptr := Sloc (N2); - - begin - if S1 = No_Location or else S2 = No_Location then - return False; - - elsif S1 = Standard_Location then - return S2 = Standard_Location; - - elsif S2 = Standard_Location then - return False; - end if; - - return Get_Source_Unit (N1) = Get_Source_Unit (N2); - end In_Same_Source_Unit; - - ----------------------------- - -- Increment_Serial_Number -- - ----------------------------- - - function Increment_Serial_Number return Nat is - TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; - begin - TSN := TSN + 1; - return TSN; - end Increment_Serial_Number; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Linker_Option_Lines.Init; - Load_Stack.Init; - Units.Init; - Compilation_Switches.Init; - end Initialize; - - --------------- - -- Is_Loaded -- - --------------- - - function Is_Loaded (Uname : Unit_Name_Type) return Boolean is - begin - for Unum in Units.First .. Units.Last loop - if Uname = Unit_Name (Unum) then - return True; - end if; - end loop; - - return False; - end Is_Loaded; - - --------------- - -- Last_Unit -- - --------------- - - function Last_Unit return Unit_Number_Type is - begin - return Units.Last; - end Last_Unit; - - ---------- - -- List -- - ---------- - - procedure List (File_Names_Only : Boolean := False) is separate; - - ---------- - -- Lock -- - ---------- - - procedure Lock is - begin - Linker_Option_Lines.Locked := True; - Load_Stack.Locked := True; - Units.Locked := True; - Linker_Option_Lines.Release; - Load_Stack.Release; - Units.Release; - end Lock; - - --------------- - -- Num_Units -- - --------------- - - function Num_Units return Nat is - begin - return Int (Units.Last) - Int (Main_Unit) + 1; - end Num_Units; - - ----------------- - -- Remove_Unit -- - ----------------- - - procedure Remove_Unit (U : Unit_Number_Type) is - begin - if U = Units.Last then - Units.Decrement_Last; - end if; - end Remove_Unit; - - ---------------------------------- - -- Replace_Linker_Option_String -- - ---------------------------------- - - procedure Replace_Linker_Option_String - (S : String_Id; Match_String : String) - is - begin - if Match_String'Length > 0 then - for J in 1 .. Linker_Option_Lines.Last loop - String_To_Name_Buffer (Linker_Option_Lines.Table (J).Option); - - if Match_String = Name_Buffer (1 .. Match_String'Length) then - Linker_Option_Lines.Table (J).Option := S; - return; - end if; - end loop; - end if; - - Store_Linker_Option_String (S); - end Replace_Linker_Option_String; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Tbl : in out Unit_Ref_Table) is separate; - - ------------------------------ - -- Store_Compilation_Switch -- - ------------------------------ - - procedure Store_Compilation_Switch (Switch : String) is - begin - if Switch_Storing_Enabled then - Compilation_Switches.Increment_Last; - Compilation_Switches.Table (Compilation_Switches.Last) := - new String'(Switch); - - -- Fix up --RTS flag which has been transformed by the gcc driver - -- into -fRTS - - if Switch'Last >= Switch'First + 4 - and then Switch (Switch'First .. Switch'First + 4) = "-fRTS" - then - Compilation_Switches.Table - (Compilation_Switches.Last) (Switch'First + 1) := '-'; - end if; - end if; - end Store_Compilation_Switch; - - -------------------------------- - -- Store_Linker_Option_String -- - -------------------------------- - - procedure Store_Linker_Option_String (S : String_Id) is - begin - Linker_Option_Lines.Increment_Last; - Linker_Option_Lines.Table (Linker_Option_Lines.Last) := - (Option => S, Unit => Current_Sem_Unit); - end Store_Linker_Option_String; - - ------------------------------- - -- Synchronize_Serial_Number -- - ------------------------------- - - procedure Synchronize_Serial_Number is - TSN : Int renames Units.Table (Current_Sem_Unit).Serial_Number; - begin - TSN := TSN + 1; - end Synchronize_Serial_Number; - - --------------- - -- Tree_Read -- - --------------- - - procedure Tree_Read is - N : Nat; - S : String_Ptr; - - begin - Units.Tree_Read; - - -- Read Compilation_Switches table. First release the memory occupied - -- by the previously loaded switches. - - for J in Compilation_Switches.First .. Compilation_Switches.Last loop - Free (Compilation_Switches.Table (J)); - end loop; - - Tree_Read_Int (N); - Compilation_Switches.Set_Last (N); - - for J in 1 .. N loop - Tree_Read_Str (S); - Compilation_Switches.Table (J) := S; - end loop; - end Tree_Read; - - ---------------- - -- Tree_Write -- - ---------------- - - procedure Tree_Write is - begin - Units.Tree_Write; - - -- Write Compilation_Switches table - - Tree_Write_Int (Compilation_Switches.Last); - - for J in 1 .. Compilation_Switches.Last loop - Tree_Write_Str (Compilation_Switches.Table (J)); - end loop; - end Tree_Write; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock is - begin - Linker_Option_Lines.Locked := False; - Load_Stack.Locked := False; - Units.Locked := False; - end Unlock; - - ----------------- - -- Version_Get -- - ----------------- - - function Version_Get (U : Unit_Number_Type) return Word_Hex_String is - begin - return Get_Hex_String (Units.Table (U).Version); - end Version_Get; - - ------------------------ - -- Version_Referenced -- - ------------------------ - - procedure Version_Referenced (S : String_Id) is - begin - Version_Ref.Append (S); - end Version_Referenced; - -end Lib; |