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;
procedure Write_Eol;
procedure Write_A_Char (C : Character);
procedure Write_A_String (S : String);
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
Csets.Initialize;
Namet.Initialize;
Snames.Initialize;
Prj.Initialize;
SFN_Pragmas.Set_Last (0);
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;
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;
Name_Len := Output_Name_Last;
Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
Output_Name_Id := Name_Find;
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;
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;
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;
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;
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
declare
Discard : Boolean;
begin
Delete_File
(Source_List_Path (1 .. Source_List_Last),
Success => Discard);
end;
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;
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 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 Project_Node /= Empty_Node then
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;
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 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;
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;
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);
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;
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;
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;
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
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;
begin
Open (Dir, Dir_Name);
exception
when Directory_Error =>
Fail ("cannot open directory """ & Dir_Name & '"');
end;
loop
Read (Dir, Str, Last);
exit when Last = 0;
if Is_Regular_File
(Dir_Name & Directory_Separator & Str (1 .. Last))
then
Matched := True;
for Index in Excluded_Expressions'Range loop
if
Match (Str (1 .. Last), Excluded_Expressions (Index))
then
Matched := Excluded;
exit;
end if;
end loop;
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 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
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
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;
Last := Last + 1;
Str (Last) := ASCII.LF;
if Write (Source_List_FD,
Str (1)'Address,
Last) /= Last
then
Fail ("disk full");
end if;
else
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_File
(Path_Name (Directory_Last + 1 .. Path_Last),
Success => Discard);
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);
if Output_FD = Invalid_FD then
Fail ("cannot create new """ & Path_Name (1 .. Path_Last) & '"');
end if;
if Project_File then
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_File
(Project_Naming_File_Name (1 .. Project_Naming_Last),
Success => Discard);
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);
if Output_FD = Invalid_FD then
Fail ("cannot create new """ &
Project_Naming_File_Name (1 .. Project_Naming_Last) &
'"');
end if;
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
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;
procedure Write_A_Char (C : Character) is
begin
Write_A_String ((1 => C));
end Write_A_Char;
procedure Write_Eol is
begin
Write_A_String ((1 => ASCII.LF));
end Write_Eol;
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;