X-Git-Url: https://oss.titaniummirror.com/gitweb/?a=blobdiff_plain;f=gcc%2Fada%2Fprj-part.adb;fp=gcc%2Fada%2Fprj-part.adb;h=0000000000000000000000000000000000000000;hb=6fed43773c9b0ce596dca5686f37ac3fc0fa11c0;hp=a734ca545093e0095f0d8f38001870b32ecd4fc4;hpb=27b11d56b743098deb193d510b337ba22dc52e5c;p=msp430-gcc.git diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb deleted file mode 100644 index a734ca54..00000000 --- a/gcc/ada/prj-part.adb +++ /dev/null @@ -1,862 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- P R J . P A R T -- --- -- --- B o d y -- --- -- --- $Revision: 1.3.10.1 $ --- -- --- Copyright (C) 2001 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. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -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_File_Extension : String := ".gpr"; - - 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 Path_Name_Of - (File_Name : String; - Directory : String) - return String; - -- Returns the path name of a (non project) file. - -- Returns an empty string if file cannot be found. - - 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 - -- Initialize the tables - - Tree_Private_Part.Project_Nodes.Set_Last (Empty_Node); - Tree_Private_Part.Projects_Htable.Reset; - - Errout.Initialize; - - -- And 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 Errout.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; - - -- 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)); - - 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); - - else - -- 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); - - 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; - - ------------------ - -- Path_Name_Of -- - ------------------ - - function Path_Name_Of - (File_Name : String; - Directory : String) - return String - is - Result : String_Access; - - begin - Result := Locate_Regular_File (File_Name => File_Name, - Path => Directory); - - if Result = null then - return ""; - - else - Canonical_Case_File_Name (Result.all); - return Result.all; - end if; - end Path_Name_Of; - - ----------------------- - -- 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 - Canonical_Case_File_Name (Project_File_Extension); - - if Prj_Path.all = "" then - Project_Path := new String'("."); - - else - Project_Path := new String'("." & Path_Separator & Prj_Path.all); - end if; - -end Prj.Part;