diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/prj-makr.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/prj-makr.adb | 1533 |
1 files changed, 0 insertions, 1533 deletions
diff --git a/gcc-4.7/gcc/ada/prj-makr.adb b/gcc-4.7/gcc/ada/prj-makr.adb deleted file mode 100644 index 29fe7b48c..000000000 --- a/gcc-4.7/gcc/ada/prj-makr.adb +++ /dev/null @@ -1,1533 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . M A K R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2011, 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.Env; -with Prj.Part; -with Prj.PP; -with Prj.Tree; use Prj.Tree; -with Prj.Util; use Prj.Util; -with Sdefault; -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.HTable; - -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. - - Very_Verbose : Boolean := False; - -- Set in call to Initialize to indicate very verbose output - - Project_File : Boolean := False; - -- True when gnatname is creating/modifying a project file. False when - -- gnatname is creating a configuration pragmas file. - - Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data; - -- The project tree where the project file is parsed - - Root_Environment : Prj.Tree.Environment; - - Args : Argument_List_Access; - -- The list of arguments for calls to the compiler to get the unit names - -- and kinds (spec or body) in the Ada sources. - - Path_Name : String_Access; - - Path_Last : Natural; - - Directory_Last : Natural := 0; - - Output_Name : String_Access; - Output_Name_Last : Natural; - Output_Name_Id : Name_Id; - - Project_Naming_File_Name : String_Access; - -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length); - - Project_Naming_Last : Natural; - Project_Naming_Id : Name_Id := No_Name; - - Source_List_Path : String_Access; - -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length); - Source_List_Last : Natural; - - Source_List_FD : File_Descriptor; - - Project_Node : Project_Node_Id := Empty_Node; - Project_Declaration : Project_Node_Id := Empty_Node; - Source_Dirs_List : 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; - - 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"); - -- The list of already processed directories for each section, to avoid - -- processing several times the same directory in the same section. - - package Source_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.Source_Directories"); - -- The complete list of directories to be put in attribute Source_Dirs in - -- the project file. - - type Source is record - File_Name : Name_Id; - Unit_Name : Name_Id; - Index : Int := 0; - Spec : Boolean; - end record; - - package Sources is new Table.Table - (Table_Component_Type => Source, - Table_Index_Type => Natural, - Table_Low_Bound => 0, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Prj.Makr.Sources"); - -- The list of Ada sources found, with their unit name and kind, to be put - -- in the source attribute and package Naming of the project file, or in - -- the pragmas Source_File_Name in the configuration pragmas file. - - package Source_Files is new System.HTable.Simple_HTable - (Header_Num => Prj.Header_Num, - Element => Boolean, - No_Element => False, - Key => Name_Id, - Hash => Prj.Hash, - Equal => "="); - -- Hash table to keep track of source file names, to avoid putting several - -- times the same file name in case of multi-unit files. - - --------- - -- 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; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - Discard : Boolean; - pragma Warnings (Off, Discard); - - Current_Source_Dir : Project_Node_Id := Empty_Node; - - begin - if Project_File then - -- 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 No (Project_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; - - end if; - - -- 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 - - -- 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; - - 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; - - -- Create the naming project node - - 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); - - -- Add an attribute declaration for Source_Files as an empty list (to - -- indicate there are no sources in the naming project) and a package - -- Naming (that will be filled later). - - 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 Present (With_Clause) 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 No (With_Clause) 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 package Naming in the main project, that is a renaming of - -- package Naming in the naming 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. - - 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; - - -- Put the source directories in attribute Source_Dirs - - for Source_Dir_Index in 1 .. Source_Directories.Last loop - 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 No (Current_Source_Dir) 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 := 0; - Add_Str_To_Name_Buffer - (Source_Directories.Table (Source_Dir_Index).all); - Set_String_Value_Of (Value, Tree, To => Name_Find); - end; - end loop; - - -- Add an attribute declaration for Source_Files or 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 Present (Source_List_File_Comments) then - Tree.Project_Nodes.Table (Attribute).Comments := - Source_List_File_Comments; - else - Tree.Project_Nodes.Table (Attribute).Comments := - Source_Files_Comments; - end if; - end; - - -- Put the sources in the source list files and in the naming - -- project. - - for Source_Index in 1 .. Sources.Last loop - - -- Add the corresponding attribute in the - -- Naming package of the naming project. - - declare - Current_Source : constant Source := - Sources.Table (Source_Index); - - 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 - -- Add source file name to the source list file if it is not - -- already there. - - if not Source_Files.Get (Current_Source.File_Name) then - Source_Files.Set (Current_Source.File_Name, True); - Get_Name_String (Current_Source.File_Name); - Add_Char_To_Name_Buffer (ASCII.LF); - - if Write (Source_List_FD, - Name_Buffer (1)'Address, - Name_Len) /= Name_Len - then - Prj.Com.Fail ("disk full"); - end if; - end if; - - -- For an Ada source, add entry in package Naming - - if Current_Source.Unit_Name /= No_Name then - 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 Current_Source.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 (Current_Source.Unit_Name); - 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 => Current_Source.File_Name); - Set_Source_Index_Of - (Value, Tree, To => Current_Source.Index); - end if; - end; - end loop; - - -- Close the source list file - - Close (Source_List_FD); - - -- 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, - Max_Line_Length => 79); - 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 - -- For each Ada source, write a pragma Source_File_Name to the - -- configuration pragmas file. - - for Index in 1 .. Sources.Last loop - if Sources.Table (Index).Unit_Name /= No_Name then - Write_A_String ("pragma Source_File_Name"); - Write_Eol; - Write_A_String (" ("); - Write_A_String - (Get_Name_String (Sources.Table (Index).Unit_Name)); - Write_A_String (","); - Write_Eol; - - if Sources.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 (Sources.Table (Index).File_Name)); - - Write_A_String (""""); - - if Sources.Table (Index).Index /= 0 then - Write_A_String (", Index =>"); - Write_A_String (Sources.Table (Index).Index'Img); - end if; - - Write_A_String (");"); - Write_Eol; - end if; - end loop; - - Close (Output_FD); - end if; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (File_Path : String; - Project_File : Boolean; - Preproc_Switches : Argument_List; - Very_Verbose : Boolean; - Flags : Processing_Flags) - is - begin - Makr.Very_Verbose := Initialize.Very_Verbose; - Makr.Project_File := Initialize.Project_File; - - -- Do some needed initializations - - Csets.Initialize; - Snames.Initialize; - - Prj.Initialize (No_Project_Tree); - - Prj.Tree.Initialize (Root_Environment, Flags); - Prj.Env.Initialize_Default_Project_Path - (Root_Environment.Project_Path, - Target_Name => Sdefault.Target_Name.all); - - Prj.Tree.Initialize (Tree); - - Sources.Set_Last (0); - Source_Directories.Set_Last (0); - - -- Initialize the compiler switches - - Args := new Argument_List (1 .. Preproc_Switches'Length + 6); - 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 - - Path_Name := new - String (1 .. File_Path'Length + Project_File_Extension'Length); - Path_Last := File_Path'Length; - - 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 := new String'(To_Lower (Path_Name (1 .. Path_Last))); - Output_Name_Last := Output_Name'Last - 4; - - -- 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.all); - Output.Write_Line (""""); - end if; - - Part.Parse - (In_Tree => Tree, - Project => Project_Node, - Project_File_Name => Output_Name.all, - Errout_Handling => Part.Finalize_If_Error, - Store_Comments => True, - Is_Config_File => False, - Env => Root_Environment, - Current_Directory => Get_Current_Dir, - Packages_To_Check => Packages_To_Check_By_Gnatname); - - -- Fail if parsing was not successful - - if No (Project_Node) then - Prj.Com.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 Present (With_Clause) loop - if Prj.Tree.Name_Of (With_Clause, Tree) = - Project_Naming_Id - then - if No (Previous) 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 Present (Declaration) 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 No (Previous) 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 := - new String'(Output_Name (1 .. Output_Name_Last) & - Naming_File_Suffix & - Project_File_Extension); - 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_Last := - Project_Naming_Last + Project_File_Extension'Length; - - -- Create the source list file name - - Source_List_Last := Output_Name_Last; - Source_List_Path := - new String'(Output_Name (1 .. Output_Name_Last) & - Source_List_File_Suffix); - Source_List_Last := - Output_Name_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; - end Initialize; - - ------------- - -- Process -- - ------------- - - procedure Process - (Directories : Argument_List; - Name_Patterns : Regexp_List; - Excluded_Patterns : Regexp_List; - Foreign_Patterns : Regexp_List) - is - 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; - Do_Process : Boolean := True; - - Temp_File_Name : String_Access := null; - Save_Last_Source_Index : Natural := 0; - File_Name_Id : Name_Id := No_Name; - - Current_Source : Source; - - 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 - Do_Process := False; - exit; - end if; - end loop; - - if Do_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_Patterns'Range loop - if - Match (Canon (1 .. Last), Excluded_Patterns (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 Name_Patterns'Range loop - if - Match - (Canon (1 .. Last), Name_Patterns (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, "gnatname"); - 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.all, 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_Source_Index := Sources.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 Sources table - - Name_Len := J - 12; - Name_Buffer (1 .. Name_Len) := - Text_Line (6 .. J - 7); - Current_Source := - (Unit_Name => Name_Find, - File_Name => File_Name_Id, - Index => 0, - Spec => Text_Line (J - 5 .. J) = - "(spec)"); - - Sources.Append (Current_Source); - end if; - - exit Char_Loop; - end if; - end loop Char_Loop; - end loop Line_Loop; - end if; - - if Save_Last_Source_Index = Sources.Last then - if Opt.Verbose_Mode then - Output.Write_Line (" not a unit"); - end if; - - else - if Sources.Last > - Save_Last_Source_Index + 1 - then - for Index in Save_Last_Source_Index + 1 .. - Sources.Last - loop - Sources.Table (Index).Index := - Int (Index - Save_Last_Source_Index); - end loop; - end if; - - for Index in Save_Last_Source_Index + 1 .. - Sources.Last - loop - Current_Source := Sources.Table (Index); - - if Opt.Verbose_Mode then - if Current_Source.Spec then - Output.Write_Str (" spec of "); - - else - Output.Write_Str (" body of "); - end if; - - Output.Write_Line - (Get_Name_String - (Current_Source.Unit_Name)); - end if; - end loop; - 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_Patterns'Range loop - if Match (Canon (1 .. Last), - Foreign_Patterns (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 Matched = True then - - -- Add source file name without unit name - - Name_Len := 0; - Add_Str_To_Name_Buffer (Canon (1 .. Last)); - Sources.Append - ((File_Name => Name_Find, - Unit_Name => No_Name, - Index => 0, - Spec => False)); - 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 Process - - begin - Processed_Directories.Set_Last (0); - - -- 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; - Found : Boolean; - Canonical : String (1 .. Dir_Name'Length) := Dir_Name; - - begin - Canonical_Case_File_Name (Canonical); - - Found := False; - for J in 1 .. Source_Directories.Last loop - if Source_Directories.Table (J).all = Canonical then - Found := True; - exit; - end if; - end loop; - - if not Found then - Source_Directories.Append (new String'(Canonical)); - end if; - - if Dir_Name'Length >= 4 - and then (Dir_Name (Last - 2 .. Last) = "/**") - then - Last := Last - 3; - Recursively := True; - end if; - - Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); - end; - - end loop; - end Process; - - ---------------- - -- 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; |