diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/lib.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/lib.adb | 1237 |
1 files changed, 1237 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/lib.adb b/gcc-4.8.3/gcc/ada/lib.adb new file mode 100644 index 000000000..fc62239b2 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/lib.adb @@ -0,0 +1,1237 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2012, 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 Csets; use Csets; +with Einfo; use Einfo; +with Fname; use Fname; +with Nlists; use Nlists; +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; +with Widechar; use Widechar; + +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_Allocator (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).Has_Allocator; + end Has_Allocator; + + 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_CPU (U : Unit_Number_Type) return Int is + begin + return Units.Table (U).Main_CPU; + end Main_CPU; + + 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_Allocator (U : Unit_Number_Type; B : Boolean := True) is + begin + Units.Table (U).Has_Allocator := B; + end Set_Has_Allocator; + + 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_CPU (U : Unit_Number_Type; P : Int) is + begin + Units.Table (U).Main_CPU := P; + end Set_Main_CPU; + + 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_Source_Unit (Sloc1); + Unum2 := Get_Source_Unit (Sloc2); + + loop + -- Step 1: Check whether the two locations are in the same source + -- file. + + 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; + + -- Step 2: Check subunits. If a subunit is instantiated, follow the + -- instantiation chain rather than the stub chain. + + Unit1 := Unit (Cunit (Unum1)); + Unit2 := Unit (Cunit (Unum2)); + Inst1 := Instantiation (Sind1); + Inst2 := Instantiation (Sind2); + + if Nkind (Unit1) = N_Subunit + and then Present (Corresponding_Stub (Unit1)) + and then Inst1 = No_Location + then + if Nkind (Unit2) = N_Subunit + and then Present (Corresponding_Stub (Unit2)) + and then Inst2 = No_Location + then + -- Both locations refer to subunits which may have a common + -- ancestor. If they do, the deeper subunit must have a longer + -- unit name. Replace the deeper one with its corresponding + -- stub in order to find the nearest ancestor. + + 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; + + -- Sloc1 in subunit, Sloc2 not + + else + Sloc1 := Sloc (Corresponding_Stub (Unit1)); + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Sloc2 in subunit, Sloc1 not + + elsif Nkind (Unit2) = N_Subunit + and then Present (Corresponding_Stub (Unit2)) + and then Inst2 = No_Location + then + Sloc2 := Sloc (Corresponding_Stub (Unit2)); + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- Step 3: Check instances. The two locations may yield a common + -- ancestor. + + if Inst1 /= No_Location then + if Inst2 /= No_Location then + + -- Both locations denote instantiations + + 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; + + -- Sloc1 is an instantiation + + else + Sloc1 := Inst1; + Unum1 := Get_Source_Unit (Sloc1); + goto Continue; + end if; + + -- Sloc2 is an instantiation + + elsif Inst2 /= No_Location then + Sloc2 := Inst2; + Unum2 := Get_Source_Unit (Sloc2); + goto Continue; + end if; + + -- Step 4: One location in the spec, the other in the corresponding + -- body of the same unit. The location in the spec is considered + -- 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; + + -- At this point it is certain that the two locations denote two + -- entirely 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; + + ----------------------- + -- Exact_Source_Name -- + ----------------------- + + function Exact_Source_Name (Loc : Source_Ptr) return String is + U : constant Unit_Number_Type := Get_Source_Unit (Loc); + Buf : constant Source_Buffer_Ptr := Source_Text (Source_Index (U)); + Orig : constant Source_Ptr := Original_Location (Loc); + P : Source_Ptr; + + WC : Char_Code; + Err : Boolean; + pragma Warnings (Off, WC); + pragma Warnings (Off, Err); + + begin + -- Entity is character literal + + if Buf (Orig) = ''' then + return String (Buf (Orig .. Orig + 2)); + + -- Entity is operator symbol + + elsif Buf (Orig) = '"' or else Buf (Orig) = '%' then + P := Orig; + + loop + P := P + 1; + exit when Buf (P) = Buf (Orig); + end loop; + + return String (Buf (Orig .. P)); + + -- Entity is identifier + + else + P := Orig; + + loop + if Is_Start_Of_Wide_Char (Buf, P) then + Scan_Wide (Buf, P, WC, Err); + elsif not Identifier_Char (Buf (P)) then + exit; + else + P := P + 1; + end if; + end loop; + + -- Write out the identifier by copying the exact source characters + -- used in its declaration. Note that this means wide characters will + -- be in their original encoded form. + + return String (Buf (Orig .. P - 1)); + end if; + end Exact_Source_Name; + + ---------------------------- + -- 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 a spec created for a main unit that is a + -- child subprogram body which we have not inserted into the table yet. + + if N = Library_Unit (Cunit (Main_Unit)) then + return Main_Unit; + + -- If it is anything else, something is seriously wrong, and we really + -- don't want to proceed, even if assertions are off, so we explicitly + -- raise an exception in this case to terminate compilation. + + else + raise Program_Error; + end if; + 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 parsing, then use the global flag to indicate result + + if Compiler_State = Parsing then + return Parsing_Main_Extended_Source; + + -- 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 parsing, then use the global flag to indicate result + + if Compiler_State = Parsing then + return Parsing_Main_Extended_Source; + + -- 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; + Notes.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.Append ((Option => S, Unit => Current_Sem_Unit)); + end Store_Linker_Option_String; + + ---------------- + -- Store_Note -- + ---------------- + + procedure Store_Note (N : Node_Id) is + begin + Notes.Append ((Pragma_Node => N, Unit => Current_Sem_Unit)); + end Store_Note; + + ------------------------------- + -- 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; + + --------------------- + -- Write_Unit_Info -- + --------------------- + + procedure Write_Unit_Info + (Unit_Num : Unit_Number_Type; + Item : Node_Id; + Prefix : String := ""; + Withs : Boolean := False) + is + begin + Write_Str (Prefix); + Write_Unit_Name (Unit_Name (Unit_Num)); + Write_Str (", unit "); + Write_Int (Int (Unit_Num)); + Write_Str (", "); + Write_Int (Int (Item)); + Write_Str ("="); + Write_Str (Node_Kind'Image (Nkind (Item))); + + if Item /= Original_Node (Item) then + Write_Str (", orig = "); + Write_Int (Int (Original_Node (Item))); + Write_Str ("="); + Write_Str (Node_Kind'Image (Nkind (Original_Node (Item)))); + end if; + + Write_Eol; + + -- Skip the rest if we're not supposed to print the withs + + if not Withs then + return; + end if; + + declare + Context_Item : Node_Id; + + begin + Context_Item := First (Context_Items (Cunit (Unit_Num))); + while Present (Context_Item) + and then (Nkind (Context_Item) /= N_With_Clause + or else Limited_Present (Context_Item)) + loop + Context_Item := Next (Context_Item); + end loop; + + if Present (Context_Item) then + Indent; + Write_Line ("withs:"); + Indent; + + while Present (Context_Item) loop + if Nkind (Context_Item) = N_With_Clause + and then not Limited_Present (Context_Item) + then + pragma Assert (Present (Library_Unit (Context_Item))); + Write_Unit_Name + (Unit_Name + (Get_Cunit_Unit_Number (Library_Unit (Context_Item)))); + + if Implicit_With (Context_Item) then + Write_Str (" -- implicit"); + end if; + + Write_Eol; + end if; + + Context_Item := Next (Context_Item); + end loop; + + Outdent; + Write_Line ("end withs"); + Outdent; + end if; + end; + end Write_Unit_Info; + +end Lib; |