diff options
Diffstat (limited to 'gcc-4.3.1/gcc/ada/prj-makr.adb')
-rw-r--r-- | gcc-4.3.1/gcc/ada/prj-makr.adb | 1507 |
1 files changed, 1507 insertions, 0 deletions
diff --git a/gcc-4.3.1/gcc/ada/prj-makr.adb b/gcc-4.3.1/gcc/ada/prj-makr.adb new file mode 100644 index 000000000..336c676e7 --- /dev/null +++ b/gcc-4.3.1/gcc/ada/prj-makr.adb @@ -0,0 +1,1507 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . M A K R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2007, 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 Csets; +with Opt; +with Output; +with Osint; use Osint; +with Prj; use Prj; +with Prj.Com; +with Prj.Part; +with Prj.PP; +with Prj.Tree; use Prj.Tree; +with Prj.Util; use Prj.Util; +with Snames; use Snames; +with Table; use Table; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with System.Case_Util; use System.Case_Util; +with System.CRTL; +with System.Regexp; use System.Regexp; + +package body Prj.Makr is + + -- Packages of project files where unknown attributes are errors + + -- All the following need comments ??? All global variables and + -- subprograms must be fully commented. + + Naming_String : aliased String := "naming"; + + Gnatname_Packages : aliased String_List := (1 => Naming_String'Access); + + Packages_To_Check_By_Gnatname : constant String_List_Access := + Gnatname_Packages'Access; + + function Dup (Fd : File_Descriptor) return File_Descriptor; + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + + Gcc : constant String := "gcc"; + Gcc_Path : String_Access := null; + + Non_Empty_Node : constant Project_Node_Id := 1; + -- Used for the With_Clause of the naming project + + type Matched_Type is (True, False, Excluded); + + Naming_File_Suffix : constant String := "_naming"; + Source_List_File_Suffix : constant String := "_source_list.txt"; + + Output_FD : File_Descriptor; + -- To save the project file and its naming project file + + procedure Write_Eol; + -- Output an empty line + + procedure Write_A_Char (C : Character); + -- Write one character to Output_FD + + procedure Write_A_String (S : String); + -- Write a String to Output_FD + + package Processed_Directories is new Table.Table + (Table_Component_Type => String_Access, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Makr.Processed_Directories"); + + --------- + -- Dup -- + --------- + + function Dup (Fd : File_Descriptor) return File_Descriptor is + begin + return File_Descriptor (System.CRTL.dup (Integer (Fd))); + end Dup; + + ---------- + -- Dup2 -- + ---------- + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is + Fd : Integer; + pragma Warnings (Off, Fd); + begin + Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); + end Dup2; + + ---------- + -- Make -- + ---------- + + procedure Make + (File_Path : String; + Project_File : Boolean; + Directories : Argument_List; + Name_Patterns : Argument_List; + Excluded_Patterns : Argument_List; + Foreign_Patterns : Argument_List; + Preproc_Switches : Argument_List; + Very_Verbose : Boolean) + is + Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; + + Path_Name : String (1 .. File_Path'Length + + Project_File_Extension'Length); + Path_Last : Natural := File_Path'Length; + + Directory_Last : Natural := 0; + + Output_Name : String (Path_Name'Range); + Output_Name_Last : Natural; + Output_Name_Id : Name_Id; + + Project_Node : Project_Node_Id := Empty_Node; + Project_Declaration : Project_Node_Id := Empty_Node; + Source_Dirs_List : Project_Node_Id := Empty_Node; + Current_Source_Dir : Project_Node_Id := Empty_Node; + + Project_Naming_Node : Project_Node_Id := Empty_Node; + Project_Naming_Decl : Project_Node_Id := Empty_Node; + Naming_Package : Project_Node_Id := Empty_Node; + Naming_Package_Comments : Project_Node_Id := Empty_Node; + + Source_Files_Comments : Project_Node_Id := Empty_Node; + Source_Dirs_Comments : Project_Node_Id := Empty_Node; + Source_List_File_Comments : Project_Node_Id := Empty_Node; + + Project_Naming_File_Name : String (1 .. Output_Name'Length + + Naming_File_Suffix'Length); + + Project_Naming_Last : Natural; + Project_Naming_Id : Name_Id := No_Name; + + Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp; + Regular_Expressions : array (Name_Patterns'Range) of Regexp; + Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp; + + Source_List_Path : String (1 .. Output_Name'Length + + Source_List_File_Suffix'Length); + Source_List_Last : Natural; + + Source_List_FD : File_Descriptor; + + Args : Argument_List (1 .. Preproc_Switches'Length + 6); + + type SFN_Pragma is record + Unit : Name_Id; + File : Name_Id; + Index : Int := 0; + Spec : Boolean; + end record; + + package SFN_Pragmas is new Table.Table + (Table_Component_Type => SFN_Pragma, + Table_Index_Type => Natural, + Table_Low_Bound => 0, + Table_Initial => 50, + Table_Increment => 100, + Table_Name => "Prj.Makr.SFN_Pragmas"); + + procedure Process_Directory (Dir_Name : String; Recursively : Boolean); + -- Look for Ada and foreign sources in a directory, according to the + -- patterns. When Recursively is True, after looking for sources in + -- Dir_Name, look also in its subdirectories, if any. + + ----------------------- + -- Process_Directory -- + ----------------------- + + procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is + Matched : Matched_Type := False; + Str : String (1 .. 2_000); + Canon : String (1 .. 2_000); + Last : Natural; + Dir : Dir_Type; + Process : Boolean := True; + + Temp_File_Name : String_Access := null; + Save_Last_Pragma_Index : Natural := 0; + File_Name_Id : Name_Id := No_Name; + SFN_Prag : SFN_Pragma; + + begin + -- Avoid processing the same directory more than once + + for Index in 1 .. Processed_Directories.Last loop + if Processed_Directories.Table (Index).all = Dir_Name then + Process := False; + exit; + end if; + end loop; + + if Process then + if Opt.Verbose_Mode then + Output.Write_Str ("Processing directory """); + Output.Write_Str (Dir_Name); + Output.Write_Line (""""); + end if; + + Processed_Directories. Increment_Last; + Processed_Directories.Table (Processed_Directories.Last) := + new String'(Dir_Name); + + -- Get the source file names from the directory. Fails if the + -- directory does not exist. + + begin + Open (Dir, Dir_Name); + exception + when Directory_Error => + Prj.Com.Fail ("cannot open directory """, Dir_Name, """"); + end; + + -- Process each regular file in the directory + + File_Loop : loop + Read (Dir, Str, Last); + exit File_Loop when Last = 0; + + -- Copy the file name and put it in canonical case to match + -- against the patterns that have themselves already been put + -- in canonical case. + + Canon (1 .. Last) := Str (1 .. Last); + Canonical_Case_File_Name (Canon (1 .. Last)); + + if Is_Regular_File + (Dir_Name & Directory_Separator & Str (1 .. Last)) + then + Matched := True; + + Name_Len := Last; + Name_Buffer (1 .. Name_Len) := Str (1 .. Last); + File_Name_Id := Name_Find; + + -- First, check if the file name matches at least one of + -- the excluded expressions; + + for Index in Excluded_Expressions'Range loop + if + Match (Canon (1 .. Last), Excluded_Expressions (Index)) + then + Matched := Excluded; + exit; + end if; + end loop; + + -- If it does not match any of the excluded expressions, + -- check if the file name matches at least one of the + -- regular expressions. + + if Matched = True then + Matched := False; + + for Index in Regular_Expressions'Range loop + if + Match + (Canon (1 .. Last), Regular_Expressions (Index)) + then + Matched := True; + exit; + end if; + end loop; + end if; + + if Very_Verbose + or else (Matched = True and then Opt.Verbose_Mode) + then + Output.Write_Str (" Checking """); + Output.Write_Str (Str (1 .. Last)); + Output.Write_Line (""": "); + end if; + + -- If the file name matches one of the regular expressions, + -- parse it to get its unit name. + + if Matched = True then + declare + FD : File_Descriptor; + Success : Boolean; + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor; + + begin + -- If we don't have the path of the compiler yet, + -- get it now. The compiler name may have a prefix, + -- so we get the potentially prefixed name. + + if Gcc_Path = null then + declare + Prefix_Gcc : String_Access := + Program_Name (Gcc); + begin + Gcc_Path := + Locate_Exec_On_Path (Prefix_Gcc.all); + Free (Prefix_Gcc); + end; + + if Gcc_Path = null then + Prj.Com.Fail ("could not locate " & Gcc); + end if; + end if; + + -- If we don't have yet the file name of the + -- temporary file, get it now. + + if Temp_File_Name = null then + Create_Temp_File (FD, Temp_File_Name); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + Close (FD); + Delete_File (Temp_File_Name.all, Success); + end if; + + Args (Args'Last) := new String' + (Dir_Name & + Directory_Separator & + Str (1 .. Last)); + + -- Create the temporary file + + FD := Create_Output_Text_File + (Name => Temp_File_Name.all); + + if FD = Invalid_FD then + Prj.Com.Fail + ("could not create temporary file"); + end if; + + -- Save the standard output and error + + Saved_Output := Dup (Standout); + Saved_Error := Dup (Standerr); + + -- Set standard output and error to the temporary file + + Dup2 (FD, Standout); + Dup2 (FD, Standerr); + + -- And spawn the compiler + + Spawn (Gcc_Path.all, Args, Success); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); + + -- Close the temporary file + + Close (FD); + + -- And close the saved standard output and error to + -- avoid too many file descriptors. + + Close (Saved_Output); + Close (Saved_Error); + + -- Now that standard output is restored, check if + -- the compiler ran correctly. + + -- Read the lines of the temporary file: + -- they should contain the kind and name of the unit. + + declare + File : Text_File; + Text_Line : String (1 .. 1_000); + Text_Last : Natural; + + begin + Open (File, Temp_File_Name.all); + + if not Is_Valid (File) then + Prj.Com.Fail + ("could not read temporary file"); + end if; + + Save_Last_Pragma_Index := SFN_Pragmas.Last; + + if End_Of_File (File) then + if Opt.Verbose_Mode then + if not Success then + Output.Write_Str (" (process died) "); + end if; + end if; + + else + Line_Loop : while not End_Of_File (File) loop + Get_Line (File, Text_Line, Text_Last); + + -- Find the first closing parenthesis + + Char_Loop : for J in 1 .. Text_Last loop + if Text_Line (J) = ')' then + if J >= 13 and then + Text_Line (1 .. 4) = "Unit" + then + -- Add entry to SFN_Pragmas table + + Name_Len := J - 12; + Name_Buffer (1 .. Name_Len) := + Text_Line (6 .. J - 7); + SFN_Prag := + (Unit => Name_Find, + File => File_Name_Id, + Index => 0, + Spec => Text_Line (J - 5 .. J) = + "(spec)"); + + SFN_Pragmas.Increment_Last; + SFN_Pragmas.Table + (SFN_Pragmas.Last) := SFN_Prag; + end if; + exit Char_Loop; + end if; + end loop Char_Loop; + end loop Line_Loop; + end if; + + if Save_Last_Pragma_Index = SFN_Pragmas.Last then + if Opt.Verbose_Mode then + Output.Write_Line (" not a unit"); + end if; + + else + if SFN_Pragmas.Last > + Save_Last_Pragma_Index + 1 + then + for Index in Save_Last_Pragma_Index + 1 .. + SFN_Pragmas.Last + loop + SFN_Pragmas.Table (Index).Index := + Int (Index - Save_Last_Pragma_Index); + end loop; + end if; + + for Index in Save_Last_Pragma_Index + 1 .. + SFN_Pragmas.Last + loop + SFN_Prag := SFN_Pragmas.Table (Index); + + if Opt.Verbose_Mode then + if SFN_Prag.Spec then + Output.Write_Str (" spec of "); + + else + Output.Write_Str (" body of "); + end if; + + Output.Write_Line + (Get_Name_String (SFN_Prag.Unit)); + end if; + + if Project_File then + + -- Add the corresponding attribute in the + -- Naming package of the naming project. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Declarative_Item, + In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Attribute_Declaration, + In_Tree => Tree); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single, + In_Tree => Tree); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single, + In_Tree => Tree); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single, + In_Tree => Tree); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package, Tree), + In_Tree => Tree); + Set_First_Declarative_Item_Of + (Naming_Package, + To => Decl_Item, + In_Tree => Tree); + Set_Current_Item_Node + (Decl_Item, + To => Attribute, + In_Tree => Tree); + + -- Is it a spec or a body? + + if SFN_Prag.Spec then + Set_Name_Of + (Attribute, Tree, + To => Name_Spec); + else + Set_Name_Of + (Attribute, Tree, + To => Name_Body); + end if; + + -- Get the name of the unit + + Get_Name_String (SFN_Prag.Unit); + To_Lower (Name_Buffer (1 .. Name_Len)); + Set_Associative_Array_Index_Of + (Attribute, Tree, To => Name_Find); + + Set_Expression_Of + (Attribute, Tree, To => Expression); + Set_First_Term + (Expression, Tree, To => Term); + Set_Current_Term + (Term, Tree, To => Value); + + -- And set the name of the file + + Set_String_Value_Of + (Value, Tree, To => File_Name_Id); + Set_Source_Index_Of + (Value, Tree, To => SFN_Prag.Index); + end; + end if; + end loop; + + if Project_File then + -- Add source file name to source list + -- file. + + Last := Last + 1; + Str (Last) := ASCII.LF; + + if Write (Source_List_FD, + Str (1)'Address, + Last) /= Last + then + Prj.Com.Fail ("disk full"); + end if; + end if; + end if; + + Close (File); + + Delete_File (Temp_File_Name.all, Success); + end; + end; + + -- File name matches none of the regular expressions + + else + -- If file is not excluded, see if this is foreign source + + if Matched /= Excluded then + for Index in Foreign_Expressions'Range loop + if Match (Canon (1 .. Last), + Foreign_Expressions (Index)) + then + Matched := True; + exit; + end if; + end loop; + end if; + + if Very_Verbose then + case Matched is + when False => + Output.Write_Line ("no match"); + + when Excluded => + Output.Write_Line ("excluded"); + + when True => + Output.Write_Line ("foreign source"); + end case; + end if; + + if Project_File and Matched = True then + + -- Add source file name to source list file + + Last := Last + 1; + Str (Last) := ASCII.LF; + + if Write (Source_List_FD, + Str (1)'Address, + Last) /= Last + then + Prj.Com.Fail ("disk full"); + end if; + end if; + end if; + end if; + end loop File_Loop; + + Close (Dir); + end if; + + -- If Recursively is True, call itself for each subdirectory. + -- We do that, even when this directory has already been processed, + -- because all of its subdirectories may not have been processed. + + if Recursively then + Open (Dir, Dir_Name); + + loop + Read (Dir, Str, Last); + exit when Last = 0; + + -- Do not call itself for "." or ".." + + if Is_Directory + (Dir_Name & Directory_Separator & Str (1 .. Last)) + and then Str (1 .. Last) /= "." + and then Str (1 .. Last) /= ".." + then + Process_Directory + (Dir_Name & Directory_Separator & Str (1 .. Last), + Recursively => True); + end if; + end loop; + + Close (Dir); + end if; + end Process_Directory; + + -- Start of processing for Make + + begin + -- Do some needed initializations + + Csets.Initialize; + Namet.Initialize; + Snames.Initialize; + Prj.Initialize (No_Project_Tree); + Prj.Tree.Initialize (Tree); + + SFN_Pragmas.Set_Last (0); + + Processed_Directories.Set_Last (0); + + -- Initialize the compiler switches + + Args (1) := new String'("-c"); + Args (2) := new String'("-gnats"); + Args (3) := new String'("-gnatu"); + Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches; + Args (4 + Preproc_Switches'Length) := new String'("-x"); + Args (5 + Preproc_Switches'Length) := new String'("ada"); + + -- Get the path and file names + + if File_Names_Case_Sensitive then + Path_Name (1 .. Path_Last) := File_Path; + else + Path_Name (1 .. Path_Last) := To_Lower (File_Path); + end if; + + Path_Name (Path_Last + 1 .. Path_Name'Last) := + Project_File_Extension; + + -- Get the end of directory information, if any + + for Index in reverse 1 .. Path_Last loop + if Path_Name (Index) = Directory_Separator then + Directory_Last := Index; + exit; + end if; + end loop; + + if Project_File then + if Path_Last < Project_File_Extension'Length + 1 + or else Path_Name + (Path_Last - Project_File_Extension'Length + 1 .. Path_Last) + /= Project_File_Extension + then + Path_Last := Path_Name'Last; + end if; + + Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last)); + Output_Name_Last := Path_Last - Project_File_Extension'Length; + + -- If there is already a project file with the specified name, parse + -- it to get the components that are not automatically generated. + + if Is_Regular_File (Output_Name (1 .. Path_Last)) then + if Opt.Verbose_Mode then + Output.Write_Str ("Parsing already existing project file """); + Output.Write_Str (Output_Name (1 .. Output_Name_Last)); + Output.Write_Line (""""); + end if; + + Part.Parse + (In_Tree => Tree, + Project => Project_Node, + Project_File_Name => Output_Name (1 .. Output_Name_Last), + Always_Errout_Finalize => False, + Store_Comments => True, + Current_Directory => Get_Current_Dir, + Packages_To_Check => Packages_To_Check_By_Gnatname); + + -- Fail if parsing was not successful + + if Project_Node = Empty_Node then + Fail ("parsing of existing project file failed"); + + else + -- If parsing was successful, remove the components that are + -- automatically generated, if any, so that they will be + -- unconditionally added later. + + -- Remove the with clause for the naming project file + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node, Tree); + Previous : Project_Node_Id := Empty_Node; + + begin + while With_Clause /= Empty_Node loop + if Prj.Tree.Name_Of (With_Clause, Tree) = + Project_Naming_Id + then + if Previous = Empty_Node then + Set_First_With_Clause_Of + (Project_Node, Tree, + To => Next_With_Clause_Of (With_Clause, Tree)); + else + Set_Next_With_Clause_Of + (Previous, Tree, + To => Next_With_Clause_Of (With_Clause, Tree)); + end if; + + exit; + end if; + + Previous := With_Clause; + With_Clause := Next_With_Clause_Of (With_Clause, Tree); + end loop; + end; + + -- Remove attribute declarations of Source_Files, + -- Source_List_File, Source_Dirs, and the declaration of + -- package Naming, if they exist, but preserve the comments + -- attached to these nodes. + + declare + Declaration : Project_Node_Id := + First_Declarative_Item_Of + (Project_Declaration_Of + (Project_Node, Tree), + Tree); + Previous : Project_Node_Id := Empty_Node; + Current_Node : Project_Node_Id := Empty_Node; + + Name : Name_Id; + Kind_Of_Node : Project_Node_Kind; + Comments : Project_Node_Id; + + begin + while Declaration /= Empty_Node loop + Current_Node := Current_Item_Node (Declaration, Tree); + + Kind_Of_Node := Kind_Of (Current_Node, Tree); + + if Kind_Of_Node = N_Attribute_Declaration or else + Kind_Of_Node = N_Package_Declaration + then + Name := Prj.Tree.Name_Of (Current_Node, Tree); + + if Name = Name_Source_Files or else + Name = Name_Source_List_File or else + Name = Name_Source_Dirs or else + Name = Name_Naming + then + Comments := + Tree.Project_Nodes.Table (Current_Node).Comments; + + if Name = Name_Source_Files then + Source_Files_Comments := Comments; + + elsif Name = Name_Source_List_File then + Source_List_File_Comments := Comments; + + elsif Name = Name_Source_Dirs then + Source_Dirs_Comments := Comments; + + elsif Name = Name_Naming then + Naming_Package_Comments := Comments; + end if; + + if Previous = Empty_Node then + Set_First_Declarative_Item_Of + (Project_Declaration_Of (Project_Node, Tree), + Tree, + To => Next_Declarative_Item + (Declaration, Tree)); + + else + Set_Next_Declarative_Item + (Previous, Tree, + To => Next_Declarative_Item + (Declaration, Tree)); + end if; + + else + Previous := Declaration; + end if; + end if; + + Declaration := Next_Declarative_Item (Declaration, Tree); + end loop; + end; + end if; + end if; + + if Directory_Last /= 0 then + Output_Name (1 .. Output_Name_Last - Directory_Last) := + Output_Name (Directory_Last + 1 .. Output_Name_Last); + Output_Name_Last := Output_Name_Last - Directory_Last; + end if; + + -- Get the project name id + + Name_Len := Output_Name_Last; + Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len); + Output_Name_Id := Name_Find; + + -- Create the project naming file name + + Project_Naming_Last := Output_Name_Last; + Project_Naming_File_Name (1 .. Project_Naming_Last) := + Output_Name (1 .. Project_Naming_Last); + Project_Naming_File_Name + (Project_Naming_Last + 1 .. + Project_Naming_Last + Naming_File_Suffix'Length) := + Naming_File_Suffix; + Project_Naming_Last := + Project_Naming_Last + Naming_File_Suffix'Length; + + -- Get the project naming id + + Name_Len := Project_Naming_Last; + Name_Buffer (1 .. Name_Len) := + Project_Naming_File_Name (1 .. Name_Len); + Project_Naming_Id := Name_Find; + + Project_Naming_File_Name + (Project_Naming_Last + 1 .. + Project_Naming_Last + Project_File_Extension'Length) := + Project_File_Extension; + Project_Naming_Last := + Project_Naming_Last + Project_File_Extension'Length; + + -- Create the source list file name + + Source_List_Last := Output_Name_Last; + Source_List_Path (1 .. Source_List_Last) := + Output_Name (1 .. Source_List_Last); + Source_List_Path + (Source_List_Last + 1 .. + Source_List_Last + Source_List_File_Suffix'Length) := + Source_List_File_Suffix; + Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length; + + -- Add the project file extension to the project name + + Output_Name + (Output_Name_Last + 1 .. + Output_Name_Last + Project_File_Extension'Length) := + Project_File_Extension; + Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; + end if; + + -- Change the current directory to the directory of the project file, + -- if any directory information is specified. + + if Directory_Last /= 0 then + begin + Change_Dir (Path_Name (1 .. Directory_Last)); + exception + when Directory_Error => + Prj.Com.Fail + ("unknown directory """, + Path_Name (1 .. Directory_Last), + """"); + end; + end if; + + if Project_File then + + -- Delete the source list file, if it already exists + + declare + Discard : Boolean; + pragma Warnings (Off, Discard); + begin + Delete_File + (Source_List_Path (1 .. Source_List_Last), + Success => Discard); + end; + + -- And create a new source list file. + -- Fail if file cannot be created. + + Source_List_FD := Create_New_File + (Name => Source_List_Path (1 .. Source_List_Last), + Fmode => Text); + + if Source_List_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create file """, + Source_List_Path (1 .. Source_List_Last), + """"); + end if; + end if; + + -- Compile the regular expressions. Fails immediately if any of + -- the specified strings is in error. + + for Index in Excluded_Expressions'Range loop + if Very_Verbose then + Output.Write_Str ("Excluded pattern: """); + Output.Write_Str (Excluded_Patterns (Index).all); + Output.Write_Line (""""); + end if; + + begin + Excluded_Expressions (Index) := + Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); + exception + when Error_In_Regexp => + Prj.Com.Fail + ("invalid regular expression """, + Excluded_Patterns (Index).all, + """"); + end; + end loop; + + for Index in Foreign_Expressions'Range loop + if Very_Verbose then + Output.Write_Str ("Foreign pattern: """); + Output.Write_Str (Foreign_Patterns (Index).all); + Output.Write_Line (""""); + end if; + + begin + Foreign_Expressions (Index) := + Compile (Pattern => Foreign_Patterns (Index).all, Glob => True); + exception + when Error_In_Regexp => + Prj.Com.Fail + ("invalid regular expression """, + Foreign_Patterns (Index).all, + """"); + end; + end loop; + + for Index in Regular_Expressions'Range loop + if Very_Verbose then + Output.Write_Str ("Pattern: """); + Output.Write_Str (Name_Patterns (Index).all); + Output.Write_Line (""""); + end if; + + begin + Regular_Expressions (Index) := + Compile (Pattern => Name_Patterns (Index).all, Glob => True); + + exception + when Error_In_Regexp => + Prj.Com.Fail + ("invalid regular expression """, + Name_Patterns (Index).all, + """"); + end; + end loop; + + if Project_File then + if Opt.Verbose_Mode then + Output.Write_Str ("Naming project file name is """); + Output.Write_Str + (Project_Naming_File_Name (1 .. Project_Naming_Last)); + Output.Write_Line (""""); + end if; + + -- If there were no already existing project file, or if the parsing + -- was unsuccessful, create an empty project node with the correct + -- name and its project declaration node. + + if Project_Node = Empty_Node then + Project_Node := + Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); + Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); + Set_Project_Declaration_Of + (Project_Node, Tree, + To => Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => Tree)); + + end if; + + -- Create the naming project node, and add an attribute declaration + -- for Source_Files as an empty list, to indicate there are no + -- sources in the naming project. + + Project_Naming_Node := + Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); + Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); + Project_Naming_Decl := + Default_Project_Node + (Of_Kind => N_Project_Declaration, In_Tree => Tree); + Set_Project_Declaration_Of + (Project_Naming_Node, Tree, Project_Naming_Decl); + Naming_Package := + Default_Project_Node + (Of_Kind => N_Package_Declaration, In_Tree => Tree); + Set_Name_Of (Naming_Package, Tree, To => Name_Naming); + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => List); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => List); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => List); + + Empty_List : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => Tree); + + begin + Set_First_Declarative_Item_Of + (Project_Naming_Decl, Tree, To => Decl_Item); + Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_Files); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Empty_List); + end; + + -- Add a with clause on the naming project in the main project, if + -- there is not already one. + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node, Tree); + + begin + while With_Clause /= Empty_Node loop + exit when + Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; + With_Clause := Next_With_Clause_Of (With_Clause, Tree); + end loop; + + if With_Clause = Empty_Node then + With_Clause := Default_Project_Node + (Of_Kind => N_With_Clause, In_Tree => Tree); + Set_Next_With_Clause_Of + (With_Clause, Tree, + To => First_With_Clause_Of (Project_Node, Tree)); + Set_First_With_Clause_Of + (Project_Node, Tree, To => With_Clause); + Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); + + -- We set the project node to something different than + -- Empty_Node, so that Prj.PP does not generate a limited + -- with clause. + + Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); + + Name_Len := Project_Naming_Last; + Name_Buffer (1 .. Name_Len) := + Project_Naming_File_Name (1 .. Project_Naming_Last); + Set_String_Value_Of (With_Clause, Tree, To => Name_Find); + end if; + end; + + Project_Declaration := Project_Declaration_Of (Project_Node, Tree); + + -- Add a renaming declaration for package Naming in the main project + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); + + Naming : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Package_Declaration, + In_Tree => Tree); + + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Naming); + Set_Name_Of (Naming, Tree, To => Name_Naming); + Set_Project_Of_Renamed_Package_Of + (Naming, Tree, To => Project_Naming_Node); + + -- Attach the comments, if any, that were saved for package + -- Naming. + + Tree.Project_Nodes.Table (Naming).Comments := + Naming_Package_Comments; + end; + + -- Add an attribute declaration for Source_Dirs, initialized as an + -- empty list. Directories will be added as they are read from the + -- directory list file. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => List); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => List); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, In_Tree => Tree, + And_Expr_Kind => List); + + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Source_Dirs_List := + Default_Project_Node + (Of_Kind => N_Literal_String_List, + In_Tree => Tree, + And_Expr_Kind => List); + Set_Current_Term (Term, Tree, To => Source_Dirs_List); + + -- Attach the comments, if any, that were saved for attribute + -- Source_Dirs. + + Tree.Project_Nodes.Table (Attribute).Comments := + Source_Dirs_Comments; + end; + + -- Add an attribute declaration for Source_List_File with the + -- source list file name that will be created. + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Declarative_Item, + In_Tree => Tree); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + In_Tree => Tree, + And_Expr_Kind => Single); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => Tree, + And_Expr_Kind => Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, Tree, + To => First_Declarative_Item_Of (Project_Declaration, Tree)); + Set_First_Declarative_Item_Of + (Project_Declaration, Tree, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); + Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); + Set_Expression_Of (Attribute, Tree, To => Expression); + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Value); + Name_Len := Source_List_Last; + Name_Buffer (1 .. Name_Len) := + Source_List_Path (1 .. Source_List_Last); + Set_String_Value_Of (Value, Tree, To => Name_Find); + + -- If there was no comments for attribute Source_List_File, put + -- those for Source_Files, if they exist. + + if Source_List_File_Comments /= Empty_Node then + Tree.Project_Nodes.Table (Attribute).Comments := + Source_List_File_Comments; + else + Tree.Project_Nodes.Table (Attribute).Comments := + Source_Files_Comments; + end if; + end; + end if; + + -- Process each directory + + for Index in Directories'Range loop + + declare + Dir_Name : constant String := Directories (Index).all; + Last : Natural := Dir_Name'Last; + Recursively : Boolean := False; + + begin + if Dir_Name'Length >= 4 + and then (Dir_Name (Last - 2 .. Last) = "/**") + then + Last := Last - 3; + Recursively := True; + end if; + + if Project_File then + + -- Add the directory in the list for attribute Source_Dirs + + declare + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + In_Tree => Tree, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + In_Tree => Tree, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + In_Tree => Tree, + And_Expr_Kind => Single); + + begin + if Current_Source_Dir = Empty_Node then + Set_First_Expression_In_List + (Source_Dirs_List, Tree, To => Expression); + else + Set_Next_Expression_In_List + (Current_Source_Dir, Tree, To => Expression); + end if; + + Current_Source_Dir := Expression; + Set_First_Term (Expression, Tree, To => Term); + Set_Current_Term (Term, Tree, To => Value); + Name_Len := Dir_Name'Length; + Name_Buffer (1 .. Name_Len) := Dir_Name; + Set_String_Value_Of (Value, Tree, To => Name_Find); + end; + end if; + + Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); + end; + + end loop; + + if Project_File then + Close (Source_List_FD); + end if; + + declare + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + -- Delete the file if it already exists + + Delete_File + (Path_Name (Directory_Last + 1 .. Path_Last), + Success => Discard); + + -- Create a new one + + if Opt.Verbose_Mode then + Output.Write_Str ("Creating new file """); + Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last)); + Output.Write_Line (""""); + end if; + + Output_FD := Create_New_File + (Path_Name (Directory_Last + 1 .. Path_Last), + Fmode => Text); + + -- Fails if project file cannot be created + + if Output_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create new """, Path_Name (1 .. Path_Last), """"); + end if; + + if Project_File then + + -- Output the project file + + Prj.PP.Pretty_Print + (Project_Node, Tree, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access, + Backward_Compatibility => False); + Close (Output_FD); + + -- Delete the naming project file if it already exists + + Delete_File + (Project_Naming_File_Name (1 .. Project_Naming_Last), + Success => Discard); + + -- Create a new one + + if Opt.Verbose_Mode then + Output.Write_Str ("Creating new naming project file """); + Output.Write_Str (Project_Naming_File_Name + (1 .. Project_Naming_Last)); + Output.Write_Line (""""); + end if; + + Output_FD := Create_New_File + (Project_Naming_File_Name (1 .. Project_Naming_Last), + Fmode => Text); + + -- Fails if naming project file cannot be created + + if Output_FD = Invalid_FD then + Prj.Com.Fail + ("cannot create new """, + Project_Naming_File_Name (1 .. Project_Naming_Last), + """"); + end if; + + -- Output the naming project file + + Prj.PP.Pretty_Print + (Project_Naming_Node, Tree, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access, + Backward_Compatibility => False); + Close (Output_FD); + + else + -- Write to the output file each entry in the SFN_Pragmas table + -- as an pragma Source_File_Name. + + for Index in 1 .. SFN_Pragmas.Last loop + Write_A_String ("pragma Source_File_Name"); + Write_Eol; + Write_A_String (" ("); + Write_A_String + (Get_Name_String (SFN_Pragmas.Table (Index).Unit)); + Write_A_String (","); + Write_Eol; + + if SFN_Pragmas.Table (Index).Spec then + Write_A_String (" Spec_File_Name => """); + + else + Write_A_String (" Body_File_Name => """); + end if; + + Write_A_String + (Get_Name_String (SFN_Pragmas.Table (Index).File)); + + Write_A_String (""""); + + if SFN_Pragmas.Table (Index).Index /= 0 then + Write_A_String (", Index =>"); + Write_A_String (SFN_Pragmas.Table (Index).Index'Img); + end if; + + Write_A_String (");"); + Write_Eol; + end loop; + + Close (Output_FD); + end if; + end; + + end Make; + + ---------------- + -- Write_Char -- + ---------------- + procedure Write_A_Char (C : Character) is + begin + Write_A_String ((1 => C)); + end Write_A_Char; + + --------------- + -- Write_Eol -- + --------------- + + procedure Write_Eol is + begin + Write_A_String ((1 => ASCII.LF)); + end Write_Eol; + + -------------------- + -- Write_A_String -- + -------------------- + + procedure Write_A_String (S : String) is + Str : String (1 .. S'Length); + + begin + if S'Length > 0 then + Str := S; + + if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then + Prj.Com.Fail ("disk full"); + end if; + end if; + end Write_A_String; + +end Prj.Makr; |