--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
git://gcc.gnu.org / gcc.git / commitdiff