diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/makeutl.adb')
-rw-r--r-- | gcc-4.4.3/gcc/ada/makeutl.adb | 758 |
1 files changed, 0 insertions, 758 deletions
diff --git a/gcc-4.4.3/gcc/ada/makeutl.adb b/gcc-4.4.3/gcc/ada/makeutl.adb deleted file mode 100644 index 3d0ee62ea..000000000 --- a/gcc-4.4.3/gcc/ada/makeutl.adb +++ /dev/null @@ -1,758 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M A K E U T L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2008, 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. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Debug; -with Osint; use Osint; -with Output; use Output; -with Prj.Ext; -with Prj.Util; -with Snames; use Snames; -with Table; - -with Ada.Command_Line; use Ada.Command_Line; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System.Case_Util; use System.Case_Util; -with System.HTable; - -package body Makeutl is - - type Mark_Key is record - File : File_Name_Type; - Index : Int; - end record; - -- Identify either a mono-unit source (when Index = 0) or a specific unit - -- (index = 1's origin index of unit) in a multi-unit source. - - -- There follow many global undocumented declarations, comments needed ??? - - Max_Mask_Num : constant := 2048; - - subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; - - function Hash (Key : Mark_Key) return Mark_Num; - - package Marks is new System.HTable.Simple_HTable - (Header_Num => Mark_Num, - Element => Boolean, - No_Element => False, - Key => Mark_Key, - Hash => Hash, - Equal => "="); - -- A hash table to keep tracks of the marked units - - type Linker_Options_Data is record - Project : Project_Id; - Options : String_List_Id; - end record; - - Linker_Option_Initial_Count : constant := 20; - - Linker_Options_Buffer : String_List_Access := - new String_List (1 .. Linker_Option_Initial_Count); - - Last_Linker_Option : Natural := 0; - - package Linker_Opts is new Table.Table ( - Table_Component_Type => Linker_Options_Data, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Make.Linker_Opts"); - - procedure Add_Linker_Option (Option : String); - - --------- - -- Add -- - --------- - - procedure Add - (Option : String_Access; - To : in out String_List_Access; - Last : in out Natural) - is - begin - if Last = To'Last then - declare - New_Options : constant String_List_Access := - new String_List (1 .. To'Last * 2); - begin - New_Options (To'Range) := To.all; - - -- Set all elements of the original options to null to avoid - -- deallocation of copies. - - To.all := (others => null); - - Free (To); - To := New_Options; - end; - end if; - - Last := Last + 1; - To (Last) := Option; - end Add; - - procedure Add - (Option : String; - To : in out String_List_Access; - Last : in out Natural) - is - begin - Add (Option => new String'(Option), To => To, Last => Last); - end Add; - - ----------------------- - -- Add_Linker_Option -- - ----------------------- - - procedure Add_Linker_Option (Option : String) is - begin - if Option'Length > 0 then - if Last_Linker_Option = Linker_Options_Buffer'Last then - declare - New_Buffer : constant String_List_Access := - new String_List - (1 .. Linker_Options_Buffer'Last + - Linker_Option_Initial_Count); - begin - New_Buffer (Linker_Options_Buffer'Range) := - Linker_Options_Buffer.all; - Linker_Options_Buffer.all := (others => null); - Free (Linker_Options_Buffer); - Linker_Options_Buffer := New_Buffer; - end; - end if; - - Last_Linker_Option := Last_Linker_Option + 1; - Linker_Options_Buffer (Last_Linker_Option) := new String'(Option); - end if; - end Add_Linker_Option; - - ----------------- - -- Create_Name -- - ----------------- - - function Create_Name (Name : String) return File_Name_Type is - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Name); - return Name_Find; - end Create_Name; - - function Create_Name (Name : String) return Name_Id is - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Name); - return Name_Find; - end Create_Name; - - function Create_Name (Name : String) return Path_Name_Type is - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Name); - return Name_Find; - end Create_Name; - - ---------------------- - -- Delete_All_Marks -- - ---------------------- - - procedure Delete_All_Marks is - begin - Marks.Reset; - end Delete_All_Marks; - - ---------------------------- - -- Executable_Prefix_Path -- - ---------------------------- - - function Executable_Prefix_Path return String is - Exec_Name : constant String := Command_Name; - - function Get_Install_Dir (S : String) return String; - -- S is the executable name preceded by the absolute or relative - -- path, e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory - -- where "bin" lies (in the example "C:\usr"). - -- If the executable is not in a "bin" directory, return "". - - --------------------- - -- Get_Install_Dir -- - --------------------- - - function Get_Install_Dir (S : String) return String is - Exec : String := S; - Path_Last : Integer := 0; - - begin - for J in reverse Exec'Range loop - if Exec (J) = Directory_Separator then - Path_Last := J - 1; - exit; - end if; - end loop; - - if Path_Last >= Exec'First + 2 then - To_Lower (Exec (Path_Last - 2 .. Path_Last)); - end if; - - if Path_Last < Exec'First + 2 - or else Exec (Path_Last - 2 .. Path_Last) /= "bin" - or else (Path_Last - 3 >= Exec'First - and then Exec (Path_Last - 3) /= Directory_Separator) - then - return ""; - end if; - - return Normalize_Pathname (Exec (Exec'First .. Path_Last - 4)); - end Get_Install_Dir; - - -- Beginning of Executable_Prefix_Path - - begin - -- First determine if a path prefix was placed in front of the - -- executable name. - - for J in reverse Exec_Name'Range loop - if Exec_Name (J) = Directory_Separator then - return Get_Install_Dir (Exec_Name); - end if; - end loop; - - -- If we get here, the user has typed the executable name with no - -- directory prefix. - - declare - Path : constant String_Access := Locate_Exec_On_Path (Exec_Name); - begin - if Path = null then - return ""; - else - return Get_Install_Dir (Path.all); - end if; - end; - end Executable_Prefix_Path; - - ---------- - -- Hash -- - ---------- - - function Hash (Key : Mark_Key) return Mark_Num is - begin - return Union_Id (Key.File) mod Max_Mask_Num; - end Hash; - - ------------ - -- Inform -- - ------------ - - procedure Inform (N : File_Name_Type; Msg : String) is - begin - Inform (Name_Id (N), Msg); - end Inform; - - procedure Inform (N : Name_Id := No_Name; Msg : String) is - begin - Osint.Write_Program_Name; - - Write_Str (": "); - - if N /= No_Name then - Write_Str (""""); - - declare - Name : constant String := Get_Name_String (N); - begin - if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then - Write_Str (File_Name (Name)); - else - Write_Str (Name); - end if; - end; - - Write_Str (""" "); - end if; - - Write_Str (Msg); - Write_Eol; - end Inform; - - ---------------------------- - -- Is_External_Assignment -- - ---------------------------- - - function Is_External_Assignment (Argv : String) return Boolean is - Start : Positive := 3; - Finish : Natural := Argv'Last; - Equal_Pos : Natural; - - pragma Assert (Argv'First = 1); - pragma Assert (Argv (1 .. 2) = "-X"); - - begin - if Argv'Last < 5 then - return False; - - elsif Argv (3) = '"' then - if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then - return False; - else - Start := 4; - Finish := Argv'Last - 1; - end if; - end if; - - Equal_Pos := Start; - - while Equal_Pos <= Finish and then Argv (Equal_Pos) /= '=' loop - Equal_Pos := Equal_Pos + 1; - end loop; - - if Equal_Pos = Start - or else Equal_Pos > Finish - then - return False; - else - Prj.Ext.Add - (External_Name => Argv (Start .. Equal_Pos - 1), - Value => Argv (Equal_Pos + 1 .. Finish)); - return True; - end if; - end Is_External_Assignment; - - --------------- - -- Is_Marked -- - --------------- - - function Is_Marked - (Source_File : File_Name_Type; - Index : Int := 0) return Boolean - is - begin - return Marks.Get (K => (File => Source_File, Index => Index)); - end Is_Marked; - - ----------------------------- - -- Linker_Options_Switches -- - ----------------------------- - - function Linker_Options_Switches - (Project : Project_Id; - In_Tree : Project_Tree_Ref) return String_List - is - procedure Recursive_Add_Linker_Options (Proj : Project_Id); - -- The recursive routine used to add linker options - - ---------------------------------- - -- Recursive_Add_Linker_Options -- - ---------------------------------- - - procedure Recursive_Add_Linker_Options (Proj : Project_Id) is - Data : Project_Data; - Linker_Package : Package_Id; - Options : Variable_Value; - Imported : Project_List; - - begin - if Proj /= No_Project then - Data := In_Tree.Projects.Table (Proj); - - if not Data.Seen then - In_Tree.Projects.Table (Proj).Seen := True; - Imported := Data.Imported_Projects; - - while Imported /= Empty_Project_List loop - Recursive_Add_Linker_Options - (In_Tree.Project_Lists.Table - (Imported).Project); - Imported := In_Tree.Project_Lists.Table - (Imported).Next; - end loop; - - if Proj /= Project then - Linker_Package := - Prj.Util.Value_Of - (Name => Name_Linker, - In_Packages => Data.Decl.Packages, - In_Tree => In_Tree); - Options := - Prj.Util.Value_Of - (Name => Name_Ada, - Index => 0, - Attribute_Or_Array_Name => Name_Linker_Options, - In_Package => Linker_Package, - In_Tree => In_Tree); - - -- If attribute is present, add the project with - -- the attribute to table Linker_Opts. - - if Options /= Nil_Variable_Value then - Linker_Opts.Increment_Last; - Linker_Opts.Table (Linker_Opts.Last) := - (Project => Proj, Options => Options.Values); - end if; - end if; - end if; - end if; - end Recursive_Add_Linker_Options; - - -- Start of processing for Linker_Options_Switches - - begin - Linker_Opts.Init; - - for Index in Project_Table.First .. - Project_Table.Last (In_Tree.Projects) - loop - In_Tree.Projects.Table (Index).Seen := False; - end loop; - - Recursive_Add_Linker_Options (Project); - - Last_Linker_Option := 0; - - for Index in reverse 1 .. Linker_Opts.Last loop - declare - Options : String_List_Id := Linker_Opts.Table (Index).Options; - Proj : constant Project_Id := - Linker_Opts.Table (Index).Project; - Option : Name_Id; - - begin - -- If Dir_Path has not been computed for this project, do it now - - if In_Tree.Projects.Table (Proj).Dir_Path = null then - In_Tree.Projects.Table (Proj).Dir_Path := - new String' - (Get_Name_String - (In_Tree.Projects.Table - (Proj).Directory.Name)); - end if; - - while Options /= Nil_String loop - Option := - In_Tree.String_Elements.Table (Options).Value; - Get_Name_String (Option); - - -- Do not consider empty linker options - - if Name_Len /= 0 then - Add_Linker_Option (Name_Buffer (1 .. Name_Len)); - - -- Object files and -L switches specified with relative - -- paths must be converted to absolute paths. - - Test_If_Relative_Path - (Switch => - Linker_Options_Buffer (Last_Linker_Option), - Parent => - In_Tree.Projects.Table (Proj).Dir_Path, - Including_L_Switch => True); - end if; - - Options := - In_Tree.String_Elements.Table (Options).Next; - end loop; - end; - end loop; - - return Linker_Options_Buffer (1 .. Last_Linker_Option); - end Linker_Options_Switches; - - ----------- - -- Mains -- - ----------- - - package body Mains is - - type File_And_Loc is record - File_Name : File_Name_Type; - Location : Source_Ptr := No_Location; - end record; - - package Names is new Table.Table - (Table_Component_Type => File_And_Loc, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Makeutl.Mains.Names"); - -- The table that stores the mains - - Current : Natural := 0; - -- The index of the last main retrieved from the table - - -------------- - -- Add_Main -- - -------------- - - procedure Add_Main (Name : String) is - begin - Name_Len := 0; - Add_Str_To_Name_Buffer (Name); - Names.Increment_Last; - Names.Table (Names.Last) := (Name_Find, No_Location); - end Add_Main; - - ------------ - -- Delete -- - ------------ - - procedure Delete is - begin - Names.Set_Last (0); - Mains.Reset; - end Delete; - - ------------------ - -- Get_Location -- - ------------------ - - function Get_Location return Source_Ptr is - begin - if Current in Names.First .. Names.Last then - return Names.Table (Current).Location; - else - return No_Location; - end if; - end Get_Location; - - --------------- - -- Next_Main -- - --------------- - - function Next_Main return String is - begin - if Current >= Names.Last then - return ""; - else - Current := Current + 1; - return Get_Name_String (Names.Table (Current).File_Name); - end if; - end Next_Main; - - --------------------- - -- Number_Of_Mains -- - --------------------- - - function Number_Of_Mains return Natural is - begin - return Names.Last; - end Number_Of_Mains; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - Current := 0; - end Reset; - - ------------------ - -- Set_Location -- - ------------------ - - procedure Set_Location (Location : Source_Ptr) is - begin - if Names.Last > 0 then - Names.Table (Names.Last).Location := Location; - end if; - end Set_Location; - - ----------------- - -- Update_Main -- - ----------------- - - procedure Update_Main (Name : String) is - begin - if Current in Names.First .. Names.Last then - Name_Len := 0; - Add_Str_To_Name_Buffer (Name); - Names.Table (Current).File_Name := Name_Find; - end if; - end Update_Main; - end Mains; - - ---------- - -- Mark -- - ---------- - - procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is - begin - Marks.Set (K => (File => Source_File, Index => Index), E => True); - end Mark; - - ----------------------- - -- Path_Or_File_Name -- - ----------------------- - - function Path_Or_File_Name (Path : Path_Name_Type) return String is - Path_Name : constant String := Get_Name_String (Path); - begin - if Debug.Debug_Flag_F then - return File_Name (Path_Name); - else - return Path_Name; - end if; - end Path_Or_File_Name; - - --------------------------- - -- Test_If_Relative_Path -- - --------------------------- - - procedure Test_If_Relative_Path - (Switch : in out String_Access; - Parent : String_Access; - Including_L_Switch : Boolean := True; - Including_Non_Switch : Boolean := True) - is - begin - if Switch /= null then - declare - Sw : String (1 .. Switch'Length); - Start : Positive; - - begin - Sw := Switch.all; - - if Sw (1) = '-' then - if Sw'Length >= 3 - and then (Sw (2) = 'A' - or else Sw (2) = 'I' - or else (Including_L_Switch and then Sw (2) = 'L')) - then - Start := 3; - - if Sw = "-I-" then - return; - end if; - - elsif Sw'Length >= 4 - and then (Sw (2 .. 3) = "aL" - or else Sw (2 .. 3) = "aO" - or else Sw (2 .. 3) = "aI") - then - Start := 4; - - else - return; - end if; - - -- Because relative path arguments to --RTS= may be relative - -- to the search directory prefix, those relative path - -- arguments are not converted. - - if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then - if Parent = null or else Parent'Length = 0 then - Do_Fail - ("relative search path switches (""", - Sw, - """) are not allowed"); - - else - Switch := - new String' - (Sw (1 .. Start - 1) & - Parent.all & - Directory_Separator & - Sw (Start .. Sw'Last)); - end if; - end if; - - elsif Including_Non_Switch then - if not Is_Absolute_Path (Sw) then - if Parent = null or else Parent'Length = 0 then - Do_Fail - ("relative paths (""", Sw, """) are not allowed"); - - else - Switch := - new String'(Parent.all & Directory_Separator & Sw); - end if; - end if; - end if; - end; - end if; - end Test_If_Relative_Path; - - ------------------- - -- Unit_Index_Of -- - ------------------- - - function Unit_Index_Of (ALI_File : File_Name_Type) return Int is - Start : Natural; - Finish : Natural; - Result : Int := 0; - - begin - Get_Name_String (ALI_File); - - -- First, find the last dot - - Finish := Name_Len; - - while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop - Finish := Finish - 1; - end loop; - - if Finish = 1 then - return 0; - end if; - - -- Now check that the dot is preceded by digits - - Start := Finish; - Finish := Finish - 1; - - while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop - Start := Start - 1; - end loop; - - -- If there are no digits, or if the digits are not preceded by - -- the character that precedes a unit index, this is not the ALI file - -- of a unit in a multi-unit source. - - if Start > Finish - or else Start = 1 - or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character - then - return 0; - end if; - - -- Build the index from the digit(s) - - while Start <= Finish loop - Result := Result * 10 + - Character'Pos (Name_Buffer (Start)) - Character'Pos ('0'); - Start := Start + 1; - end loop; - - return Result; - end Unit_Index_Of; - -end Makeutl; |