------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P R J . P A R T -- -- -- -- B o d y -- -- -- -- -- -- 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 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; -- The project path; initialized during package elaboration. Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; Prj_Path : constant String_Access := Getenv (Ada_Project_Path); ------------------------------------ -- Local Packages and Subprograms -- ------------------------------------ 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"); -- This table is used to detect circular dependencies -- for imported and modified projects. procedure Parse_Context_Clause (Context_Clause : out Project_Node_Id; Project_Directory : Name_Id); -- Parse the context clause of a project -- Does nothing if there is b\no context clause (if the current -- token is not "with"). procedure Parse_Single_Project (Project : out Project_Node_Id; Path_Name : String; Modified : Boolean); -- Parse a project file. -- Recursive procedure: it calls itself for imported and -- modified projects. function Project_Path_Name_Of (Project_File_Name : String; Directory : String) return String; -- Returns the path name of a project file. -- Returns an empty string if project file cannot be found. function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id; -- Get the directory of the file with the specified path name. -- This includes the directory separator as the last character. -- Returns "./" if Path_Name contains no directory separator. function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id; -- Returns the name of a file with the specified path name -- with no directory information. function Project_Name_From (Path_Name : String) return Name_Id; -- Returns the name of the project that corresponds to its path name. -- Returns No_Name if the path name is invalid, because the corresponding -- project name does not have the syntax of an ada identifier. ---------------------------- -- Immediate_Directory_Of -- ---------------------------- 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 -- Remove from name all characters after the last -- directory separator. Name_Len := Index; return Name_Find; end if; end loop; -- There is no directory separator in name. Return "./" or ".\" Name_Len := 2; Name_Buffer (1) := '.'; Name_Buffer (2) := Dir_Sep; return Name_Find; end Immediate_Directory_Of; ----------- -- Parse -- ----------- 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; -- Parse the main project file 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 there were any kind of error during the parsing, serious -- or not, then the parsing fails. 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 => -- Internal error 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; -------------------------- -- Parse_Context_Clause -- -------------------------- 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 -- Assume no context clause Context_Clause := Empty_Node; With_Loop : -- If Token is not WITH, there is no context clause, -- or we have exhausted the with clauses. while Token = Tok_With loop Comma_Loop : loop Scan; -- scan past WITH or "," 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 -- The project file cannot be found 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 this is not imported by the main project file, -- display the import path. 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 -- New with clause if Current_With_Clause = Empty_Node then -- First with clause of the context clause 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 the imported project Parse_Single_Project (Project => Withed_Project, Path_Name => Imported_Path_Name, Modified => False); if Withed_Project /= Empty_Node then -- If parsing was successful, record project name -- and path name in with clause 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 -- End of (possibly multiple) with clause; Scan; -- scan past the semicolon. 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; -------------------------- -- Parse_Single_Project -- -------------------------- 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; -- Check for a circular dependency 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; -- Check if the project file has already been parsed. 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; -- We never encountered this project file -- Save the scan state, load the project file and start to scan it. Save_Project_Scan_State (Project_Scan_State); Source_Index := Load_Project_File (Path_Name); -- if we cannot find it, we stop 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 -- The project file name is not correct (no or bad extension, -- or not following Ada identifier's syntax). 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); -- Is there any imported project? 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"); -- Mark location of PROJECT token if present if Token = Tok_Project then Set_Location_Of (Project, Token_Ptr); Scan; -- scan past project 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 -- The project name is not the one that was expected from -- the file name. Report a warning. 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 -- Check if we already have a project with this name 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; -- scan past the project name end if; if Token = Tok_Extends then -- We are extending another project Scan; -- scan past EXTENDS 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 -- We could not find the project file to modify 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 we are not in the main project file, display the -- import path. 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; -- scan past the modified project path end if; end if; Expect (Tok_Is, "is"); declare Project_Declaration : Project_Node_Id := Empty_Node; begin -- No need to Scan past IS, Prj.Dect.Parse will do it. Prj.Dect.Parse (Declarations => Project_Declaration, Current_Project => Project, Extends => Modified_Project); Set_Project_Declaration_Of (Project, Project_Declaration); end; Expect (Tok_End, "end"); -- Skip END if present if Token = Tok_End then Scan; end if; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then -- We check if this is the project name 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 the scan state, in case we are not the main project Restore_Project_Scan_State (Project_Scan_State); Project_Stack.Decrement_Last; end Parse_Single_Project; ----------------------- -- Project_Name_From -- ----------------------- 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; -------------------------- -- Project_Path_Name_Of -- -------------------------- function Project_Path_Name_Of (Project_File_Name : String; Directory : String) return String is Result : String_Access; begin -- First we try . 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); -- Then we try 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); -- The we try /. 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); -- Then we try / 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 we cannot find the project file, we return an empty string 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; ------------------------- -- Simple_File_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;