+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 <file_name>.<extension>
-
- 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 <file_name>
-
- 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 <directory>/<file_name>.<extension>
-
- 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 <directory>/<file_name>
-
- 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;
projects / msp430-gcc.git / blobdiff