diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 2 | ||||
| -rw-r--r-- | gcc/ada/makeutl.adb | 387 | ||||
| -rw-r--r-- | gcc/ada/makeutl.ads | 88 |
3 files changed, 477 insertions, 0 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ae718b0..a3e8394 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -91,6 +91,8 @@ (Gnatmake): Move sorting of linker options to function Makeutl.Linker_Options_Switches. + * makeutl.ads, makeutl.adb: New files. + * Makefile.in: Add makeutl.o to the object files for gnatmake * makeusg.adb: Add line for new switch -eL. diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb new file mode 100644 index 0000000..f5cd393 --- /dev/null +++ b/gcc/ada/makeutl.adb @@ -0,0 +1,387 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E U T L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Namet; use Namet; +with Prj; use Prj; +with Prj.Ext; +with Prj.Util; +with Snames; use Snames; +with Table; +with Types; use Types; + +package body Makeutl is + + 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_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; + + ---------------------------- + -- Is_External_Assignment -- + ---------------------------- + + function Is_External_Assignment (Argv : String) return Boolean is + Start : Positive := 3; + Finish : Natural := Argv'Last; + Equal_Pos : Natural; + + 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; + + ----------------------------- + -- Linker_Options_Switches -- + ----------------------------- + + function Linker_Options_Switches + (Project : Project_Id) + return String_List + is + + ---------------------------------- + -- Recursive_Add_Linker_Options -- + ---------------------------------- + + procedure Recursive_Add_Linker_Options (Proj : Project_Id); + + 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 := Projects.Table (Proj); + + if not Data.Seen then + Projects.Table (Proj).Seen := True; + Imported := Data.Imported_Projects; + + while Imported /= Empty_Project_List loop + Recursive_Add_Linker_Options + (Project_Lists.Table (Imported).Project); + Imported := 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); + Options := + Prj.Util.Value_Of + (Name => Name_Ada, + Attribute_Or_Array_Name => Name_Linker_Options, + In_Package => Linker_Package); + + -- 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; + + begin + Linker_Opts.Init; + + for Index in 1 .. Projects.Last loop + 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 Projects.Table (Proj).Dir_Path = null then + Projects.Table (Proj).Dir_Path := + new String' + (Get_Name_String (Projects.Table (Proj). Directory)); + end if; + + while Options /= Nil_String loop + Option := String_Elements.Table (Options).Value; + Options := String_Elements.Table (Options).Next; + Add_Linker_Option (Get_Name_String (Option)); + + -- Object files and -L switches specified with + -- relative paths and must be converted to + -- absolute paths. + + Test_If_Relative_Path + (Switch => + Linker_Options_Buffer (Last_Linker_Option), + Parent => Projects.Table (Proj).Dir_Path, + Including_L_Switch => True); + end loop; + end; + end loop; + + return Linker_Options_Buffer (1 .. Last_Linker_Option); + end Linker_Options_Switches; + + ----------- + -- Mains -- + ----------- + + package body Mains is + + package Names is new Table.Table + (Table_Component_Type => File_Name_Type, + 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; + end Add_Main; + + ------------ + -- Delete -- + ------------ + + procedure Delete is + begin + Names.Set_Last (0); + Reset; + end Delete; + + --------------- + -- 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)); + 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; + + end Mains; + + --------------------------- + -- Test_If_Relative_Path -- + --------------------------- + + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String_Access; + Including_L_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; + + else + 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; + +end Makeutl; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads new file mode 100644 index 0000000..3e82e0d --- /dev/null +++ b/gcc/ada/makeutl.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A K E U T L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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 COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Osint; +with Prj; use Prj; + +package Makeutl is + + type Fail_Proc is access procedure + (S1 : String; S2 : String := ""; S3 : String := ""); + Do_Fail : Fail_Proc := Osint.Fail'Access; + + + function Is_External_Assignment (Argv : String) return Boolean; + -- Verify that an external assignment switch is syntactically correct. + -- Correct forms are + -- -Xname=value + -- -X"name=other value" + -- Assumptions: 'First = 1, Argv (1 .. 2) = "-X" + -- When this function returns True, the external assignment has + -- been entered by a call to Prj.Ext.Add, so that in a project + -- file, External ("name") will return "value". + + -- Package Mains is used to store the mains specified on the command line + -- and to retrieve them when a project file is used, to verify that the + -- files exist and that they belong to a project file. + + function Linker_Options_Switches (Project : Project_Id) return String_List; + + package Mains is + + -- Mains are stored in a table. An index is used to retrieve the mains + -- from the table. + + procedure Add_Main (Name : String); + -- Add one main to the table + + procedure Delete; + -- Empty the table + + procedure Reset; + -- Reset the index to the beginning of the table + + function Next_Main return String; + -- Increase the index and return the next main. + -- If table is exhausted, return an empty string. + + function Number_Of_Mains return Natural; + -- Returns the number of mains added with Add_Main since the last call + -- to Delete. + + end Mains; + + procedure Test_If_Relative_Path + (Switch : in out String_Access; + Parent : String_Access; + Including_L_Switch : Boolean := True); + -- Test if Switch is a relative search path switch. + -- If it is, fail if Parent is null, otherwise prepend the path with + -- Parent. This subprogram is only called when using project files. + -- For gnatbind switches, Including_L_Switch is False, because the + -- argument of the -L switch is not a path. + +end Makeutl; |