From: bosch Date: Tue, 26 Mar 2002 21:07:04 +0000 (+0000) Subject: * prj-makr.ads, prj-makr.adb : New files. X-Git-Tag: upstream/4.9.2~87731 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=ce3319d9f640a4197f987c11f5261f5e00cb56dd;p=platform%2Fupstream%2Flinaro-gcc.git * prj-makr.ads, prj-makr.adb : New files. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@51406 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b114785..e33fc4a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2002-03-27 Geert Bosch + + * prj-makr.ads, prj-makr.adb : New files. + 2002-03-26 Neil Booth * misc.c (LANG_HOOKS_MARK_TREE): Redefine. diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb new file mode 100644 index 0000000..b74b566 --- /dev/null +++ b/gcc/ada/prj-makr.adb @@ -0,0 +1,1016 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . M A K R -- +-- -- +-- B o d y -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2001-2002 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Csets; +with Namet; use Namet; +with Opt; +with Output; +with Osint; use Osint; +with Prj; use Prj; +with Prj.Part; +with Prj.PP; +with Prj.Tree; use Prj.Tree; +with Snames; use Snames; +with Stringt; use Stringt; +with Table; use Table; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.Expect; use GNAT.Expect; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Regexp; use GNAT.Regexp; +with GNAT.Regpat; use GNAT.Regpat; + +package body Prj.Makr is + + 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 + + ---------- + -- Make -- + ---------- + + procedure Make + (File_Path : String; + Project_File : Boolean; + Directories : Argument_List; + Name_Patterns : Argument_List; + Excluded_Patterns : Argument_List; + Very_Verbose : Boolean) + is + 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; + + 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; + + Source_List_Path : String (1 .. Output_Name'Length + + Source_List_File_Suffix'Length); + Source_List_Last : Natural; + + Source_List_FD : File_Descriptor; + + Str : String (1 .. 2_000); + Last : Natural; + Dir : Dir_Type; + + PD : Process_Descriptor; + Result : Expect_Match; + Matcher : constant Pattern_Matcher := + Compile (Expression => "expected|Unit.*\)|No such"); + + Args : Argument_List := + (1 => new String'("-c"), + 2 => new String'("-gnats"), + 3 => new String'("-gnatu"), + 4 => new String'("-x"), + 5 => new String'("ada"), + 6 => null); + + type SFN_Pragma is record + Unit : String_Access; + File : String_Access; + 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 => 50, + Table_Name => "Prj.Makr.SFN_Pragmas"); + + begin + -- Do some needed initializations + + Csets.Initialize; + Namet.Initialize; + Snames.Initialize; + Prj.Initialize; + + SFN_Pragmas.Set_Last (0); + + -- 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 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 => + 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; + + 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 + 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 + begin + Excluded_Expressions (Index) := + Compile (Pattern => Excluded_Patterns (Index).all, Glob => True); + + exception + when Error_In_Regexp => + Fail ("invalid regular expression """ & + Excluded_Patterns (Index).all & '"'); + end; + end loop; + + for Index in Regular_Expressions'Range loop + begin + Regular_Expressions (Index) := + Compile (Pattern => Name_Patterns (Index).all, Glob => True); + + exception + when Error_In_Regexp => + 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 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 .. Output_Name_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 + (Project => Project_Node, + Project_File_Name => Output_Name (1 .. Output_Name_Last), + Always_Errout_Finalize => False); + + -- If parsing was successful, remove the components that are + -- automatically generated, if any, so that they will be + -- unconditionally added later. + + if Project_Node /= Empty_Node then + + -- Remove the with clause for the naming project file + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node); + Previous : Project_Node_Id := Empty_Node; + + begin + while With_Clause /= Empty_Node loop + if Tree.Name_Of (With_Clause) = Project_Naming_Id then + if Previous = Empty_Node then + Set_First_With_Clause_Of + (Project_Node, + To => Next_With_Clause_Of (With_Clause)); + else + Set_Next_With_Clause_Of + (Previous, + To => Next_With_Clause_Of (With_Clause)); + end if; + + exit; + end if; + + Previous := With_Clause; + With_Clause := Next_With_Clause_Of (With_Clause); + end loop; + end; + + -- Remove attribute declarations of Source_Files, + -- Source_List_File, Source_Dirs, and the declaration of + -- package Naming, if they exist. + + declare + Declaration : Project_Node_Id := + First_Declarative_Item_Of + (Project_Declaration_Of (Project_Node)); + Previous : Project_Node_Id := Empty_Node; + Current_Node : Project_Node_Id := Empty_Node; + + begin + while Declaration /= Empty_Node loop + Current_Node := Current_Item_Node (Declaration); + + if (Kind_Of (Current_Node) = N_Attribute_Declaration + and then + (Tree.Name_Of (Current_Node) = Name_Source_Files + or else Tree.Name_Of (Current_Node) = + Name_Source_List_File + or else Tree.Name_Of (Current_Node) = + Name_Source_Dirs)) + or else + (Kind_Of (Current_Node) = N_Package_Declaration + and then Tree.Name_Of (Current_Node) = Name_Naming) + then + if Previous = Empty_Node then + Set_First_Declarative_Item_Of + (Project_Declaration_Of (Project_Node), + To => Next_Declarative_Item (Declaration)); + + else + Set_Next_Declarative_Item + (Previous, + To => Next_Declarative_Item (Declaration)); + end if; + + else + Previous := Declaration; + end if; + + Declaration := Next_Declarative_Item (Declaration); + end loop; + end; + end if; + 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); + Set_Name_Of (Project_Node, To => Output_Name_Id); + Set_Project_Declaration_Of + (Project_Node, + To => Default_Project_Node (Of_Kind => N_Project_Declaration)); + + 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); + Set_Name_Of (Project_Naming_Node, To => Project_Naming_Id); + Project_Naming_Decl := + Default_Project_Node (Of_Kind => N_Project_Declaration); + Set_Project_Declaration_Of (Project_Naming_Node, Project_Naming_Decl); + Naming_Package := + Default_Project_Node (Of_Kind => N_Package_Declaration); + Set_Name_Of (Naming_Package, To => Name_Naming); + + declare + Decl_Item : constant Project_Node_Id := + Default_Project_Node (Of_Kind => N_Declarative_Item); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + And_Expr_Kind => List); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => List); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => List); + + Empty_List : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String_List); + + begin + Set_First_Declarative_Item_Of + (Project_Naming_Decl, To => Decl_Item); + Set_Next_Declarative_Item (Decl_Item, Naming_Package); + Set_Current_Item_Node (Decl_Item, To => Attribute); + Set_Name_Of (Attribute, To => Name_Source_Files); + Set_Expression_Of (Attribute, To => Expression); + Set_First_Term (Expression, To => Term); + Set_Current_Term (Term, To => Empty_List); + end; + + -- Add a with clause on the naming project in the main project + + declare + With_Clause : constant Project_Node_Id := + Default_Project_Node (Of_Kind => N_With_Clause); + + begin + Set_Next_With_Clause_Of + (With_Clause, To => First_With_Clause_Of (Project_Node)); + Set_First_With_Clause_Of (Project_Node, To => With_Clause); + Set_Name_Of (With_Clause, To => Project_Naming_Id); + Start_String; + Store_String_Chars + (Project_Naming_File_Name (1 .. Project_Naming_Last)); + Set_String_Value_Of (With_Clause, To => End_String); + end; + + Project_Declaration := Project_Declaration_Of (Project_Node); + + -- 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); + + Naming : constant Project_Node_Id := + Default_Project_Node (Of_Kind => N_Package_Declaration); + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of (Project_Declaration)); + Set_First_Declarative_Item_Of + (Project_Declaration, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, To => Naming); + Set_Name_Of (Naming, To => Name_Naming); + Set_Project_Of_Renamed_Package_Of + (Naming, To => Project_Naming_Node); + 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); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + And_Expr_Kind => List); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => List); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, And_Expr_Kind => List); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of (Project_Declaration)); + Set_First_Declarative_Item_Of + (Project_Declaration, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, To => Attribute); + Set_Name_Of (Attribute, To => Name_Source_Dirs); + Set_Expression_Of (Attribute, To => Expression); + Set_First_Term (Expression, To => Term); + Source_Dirs_List := + Default_Project_Node (Of_Kind => N_Literal_String_List, + And_Expr_Kind => List); + Set_Current_Term (Term, To => Source_Dirs_List); + 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); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Attribute_Declaration, + And_Expr_Kind => Single); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of (Project_Declaration)); + Set_First_Declarative_Item_Of + (Project_Declaration, To => Decl_Item); + Set_Current_Item_Node (Decl_Item, To => Attribute); + Set_Name_Of (Attribute, To => Name_Source_List_File); + Set_Expression_Of (Attribute, To => Expression); + Set_First_Term (Expression, To => Term); + Set_Current_Term (Term, To => Value); + Start_String; + Store_String_Chars (Source_List_Path (1 .. Source_List_Last)); + Set_String_Value_Of (Value, To => End_String); + end; + end if; + + -- Process each directory + + for Index in Directories'Range loop + + declare + Dir_Name : constant String := Directories (Index).all; + Matched : Matched_Type := False; + + begin + if Opt.Verbose_Mode then + Output.Write_Str ("Processing directory """); + Output.Write_Str (Dir_Name); + Output.Write_Line (""""); + 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, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + + begin + if Current_Source_Dir = Empty_Node then + Set_First_Expression_In_List + (Source_Dirs_List, To => Expression); + else + Set_Next_Expression_In_List + (Current_Source_Dir, To => Expression); + end if; + + Current_Source_Dir := Expression; + Set_First_Term (Expression, To => Term); + Set_Current_Term (Term, To => Value); + Start_String; + Store_String_Chars (S => Dir_Name); + Set_String_Value_Of (Value, To => End_String); + end; + end if; + + -- Get the source file names from the directory. + -- Fails if the directory does not exist. + + begin + Open (Dir, Dir_Name); + + exception + when Directory_Error => + Fail ("cannot open directory """ & Dir_Name & '"'); + end; + + -- Process each regular file in the directory + + loop + Read (Dir, Str, Last); + exit when Last = 0; + + if Is_Regular_File + (Dir_Name & Directory_Separator & Str (1 .. Last)) + then + Matched := True; + + -- First, check if the file name matches at least one of + -- the excluded expressions; + + for Index in Excluded_Expressions'Range loop + if + Match (Str (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 (Str (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_Str (""": "); + end if; + + -- If the file name matches one of the regular expressions, + -- parse it to get its unit name. + + if Matched = True then + Args (6) := new String' + (Dir_Name & + Directory_Separator & + Str (1 .. Last)); + + begin + Non_Blocking_Spawn + (PD, "gcc", Args, Err_To_Out => True); + Expect (PD, Result, Matcher); + + exception + when Process_Died => + if Opt.Verbose_Mode then + Output.Write_Str ("(process died) "); + end if; + + Result := Expect_Timeout; + end; + + if Result /= Expect_Timeout then + + -- If we got a unit name, this is a valid source file + + declare + S : constant String := Expect_Out_Match (PD); + + begin + if S'Length >= 13 + and then S (S'First .. S'First + 3) = "Unit" + then + if Opt.Verbose_Mode then + Output.Write_Str + (S (S'Last - 4 .. S'Last - 1)); + Output.Write_Str (" of "); + Output.Write_Line + (S (S'First + 5 .. S'Last - 7)); + 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); + + Attribute : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => + N_Attribute_Declaration); + + Expression : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Expression, + And_Expr_Kind => Single); + + Term : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Term, + And_Expr_Kind => Single); + + Value : constant Project_Node_Id := + Default_Project_Node + (Of_Kind => N_Literal_String, + And_Expr_Kind => Single); + + begin + Set_Next_Declarative_Item + (Decl_Item, + To => First_Declarative_Item_Of + (Naming_Package)); + Set_First_Declarative_Item_Of + (Naming_Package, To => Decl_Item); + Set_Current_Item_Node + (Decl_Item, To => Attribute); + + if S (S'Last - 5 .. S'Last) = "(spec)" then + Set_Name_Of + (Attribute, To => Name_Specification); + else + Set_Name_Of + (Attribute, + To => Name_Implementation); + end if; + + Start_String; + Store_String_Chars + (To_Lower + (S (S'First + 5 .. S'Last - 7))); + Set_Associative_Array_Index_Of + (Attribute, To => End_String); + + Set_Expression_Of + (Attribute, To => Expression); + Set_First_Term (Expression, To => Term); + Set_Current_Term (Term, To => Value); + + Start_String; + Store_String_Chars (Str (1 .. Last)); + Set_String_Value_Of + (Value, To => End_String); + end; + + -- 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 + Fail ("disk full"); + end if; + else + -- Add an entry in the SFN_Pragmas table + + SFN_Pragmas.Increment_Last; + SFN_Pragmas.Table (SFN_Pragmas.Last) := + (Unit => new String' + (S (S'First + 5 .. S'Last - 7)), + File => new String'(Str (1 .. Last)), + Spec => S (S'Last - 5 .. S'Last) + = "(spec)"); + end if; + + else + if Opt.Verbose_Mode then + Output.Write_Line ("not a unit"); + end if; + end if; + end; + + else + if Opt.Verbose_Mode then + Output.Write_Line ("not a unit"); + end if; + end if; + + Close (PD); + + else + if Very_Verbose then + if Matched = False then + Output.Write_Line ("no match"); + + else + Output.Write_Line ("excluded"); + end if; + end if; + end if; + end if; + end loop; + + Close (Dir); + end; + end loop; + + if Project_File then + Close (Source_List_FD); + end if; + + declare + Discard : Boolean; + + 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 + 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, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access); + 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 + 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, + W_Char => Write_A_Char'Access, + W_Eol => Write_Eol'Access, + W_Str => Write_A_String'Access); + 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 (SFN_Pragmas.Table (Index).Unit.all); + 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 (SFN_Pragmas.Table (Index).File.all); + 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 + Fail ("disk full"); + end if; + end if; + end Write_A_String; + +end Prj.Makr; diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads new file mode 100644 index 0000000..4bba35c --- /dev/null +++ b/gcc/ada/prj-makr.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . M A K R -- +-- -- +-- S p e c -- +-- -- +-- $Revision$ +-- -- +-- Copyright (C) 2001-2002 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- Support for procedure Gnatname. + +-- For arbitrary naming schemes, create or update a project file, +-- or create a configuration pragmas file. + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package Prj.Makr is + + procedure Make + (File_Path : String; + Project_File : Boolean; + Directories : Argument_List; + Name_Patterns : Argument_List; + Excluded_Patterns : Argument_List; + Very_Verbose : Boolean); + -- Create a project file or a configuration pragmas file + -- + -- Project_File is the path name of the project file. If the project + -- file already exists parse it and keep all the elements that are not + -- automatically generated. + -- + -- Directory_List_File is the path name of a text file that + -- contains on each non empty line the path names of the source + -- directories for the project file. The source directories + -- are relative to the directory of the project file. + -- + -- File_Name_Patterns is a GNAT.Regexp string pattern such as + -- ".*\.ads|.*\.adb" or any other pattern. + -- + -- A project file (without any sources) is automatically generated + -- with the name _naming. It contains a package Naming with + -- all the specs and bodies for the project. + -- A file containing the source file names is automatically + -- generated and used as the Source_File_List for the project file. + +end Prj.Makr;