with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Exceptions; use Ada.Exceptions;
with Errout; use Errout;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Prj.Dect;
with Scans; use Scans;
with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Sinput.P; use Sinput.P;
with Stringt; use Stringt;
with Table;
with Types; use Types;
pragma Elaborate_All (GNAT.OS_Lib);
package body Prj.Part is
Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
Project_Path : String_Access;
Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
package Project_Stack is new Table.Table
(Table_Component_Type => Name_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 10,
Table_Name => "Prj.Part.Project_Stack");
procedure Parse_Context_Clause
(Context_Clause : out Project_Node_Id;
Project_Directory : Name_Id);
procedure Parse_Single_Project
(Project : out Project_Node_Id;
Path_Name : String;
Modified : Boolean);
function Project_Path_Name_Of
(Project_File_Name : String;
Directory : String)
return String;
function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id;
function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id;
function Project_Name_From (Path_Name : String) return Name_Id;
function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id is
begin
Get_Name_String (Path_Name);
for Index in reverse 1 .. Name_Len loop
if Name_Buffer (Index) = '/'
or else Name_Buffer (Index) = Dir_Sep
then
Name_Len := Index;
return Name_Find;
end if;
end loop;
Name_Len := 2;
Name_Buffer (1) := '.';
Name_Buffer (2) := Dir_Sep;
return Name_Find;
end Immediate_Directory_Of;
procedure Parse
(Project : out Project_Node_Id;
Project_File_Name : String;
Always_Errout_Finalize : Boolean)
is
Current_Directory : constant String := Get_Current_Dir;
begin
Project := Empty_Node;
if Current_Verbosity >= Medium then
Write_Str ("ADA_PROJECT_PATH=""");
Write_Str (Project_Path.all);
Write_Line ("""");
end if;
declare
Path_Name : constant String :=
Project_Path_Name_Of (Project_File_Name,
Directory => Current_Directory);
begin
Errout.Initialize;
if Path_Name = "" then
Fail ("project file """ & Project_File_Name & """ not found");
end if;
Parse_Single_Project
(Project => Project,
Path_Name => Path_Name,
Modified => False);
if Errout.Total_Errors_Detected > 0 then
Project := Empty_Node;
end if;
if Project = Empty_Node or else Always_Errout_Finalize then
Errout.Finalize;
end if;
end;
exception
when X : others =>
Write_Line (Exception_Information (X));
Write_Str ("Exception ");
Write_Str (Exception_Name (X));
Write_Line (" raised, while processing project file");
Project := Empty_Node;
end Parse;
procedure Parse_Context_Clause
(Context_Clause : out Project_Node_Id;
Project_Directory : Name_Id)
is
Project_Directory_Path : constant String :=
Get_Name_String (Project_Directory);
Current_With_Clause : Project_Node_Id := Empty_Node;
Next_With_Clause : Project_Node_Id := Empty_Node;
begin
Context_Clause := Empty_Node;
With_Loop :
while Token = Tok_With loop
Comma_Loop :
loop
Scan;
Expect (Tok_String_Literal, "literal string");
if Token /= Tok_String_Literal then
return;
end if;
String_To_Name_Buffer (Strval (Token_Node));
declare
Original_Path : constant String :=
Name_Buffer (1 .. Name_Len);
Imported_Path_Name : constant String :=
Project_Path_Name_Of
(Original_Path,
Project_Directory_Path);
Withed_Project : Project_Node_Id := Empty_Node;
begin
if Imported_Path_Name = "" then
Name_Len := Original_Path'Length;
Name_Buffer (1 .. Name_Len) := Original_Path;
Error_Msg_Name_1 := Name_Find;
Error_Msg ("unknown project file: {", Token_Ptr);
if Project_Stack.Last > 1 then
for Index in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 := Project_Stack.Table (Index);
Error_Msg ("\imported by {", Token_Ptr);
end loop;
end if;
else
if Current_With_Clause = Empty_Node then
Current_With_Clause := Default_Project_Node
(Of_Kind => N_With_Clause);
Context_Clause := Current_With_Clause;
else
Next_With_Clause := Default_Project_Node
(Of_Kind => N_With_Clause);
Set_Next_With_Clause_Of
(Current_With_Clause, Next_With_Clause);
Current_With_Clause := Next_With_Clause;
end if;
Set_String_Value_Of
(Current_With_Clause, Strval (Token_Node));
Set_Location_Of (Current_With_Clause, Token_Ptr);
String_To_Name_Buffer
(String_Value_Of (Current_With_Clause));
Parse_Single_Project
(Project => Withed_Project,
Path_Name => Imported_Path_Name,
Modified => False);
if Withed_Project /= Empty_Node then
Set_Project_Node_Of (Current_With_Clause, Withed_Project);
Set_Name_Of (Current_With_Clause,
Name_Of (Withed_Project));
Name_Len := Imported_Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Imported_Path_Name;
Set_Path_Name_Of (Current_With_Clause, Name_Find);
end if;
end if;
end;
Scan;
if Token = Tok_Semicolon then
Scan; exit Comma_Loop;
elsif Token /= Tok_Comma then
Error_Msg ("expected comma or semi colon", Token_Ptr);
exit Comma_Loop;
end if;
end loop Comma_Loop;
end loop With_Loop;
end Parse_Context_Clause;
procedure Parse_Single_Project
(Project : out Project_Node_Id;
Path_Name : String;
Modified : Boolean)
is
Canonical_Path_Name : Name_Id;
Project_Directory : Name_Id;
Project_Scan_State : Saved_Project_Scan_State;
Source_Index : Source_File_Index;
Modified_Project : Project_Node_Id := Empty_Node;
A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
Tree_Private_Part.Projects_Htable.Get_First;
Name_From_Path : constant Name_Id := Project_Name_From (Path_Name);
use Tree_Private_Part;
begin
Name_Len := Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Path_Name;
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Canonical_Path_Name := Name_Find;
for Index in 1 .. Project_Stack.Last loop
if Canonical_Path_Name = Project_Stack.Table (Index) then
Error_Msg ("circular dependency detected", Token_Ptr);
Error_Msg_Name_1 := Canonical_Path_Name;
Error_Msg ("\ { is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
Error_Msg_Name_1 := Project_Stack.Table (Current);
if Error_Msg_Name_1 /= Canonical_Path_Name then
Error_Msg
("\ { which itself is imported by", Token_Ptr);
else
Error_Msg ("\ {", Token_Ptr);
exit;
end if;
end loop;
Project := Empty_Node;
return;
end if;
end loop;
Project_Stack.Increment_Last;
Project_Stack.Table (Project_Stack.Last) := Canonical_Path_Name;
while
A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
loop
if
Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name
then
if Modified then
if A_Project_Name_And_Node.Modified then
Error_Msg
("cannot modify the same project file several times",
Token_Ptr);
else
Error_Msg
("cannot modify an imported project file",
Token_Ptr);
end if;
elsif A_Project_Name_And_Node.Modified then
Error_Msg
("cannot imported a modified project file",
Token_Ptr);
end if;
Project := A_Project_Name_And_Node.Node;
Project_Stack.Decrement_Last;
return;
end if;
A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next;
end loop;
Save_Project_Scan_State (Project_Scan_State);
Source_Index := Load_Project_File (Path_Name);
if Source_Index = No_Source_File then
Project := Empty_Node;
Project_Stack.Decrement_Last;
return;
end if;
Initialize_Scanner (Types.No_Unit, Source_Index);
if Name_From_Path = No_Name then
Error_Msg_Name_1 := Canonical_Path_Name;
Error_Msg ("?{ is not a valid path name for a project file",
Token_Ptr);
end if;
if Current_Verbosity >= Medium then
Write_Str ("Parsing """);
Write_Str (Path_Name);
Write_Char ('"');
Write_Eol;
end if;
Project_Directory := Immediate_Directory_Of (Canonical_Path_Name);
Project := Default_Project_Node (Of_Kind => N_Project);
Set_Directory_Of (Project, Project_Directory);
Set_Name_Of (Project, Simple_File_Name_Of (Canonical_Path_Name));
Set_Path_Name_Of (Project, Canonical_Path_Name);
Set_Location_Of (Project, Token_Ptr);
declare
First_With_Clause : Project_Node_Id := Empty_Node;
begin
Parse_Context_Clause (Context_Clause => First_With_Clause,
Project_Directory => Project_Directory);
Set_First_With_Clause_Of (Project, First_With_Clause);
end;
Expect (Tok_Project, "project");
if Token = Tok_Project then
Set_Location_Of (Project, Token_Ptr);
Scan; end if;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (Project, Token_Name);
Get_Name_String (Token_Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
declare
Expected_Name : constant Name_Id := Name_Find;
begin
if Name_From_Path /= No_Name
and then Expected_Name /= Name_From_Path
then
Error_Msg_Name_1 := Expected_Name;
Error_Msg ("?file name does not match unit name, " &
"should be `{" & Project_File_Extension & "`",
Token_Ptr);
end if;
end;
declare
Project_Name : Name_Id :=
Tree_Private_Part.Projects_Htable.Get_First.Name;
begin
while Project_Name /= No_Name
and then Project_Name /= Token_Name
loop
Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name;
end loop;
if Project_Name /= No_Name then
Error_Msg ("duplicate project name", Token_Ptr);
else
Tree_Private_Part.Projects_Htable.Set
(K => Token_Name,
E => (Name => Token_Name,
Node => Project,
Modified => Modified));
end if;
end;
Scan; end if;
if Token = Tok_Extends then
Scan; Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
Set_Modified_Project_Path_Of (Project, Strval (Token_Node));
String_To_Name_Buffer (Modified_Project_Path_Of (Project));
declare
Original_Path_Name : constant String :=
Name_Buffer (1 .. Name_Len);
Modified_Project_Path_Name : constant String :=
Project_Path_Name_Of
(Original_Path_Name,
Get_Name_String
(Project_Directory));
begin
if Modified_Project_Path_Name = "" then
Name_Len := Original_Path_Name'Length;
Name_Buffer (1 .. Name_Len) := Original_Path_Name;
Error_Msg_Name_1 := Name_Find;
Error_Msg ("unknown project file: {", Token_Ptr);
if Project_Stack.Last > 1 then
Error_Msg_Name_1 :=
Project_Stack.Table (Project_Stack.Last);
Error_Msg ("\extended by {", Token_Ptr);
for Index in reverse 1 .. Project_Stack.Last - 1 loop
Error_Msg_Name_1 := Project_Stack.Table (Index);
Error_Msg ("\imported by {", Token_Ptr);
end loop;
end if;
else
Parse_Single_Project
(Project => Modified_Project,
Path_Name => Modified_Project_Path_Name,
Modified => True);
end if;
end;
Scan; end if;
end if;
Expect (Tok_Is, "is");
declare
Project_Declaration : Project_Node_Id := Empty_Node;
begin
Prj.Dect.Parse
(Declarations => Project_Declaration,
Current_Project => Project,
Extends => Modified_Project);
Set_Project_Declaration_Of (Project, Project_Declaration);
end;
Expect (Tok_End, "end");
if Token = Tok_End then
Scan;
end if;
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
if To_Lower (Get_Name_String (Token_Name)) /=
Get_Name_String (Name_Of (Project))
then
Error_Msg ("Expected """ &
Get_Name_String (Name_Of (Project)) & """",
Token_Ptr);
end if;
end if;
if Token /= Tok_Semicolon then
Scan;
end if;
Expect (Tok_Semicolon, ";");
Restore_Project_Scan_State (Project_Scan_State);
Project_Stack.Decrement_Last;
end Parse_Single_Project;
function Project_Name_From (Path_Name : String) return Name_Id is
Canonical : String (1 .. Path_Name'Length) := Path_Name;
First : Natural := Canonical'Last;
Last : Positive := First;
begin
if First = 0 then
return No_Name;
end if;
Canonical_Case_File_Name (Canonical);
while First > 0
and then
Canonical (First) /= '.'
loop
First := First - 1;
end loop;
if Canonical (First) = '.' then
if Canonical (First .. Last) = Project_File_Extension
and then First /= 1
then
First := First - 1;
Last := First;
while First > 0
and then Canonical (First) /= '/'
and then Canonical (First) /= Dir_Sep
loop
First := First - 1;
end loop;
else
return No_Name;
end if;
else
return No_Name;
end if;
if Canonical (First) = '/'
or else Canonical (First) = Dir_Sep
then
First := First + 1;
end if;
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
if not Is_Letter (Name_Buffer (1)) then
return No_Name;
else
for Index in 2 .. Name_Len - 1 loop
if Name_Buffer (Index) = '_' then
if Name_Buffer (Index + 1) = '_' then
return No_Name;
end if;
elsif not Is_Alphanumeric (Name_Buffer (Index)) then
return No_Name;
end if;
end loop;
if not Is_Alphanumeric (Name_Buffer (Name_Len)) then
return No_Name;
else
return Name_Find;
end if;
end if;
end Project_Name_From;
function Project_Path_Name_Of
(Project_File_Name : String;
Directory : String)
return String
is
Result : String_Access;
begin
if Current_Verbosity = High then
Write_Str ("Project_Path_Name_Of (""");
Write_Str (Project_File_Name);
Write_Str (""", """);
Write_Str (Directory);
Write_Line (""");");
Write_Str (" Trying ");
Write_Str (Project_File_Name);
Write_Line (Project_File_Extension);
end if;
Result :=
Locate_Regular_File
(File_Name => Project_File_Name & Project_File_Extension,
Path => Project_Path.all);
if Result = null then
if Current_Verbosity = High then
Write_Str (" Trying ");
Write_Line (Project_File_Name);
end if;
Result :=
Locate_Regular_File
(File_Name => Project_File_Name,
Path => Project_Path.all);
if Result = null then
if Current_Verbosity = High then
Write_Str (" Trying ");
Write_Str (Directory);
Write_Str (Project_File_Name);
Write_Line (Project_File_Extension);
end if;
Result :=
Locate_Regular_File
(File_Name => Directory & Project_File_Name &
Project_File_Extension,
Path => Project_Path.all);
if Result = null then
if Current_Verbosity = High then
Write_Str (" Trying ");
Write_Str (Directory);
Write_Line (Project_File_Name);
end if;
Result :=
Locate_Regular_File
(File_Name => Directory & Project_File_Name,
Path => Project_Path.all);
end if;
end if;
end if;
if Result = null then
return "";
else
declare
Final_Result : String
:= GNAT.OS_Lib.Normalize_Pathname (Result.all);
begin
Free (Result);
Canonical_Case_File_Name (Final_Result);
return Final_Result;
end;
end if;
end Project_Path_Name_Of;
function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id is
begin
Get_Name_String (Path_Name);
for Index in reverse 1 .. Name_Len loop
if Name_Buffer (Index) = '/'
or else Name_Buffer (Index) = Dir_Sep
then
exit when Index = Name_Len;
Name_Buffer (1 .. Name_Len - Index) :=
Name_Buffer (Index + 1 .. Name_Len);
Name_Len := Name_Len - Index;
return Name_Find;
end if;
end loop;
return No_Name;
end Simple_File_Name_Of;
begin
if Prj_Path.all = "" then
Project_Path := new String'(".");
else
Project_Path := new String'("." & Path_Separator & Prj_Path.all);
end if;
end Prj.Part;