diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/prj-part.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/prj-part.adb | 2052 |
1 files changed, 2052 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/prj-part.adb b/gcc-4.4.3/gcc/ada/prj-part.adb new file mode 100644 index 000000000..5e0b14f01 --- /dev/null +++ b/gcc-4.4.3/gcc/ada/prj-part.adb @@ -0,0 +1,2052 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- P R J . P A R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2008, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Err_Vars; use Err_Vars; +with Opt; use Opt; +with Osint; use Osint; +with Output; use Output; +with Prj.Com; use Prj.Com; +with Prj.Dect; +with Prj.Err; use Prj.Err; +with Prj.Ext; use Prj.Ext; +with Sinput; use Sinput; +with Sinput.P; use Sinput.P; +with Snames; +with Table; + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Exceptions; use Ada.Exceptions; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; + +with System.HTable; use System.HTable; + +package body Prj.Part is + + Buffer : String_Access; + Buffer_Last : Natural := 0; + + Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + + ------------------------------------ + -- Local Packages and Subprograms -- + ------------------------------------ + + type With_Id is new Nat; + No_With : constant With_Id := 0; + + type With_Record is record + Path : Path_Name_Type; + Location : Source_Ptr; + Limited_With : Boolean; + Node : Project_Node_Id; + Next : With_Id; + end record; + -- Information about an imported project, to be put in table Withs below + + package Withs is new Table.Table + (Table_Component_Type => With_Record, + Table_Index_Type => With_Id, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Part.Withs"); + -- Table used to store temporarily paths and locations of imported + -- projects. These imported projects will be effectively parsed later: just + -- before parsing the current project for the non limited withed projects, + -- after getting its name; after complete parsing of the current project + -- for the limited withed projects. + + type Names_And_Id is record + Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type; + Id : Project_Node_Id; + Limited_With : Boolean; + end record; + + package Project_Stack is new Table.Table + (Table_Component_Type => Names_And_Id, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Prj.Part.Project_Stack"); + -- This table is used to detect circular dependencies + -- for imported and extended projects and to get the project ids of + -- limited imported projects when there is a circularity with at least + -- one limited imported project file. + + package Virtual_Hash is new System.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Project_Node_Id, + No_Element => Empty_Node, + Key => Project_Node_Id, + Hash => Prj.Tree.Hash, + Equal => "="); + -- Hash table to store the node id of the project for which a virtual + -- extending project need to be created. + + package Processed_Hash is new System.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Boolean, + No_Element => False, + Key => Project_Node_Id, + Hash => Prj.Tree.Hash, + Equal => "="); + -- Hash table to store the project process when looking for project that + -- need to have a virtual extending project, to avoid processing the same + -- project twice. + + package Projects_Paths is new System.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Path_Name_Type, + No_Element => No_Path, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Hash table to cache project path to avoid looking for them on the path + + procedure Create_Virtual_Extending_Project + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref); + -- Create a virtual extending project of For_Project. Main_Project is + -- the extending all project. + -- + -- The String_Value_Of is not set for the automatically added with + -- clause and keeps the default value of No_Name. This enables Prj.PP + -- to skip these automatically added with clauses to be processed. + + procedure Look_For_Virtual_Projects_For + (Proj : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Potentially_Virtual : Boolean); + -- Look for projects that need to have a virtual extending project. + -- This procedure is recursive. If called with Potentially_Virtual set to + -- True, then Proj may need an virtual extending project; otherwise it + -- does not (because it is already extended), but other projects that it + -- imports may need to be virtually extended. + + type Extension_Origin is (None, Extending_Simple, Extending_All); + -- Type of parameter From_Extended for procedures Parse_Single_Project and + -- Post_Parse_Context_Clause. Extending_All means that we are parsing the + -- tree rooted at an extending all project. + + procedure Parse_Single_Project + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Extends_All : out Boolean; + Path_Name : String; + Extended : Boolean; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String); + -- Parse a project file. This is a recursive procedure: it calls itself for + -- imported and extended projects. When From_Extended is not None, if the + -- project has already been parsed and is an extended project A, return the + -- ultimate (not extended) project that extends A. When In_Limited is True, + -- the importing path includes at least one "limited with". When parsing + -- configuration projects, do not allow a depth > 1. + + procedure Pre_Parse_Context_Clause + (In_Tree : Project_Node_Tree_Ref; + Context_Clause : out With_Id); + -- Parse the context clause of a project. Store the paths and locations of + -- the imported projects in table Withs. Does nothing if there is no + -- context clause (if the current token is not "with" or "limited" followed + -- by "with"). + + procedure Post_Parse_Context_Clause + (Context_Clause : With_Id; + In_Tree : Project_Node_Tree_Ref; + Limited_Withs : Boolean; + Imported_Projects : in out Project_Node_Id; + Project_Directory : Path_Name_Type; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String); + -- Parse the imported projects that have been stored in table Withs, if + -- any. From_Extended is used for the call to Parse_Single_Project below. + -- When In_Limited is True, the importing path includes at least one + -- "limited with". When Limited_Withs is False, only non limited withed + -- projects are parsed. When Limited_Withs is True, only limited withed + -- projects are parsed. + + 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 : Path_Name_Type) return Path_Name_Type; + -- 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 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. + + -------------------------------------- + -- Create_Virtual_Extending_Project -- + -------------------------------------- + + procedure Create_Virtual_Extending_Project + (For_Project : Project_Node_Id; + Main_Project : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) + is + + Virtual_Name : constant String := + Virtual_Prefix & + Get_Name_String (Name_Of (For_Project, In_Tree)); + -- The name of the virtual extending project + + Virtual_Name_Id : Name_Id; + -- Virtual extending project name id + + Virtual_Path_Id : Path_Name_Type; + -- Fake path name of the virtual extending project. The directory is + -- the same directory as the extending all project. + + Virtual_Dir_Id : constant Path_Name_Type := + Immediate_Directory_Of (Path_Name_Of (Main_Project, In_Tree)); + -- The directory of the extending all project + + -- The source of the virtual extending project is something like: + + -- project V$<project name> extends <project path> is + + -- for Source_Dirs use (); + + -- end V$<project name>; + + -- The project directory cannot be specified during parsing; it will be + -- put directly in the virtual extending project data during processing. + + -- Nodes that made up the virtual extending project + + Virtual_Project : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Project); + With_Clause : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_With_Clause); + Project_Declaration : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Project_Declaration); + Source_Dirs_Declaration : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Declarative_Item); + Source_Dirs_Attribute : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Attribute_Declaration, List); + Source_Dirs_Expression : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Expression, List); + Source_Dirs_Term : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Term, List); + Source_Dirs_List : constant Project_Node_Id := + Default_Project_Node + (In_Tree, N_Literal_String_List, List); + + begin + -- Get the virtual name id + + Name_Len := Virtual_Name'Length; + Name_Buffer (1 .. Name_Len) := Virtual_Name; + Virtual_Name_Id := Name_Find; + + -- Get the virtual path name + + Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); + + while Name_Len > 0 + and then Name_Buffer (Name_Len) /= Directory_Separator + and then Name_Buffer (Name_Len) /= '/' + loop + Name_Len := Name_Len - 1; + end loop; + + Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) := + Virtual_Name; + Name_Len := Name_Len + Virtual_Name'Length; + Virtual_Path_Id := Name_Find; + + -- With clause + + Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); + Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); + Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project); + Set_Next_With_Clause_Of + (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); + Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); + + -- Virtual project node + + Set_Name_Of (Virtual_Project, In_Tree, Virtual_Name_Id); + Set_Path_Name_Of (Virtual_Project, In_Tree, Virtual_Path_Id); + Set_Location_Of + (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree)); + Set_Directory_Of (Virtual_Project, In_Tree, Virtual_Dir_Id); + Set_Project_Declaration_Of + (Virtual_Project, In_Tree, Project_Declaration); + Set_Extended_Project_Path_Of + (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree)); + + -- Project declaration + + Set_First_Declarative_Item_Of + (Project_Declaration, In_Tree, Source_Dirs_Declaration); + Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project); + + -- Source_Dirs declaration + + Set_Current_Item_Node + (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute); + + -- Source_Dirs attribute + + Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs); + Set_Expression_Of + (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression); + + -- Source_Dirs expression + + Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term); + + -- Source_Dirs term + + Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List); + + -- Source_Dirs empty list: nothing to do + + -- Put virtual project into Projects_Htable + + Prj.Tree.Tree_Private_Part.Projects_Htable.Set + (T => In_Tree.Projects_HT, + K => Virtual_Name_Id, + E => (Name => Virtual_Name_Id, + Node => Virtual_Project, + Canonical_Path => No_Path, + Extended => False, + Proj_Qualifier => Unspecified)); + end Create_Virtual_Extending_Project; + + ---------------------------- + -- Immediate_Directory_Of -- + ---------------------------- + + function Immediate_Directory_Of + (Path_Name : Path_Name_Type) return Path_Name_Type + 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 all chars after last directory separator from name + + if Index > 1 then + Name_Len := Index - 1; + + else + Name_Len := Index; + end if; + + 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; + + ----------------------------------- + -- Look_For_Virtual_Projects_For -- + ----------------------------------- + + procedure Look_For_Virtual_Projects_For + (Proj : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + Potentially_Virtual : Boolean) + is + Declaration : Project_Node_Id := Empty_Node; + -- Node for the project declaration of Proj + + With_Clause : Project_Node_Id := Empty_Node; + -- Node for a with clause of Proj + + Imported : Project_Node_Id := Empty_Node; + -- Node for a project imported by Proj + + Extended : Project_Node_Id := Empty_Node; + -- Node for the eventual project extended by Proj + + begin + -- Nothing to do if Proj is not defined or if it has already been + -- processed. + + if Present (Proj) and then not Processed_Hash.Get (Proj) then + -- Make sure the project will not be processed again + + Processed_Hash.Set (Proj, True); + + Declaration := Project_Declaration_Of (Proj, In_Tree); + + if Present (Declaration) then + Extended := Extended_Project_Of (Declaration, In_Tree); + end if; + + -- If this is a project that may need a virtual extending project + -- and it is not itself an extending project, put it in the list. + + if Potentially_Virtual and then No (Extended) then + Virtual_Hash.Set (Proj, Proj); + end if; + + -- Now check the projects it imports + + With_Clause := First_With_Clause_Of (Proj, In_Tree); + + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Present (Imported) then + Look_For_Virtual_Projects_For + (Imported, In_Tree, Potentially_Virtual => True); + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + + -- Check also the eventual project extended by Proj. As this project + -- is already extended, call recursively with Potentially_Virtual + -- being False. + + Look_For_Virtual_Projects_For + (Extended, In_Tree, Potentially_Virtual => False); + end if; + end Look_For_Virtual_Projects_For; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Project_File_Name : String; + Always_Errout_Finalize : Boolean; + Packages_To_Check : String_List_Access := All_Packages; + Store_Comments : Boolean := False; + Current_Directory : String := "") + is + Dummy : Boolean; + pragma Warnings (Off, Dummy); + + Real_Project_File_Name : String_Access := + Osint.To_Canonical_File_Spec + (Project_File_Name); + + begin + if Real_Project_File_Name = null then + Real_Project_File_Name := new String'(Project_File_Name); + end if; + + Project := Empty_Node; + + Projects_Paths.Reset; + + if Current_Verbosity >= Medium then + Write_Str ("GPR_PROJECT_PATH="""); + Write_Str (Project_Path); + Write_Line (""""); + end if; + + declare + Path_Name : constant String := + Project_Path_Name_Of (Real_Project_File_Name.all, + Directory => Current_Directory); + + begin + Free (Real_Project_File_Name); + + Prj.Err.Initialize; + Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments); + Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments); + + -- Parse the main project file + + if Path_Name = "" then + Prj.Com.Fail + ("project file """, + Project_File_Name, + """ not found in " & Project_Path); + Project := Empty_Node; + return; + end if; + + Parse_Single_Project + (In_Tree => In_Tree, + Project => Project, + Extends_All => Dummy, + Path_Name => Path_Name, + Extended => False, + From_Extended => None, + In_Limited => False, + Packages_To_Check => Packages_To_Check, + Depth => 0, + Current_Dir => Current_Directory); + + -- If Project is an extending-all project, create the eventual + -- virtual extending projects and check that there are no illegally + -- imported projects. + + if Present (Project) + and then Is_Extending_All (Project, In_Tree) + then + -- First look for projects that potentially need a virtual + -- extending project. + + Virtual_Hash.Reset; + Processed_Hash.Reset; + + -- Mark the extending all project as processed, to avoid checking + -- the imported projects in case of a "limited with" on this + -- extending all project. + + Processed_Hash.Set (Project, True); + + declare + Declaration : constant Project_Node_Id := + Project_Declaration_Of (Project, In_Tree); + begin + Look_For_Virtual_Projects_For + (Extended_Project_Of (Declaration, In_Tree), In_Tree, + Potentially_Virtual => False); + end; + + -- Now, check the projects directly imported by the main project. + -- Remove from the potentially virtual any project extended by one + -- of these imported projects. For non extending imported + -- projects, check that they do not belong to the project tree of + -- the project being "extended-all" by the main project. + + declare + With_Clause : Project_Node_Id; + Imported : Project_Node_Id := Empty_Node; + Declaration : Project_Node_Id := Empty_Node; + + begin + With_Clause := First_With_Clause_Of (Project, In_Tree); + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Present (Imported) then + Declaration := Project_Declaration_Of (Imported, In_Tree); + + if Extended_Project_Of (Declaration, In_Tree) /= + Empty_Node + then + loop + Imported := + Extended_Project_Of (Declaration, In_Tree); + exit when No (Imported); + Virtual_Hash.Remove (Imported); + Declaration := + Project_Declaration_Of (Imported, In_Tree); + end loop; + end if; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + end; + + -- Now create all the virtual extending projects + + declare + Proj : Project_Node_Id := Virtual_Hash.Get_First; + begin + while Present (Proj) loop + Create_Virtual_Extending_Project (Proj, Project, In_Tree); + Proj := Virtual_Hash.Get_Next; + end loop; + end; + end if; + + -- If there were any kind of error during the parsing, serious + -- or not, then the parsing fails. + + if Err_Vars.Total_Errors_Detected > 0 then + Project := Empty_Node; + end if; + + if No (Project) or else Always_Errout_Finalize then + Prj.Err.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; + + ------------------------------ + -- Pre_Parse_Context_Clause -- + ------------------------------ + + procedure Pre_Parse_Context_Clause + (In_Tree : Project_Node_Tree_Ref; + Context_Clause : out With_Id) + is + Current_With_Clause : With_Id := No_With; + Limited_With : Boolean := False; + Current_With : With_Record; + Current_With_Node : Project_Node_Id := Empty_Node; + + begin + -- Assume no context clause + + Context_Clause := No_With; + With_Loop : + + -- If Token is not WITH or LIMITED, there is no context clause, or we + -- have exhausted the with clauses. + + while Token = Tok_With or else Token = Tok_Limited loop + Current_With_Node := + Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); + Limited_With := Token = Tok_Limited; + + if In_Configuration then + Error_Msg + ("configuration project cannot import " & + "other configuration projects", + Token_Ptr); + end if; + + if Limited_With then + Scan (In_Tree); -- scan past LIMITED + Expect (Tok_With, "WITH"); + exit With_Loop when Token /= Tok_With; + end if; + + Comma_Loop : + loop + Scan (In_Tree); -- past WITH or "," + + Expect (Tok_String_Literal, "literal string"); + + if Token /= Tok_String_Literal then + return; + end if; + + -- Store path and location in table Withs + + Current_With := + (Path => Path_Name_Type (Token_Name), + Location => Token_Ptr, + Limited_With => Limited_With, + Node => Current_With_Node, + Next => No_With); + + Withs.Increment_Last; + Withs.Table (Withs.Last) := Current_With; + + if Current_With_Clause = No_With then + Context_Clause := Withs.Last; + + else + Withs.Table (Current_With_Clause).Next := Withs.Last; + end if; + + Current_With_Clause := Withs.Last; + + Scan (In_Tree); + + if Token = Tok_Semicolon then + Set_End_Of_Line (Current_With_Node); + Set_Previous_Line_Node (Current_With_Node); + + -- End of (possibly multiple) with clause; + + Scan (In_Tree); -- past the semicolon + exit Comma_Loop; + + elsif Token = Tok_Comma then + Set_Is_Not_Last_In_List (Current_With_Node, In_Tree); + + else + Error_Msg ("expected comma or semi colon", Token_Ptr); + exit Comma_Loop; + end if; + + Current_With_Node := + Default_Project_Node + (Of_Kind => N_With_Clause, In_Tree => In_Tree); + end loop Comma_Loop; + end loop With_Loop; + end Pre_Parse_Context_Clause; + + ------------------------------- + -- Post_Parse_Context_Clause -- + ------------------------------- + + procedure Post_Parse_Context_Clause + (Context_Clause : With_Id; + In_Tree : Project_Node_Tree_Ref; + Limited_Withs : Boolean; + Imported_Projects : in out Project_Node_Id; + Project_Directory : Path_Name_Type; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String) + is + Current_With_Clause : With_Id := Context_Clause; + + Current_Project : Project_Node_Id := Imported_Projects; + Previous_Project : Project_Node_Id := Empty_Node; + Next_Project : Project_Node_Id := Empty_Node; + + Project_Directory_Path : constant String := + Get_Name_String (Project_Directory); + + Current_With : With_Record; + Extends_All : Boolean := False; + + begin + -- Set Current_Project to the last project in the current list, if the + -- list is not empty. + + if Present (Current_Project) then + while + Present (Next_With_Clause_Of (Current_Project, In_Tree)) + loop + Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); + end loop; + end if; + + while Current_With_Clause /= No_With loop + Current_With := Withs.Table (Current_With_Clause); + Current_With_Clause := Current_With.Next; + + if Limited_Withs = Current_With.Limited_With then + declare + Original_Path : constant String := + Get_Name_String (Current_With.Path); + + Imported_Path_Name : constant String := + Project_Path_Name_Of + (Original_Path, + Project_Directory_Path); + + Resolved_Path : constant String := + Normalize_Pathname + (Imported_Path_Name, + Directory => Current_Dir, + Resolve_Links => + Opt.Follow_Links_For_Files, + Case_Sensitive => True); + + Withed_Project : Project_Node_Id := Empty_Node; + + begin + if Imported_Path_Name = "" then + + -- The project file cannot be found + + Error_Msg_File_1 := File_Name_Type (Current_With.Path); + Error_Msg + ("unknown project file: {", Current_With.Location); + + -- 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_File_1 := + File_Name_Type + (Project_Stack.Table (Index).Path_Name); + Error_Msg + ("\imported by {", Current_With.Location); + end loop; + end if; + + else + -- New with clause + + Previous_Project := Current_Project; + + if No (Current_Project) then + + -- First with clause of the context clause + + Current_Project := Current_With.Node; + Imported_Projects := Current_Project; + + else + Next_Project := Current_With.Node; + Set_Next_With_Clause_Of + (Current_Project, In_Tree, Next_Project); + Current_Project := Next_Project; + end if; + + Set_String_Value_Of + (Current_Project, + In_Tree, + Name_Id (Current_With.Path)); + Set_Location_Of + (Current_Project, In_Tree, Current_With.Location); + + -- If it is a limited with, check if we have a circularity. + -- If we have one, get the project id of the limited + -- imported project file, and do not parse it. + + if Limited_Withs and then Project_Stack.Last > 1 then + declare + Canonical_Path_Name : Path_Name_Type; + + begin + Name_Len := Resolved_Path'Length; + Name_Buffer (1 .. Name_Len) := Resolved_Path; + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + Canonical_Path_Name := Name_Find; + + for Index in 1 .. Project_Stack.Last loop + if Project_Stack.Table (Index).Canonical_Path_Name = + Canonical_Path_Name + then + -- We have found the limited imported project, + -- get its project id, and do not parse it. + + Withed_Project := Project_Stack.Table (Index).Id; + exit; + end if; + end loop; + end; + end if; + + -- Parse the imported project, if its project id is unknown + + if No (Withed_Project) then + Parse_Single_Project + (In_Tree => In_Tree, + Project => Withed_Project, + Extends_All => Extends_All, + Path_Name => Imported_Path_Name, + Extended => False, + From_Extended => From_Extended, + In_Limited => Limited_Withs, + Packages_To_Check => Packages_To_Check, + Depth => Depth, + Current_Dir => Current_Dir); + + else + Extends_All := Is_Extending_All (Withed_Project, In_Tree); + end if; + + if No (Withed_Project) then + + -- If parsing unsuccessful, remove the context clause + + Current_Project := Previous_Project; + + if No (Current_Project) then + Imported_Projects := Empty_Node; + + else + Set_Next_With_Clause_Of + (Current_Project, In_Tree, Empty_Node); + end if; + else + -- If parsing was successful, record project name and + -- path name in with clause + + Set_Project_Node_Of + (Node => Current_Project, + In_Tree => In_Tree, + To => Withed_Project, + Limited_With => Current_With.Limited_With); + Set_Name_Of + (Current_Project, + In_Tree, + Name_Of (Withed_Project, In_Tree)); + + Name_Len := Resolved_Path'Length; + Name_Buffer (1 .. Name_Len) := Resolved_Path; + Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); + + if Extends_All then + Set_Is_Extending_All (Current_Project, In_Tree); + end if; + end if; + end if; + end; + end if; + end loop; + end Post_Parse_Context_Clause; + + -------------------------- + -- Parse_Single_Project -- + -------------------------- + + procedure Parse_Single_Project + (In_Tree : Project_Node_Tree_Ref; + Project : out Project_Node_Id; + Extends_All : out Boolean; + Path_Name : String; + Extended : Boolean; + From_Extended : Extension_Origin; + In_Limited : Boolean; + Packages_To_Check : String_List_Access; + Depth : Natural; + Current_Dir : String) + is + Normed_Path_Name : Path_Name_Type; + Canonical_Path_Name : Path_Name_Type; + Project_Directory : Path_Name_Type; + Project_Scan_State : Saved_Project_Scan_State; + Source_Index : Source_File_Index; + + Extending : Boolean := False; + + Extended_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 + (In_Tree.Projects_HT); + + Name_From_Path : constant Name_Id := Project_Name_From (Path_Name); + Name_Of_Project : Name_Id := No_Name; + + Duplicated : Boolean := False; + + First_With : With_Id; + Imported_Projects : Project_Node_Id := Empty_Node; + + use Tree_Private_Part; + + Project_Comment_State : Tree.Comment_State; + + Proj_Qualifier : Project_Qualifier := Unspecified; + Qualifier_Location : Source_Ptr; + + begin + Extends_All := False; + + declare + Normed_Path : constant String := Normalize_Pathname + (Path_Name, + Directory => Current_Dir, + Resolve_Links => False, + Case_Sensitive => True); + Canonical_Path : constant String := Normalize_Pathname + (Normed_Path, + Directory => Current_Dir, + Resolve_Links => Opt.Follow_Links_For_Files, + Case_Sensitive => False); + begin + Name_Len := Normed_Path'Length; + Name_Buffer (1 .. Name_Len) := Normed_Path; + Normed_Path_Name := Name_Find; + Name_Len := Canonical_Path'Length; + Name_Buffer (1 .. Name_Len) := Canonical_Path; + Canonical_Path_Name := Name_Find; + end; + + -- Check for a circular dependency + + for Index in reverse 1 .. Project_Stack.Last loop + exit when Project_Stack.Table (Index).Limited_With; + + if Canonical_Path_Name = + Project_Stack.Table (Index).Canonical_Path_Name + then + Error_Msg ("circular dependency detected", Token_Ptr); + Error_Msg_Name_1 := Name_Id (Normed_Path_Name); + Error_Msg ("\ %% is imported by", Token_Ptr); + + for Current in reverse 1 .. Project_Stack.Last loop + Error_Msg_Name_1 := + Name_Id (Project_Stack.Table (Current).Path_Name); + + if Project_Stack.Table (Current).Canonical_Path_Name /= + 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; + + -- Put the new path name on the stack + + Project_Stack.Append + ((Path_Name => Normed_Path_Name, + Canonical_Path_Name => Canonical_Path_Name, + Id => Empty_Node, + Limited_With => In_Limited)); + + -- 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 A_Project_Name_And_Node.Canonical_Path = Canonical_Path_Name then + if Extended then + + if A_Project_Name_And_Node.Extended then + if A_Project_Name_And_Node.Proj_Qualifier /= Dry then + Error_Msg + ("cannot extend the same project file several times", + Token_Ptr); + end if; + else + Error_Msg + ("cannot extend an already imported project file", + Token_Ptr); + end if; + + elsif A_Project_Name_And_Node.Extended then + Extends_All := + Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); + + -- If the imported project is an extended project A, and we are + -- in an extended project, replace A with the ultimate project + -- extending A. + + if From_Extended /= None then + declare + Decl : Project_Node_Id := + Project_Declaration_Of + (A_Project_Name_And_Node.Node, In_Tree); + + Prj : Project_Node_Id := + Extending_Project_Of (Decl, In_Tree); + + begin + loop + Decl := Project_Declaration_Of (Prj, In_Tree); + exit when Extending_Project_Of (Decl, In_Tree) = + Empty_Node; + Prj := Extending_Project_Of (Decl, In_Tree); + end loop; + + A_Project_Name_And_Node.Node := Prj; + end; + else + Error_Msg + ("cannot import an already extended project file", + Token_Ptr); + end if; + 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 (In_Tree.Projects_HT); + 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); + Tree.Save (Project_Comment_State); + + -- If we cannot find it, we stop + + if Source_Index = No_Source_File then + Project := Empty_Node; + Project_Stack.Decrement_Last; + return; + end if; + + Prj.Err.Scanner.Initialize_Scanner (Source_Index); + Tree.Reset_State; + Scan (In_Tree); + + if not In_Configuration and then 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_File_1 := File_Name_Type (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 (Normed_Path_Name); + + -- Is there any imported project? + + Pre_Parse_Context_Clause + (In_Tree => In_Tree, + Context_Clause => First_With); + + Project := Default_Project_Node + (Of_Kind => N_Project, In_Tree => In_Tree); + Project_Stack.Table (Project_Stack.Last).Id := Project; + Set_Directory_Of (Project, In_Tree, Project_Directory); + Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); + + -- Check if there is a qualifier before the reserved word "project" + + Qualifier_Location := Token_Ptr; + + if Token = Tok_Abstract then + Proj_Qualifier := Dry; + Scan (In_Tree); + + elsif Token = Tok_Identifier then + case Token_Name is + when Snames.Name_Standard => + Proj_Qualifier := Standard; + Scan (In_Tree); + + when Snames.Name_Aggregate => + Proj_Qualifier := Aggregate; + Scan (In_Tree); + + if Token = Tok_Identifier and then + Token_Name = Snames.Name_Library + then + Proj_Qualifier := Aggregate_Library; + Scan (In_Tree); + end if; + + when Snames.Name_Library => + Proj_Qualifier := Library; + Scan (In_Tree); + + when Snames.Name_Configuration => + if not In_Configuration then + Error_Msg ("configuration projects cannot belong to a user" & + " project tree", + Token_Ptr); + end if; + + Scan (In_Tree); + + when others => + null; + end case; + end if; + + if Proj_Qualifier /= Unspecified then + if In_Configuration then + Error_Msg ("a configuration project cannot be qualified except " & + "as configuration project", + Qualifier_Location); + end if; + + Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); + end if; + + Set_Location_Of (Project, In_Tree, Token_Ptr); + + Expect (Tok_Project, "PROJECT"); + + -- Mark location of PROJECT token if present + + if Token = Tok_Project then + Scan (In_Tree); -- past PROJECT + Set_Location_Of (Project, In_Tree, Token_Ptr); + end if; + + -- Clear the Buffer + + Buffer_Last := 0; + loop + Expect (Tok_Identifier, "identifier"); + + -- If the token is not an identifier, clear the buffer before + -- exiting to indicate that the name of the project is ill-formed. + + if Token /= Tok_Identifier then + Buffer_Last := 0; + exit; + end if; + + -- Add the identifier name to the buffer + + Get_Name_String (Token_Name); + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + + -- Scan past the identifier + + Scan (In_Tree); + + -- If we have a dot, add a dot to the Buffer and look for the next + -- identifier. + + exit when Token /= Tok_Dot; + Add_To_Buffer (".", Buffer, Buffer_Last); + + -- Scan past the dot + + Scan (In_Tree); + end loop; + + -- See if this is an extending project + + if Token = Tok_Extends then + + if In_Configuration then + Error_Msg + ("extending configuration project not allowed", Token_Ptr); + end if; + + -- Make sure that gnatmake will use mapping files + + Create_Mapping_File := True; + + -- We are extending another project + + Extending := True; + + Scan (In_Tree); -- past EXTENDS + + if Token = Tok_All then + Extends_All := True; + Set_Is_Extending_All (Project, In_Tree); + Scan (In_Tree); -- scan past ALL + end if; + end if; + + -- If the name is well formed, Buffer_Last is > 0 + + if Buffer_Last > 0 then + + -- The Buffer contains the name of the project + + Name_Len := Buffer_Last; + Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); + Name_Of_Project := Name_Find; + Set_Name_Of (Project, In_Tree, Name_Of_Project); + + -- To get expected name of the project file, replace dots by dashes + + Name_Len := Buffer_Last; + Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); + + for Index in 1 .. Name_Len loop + if Name_Buffer (Index) = '.' then + Name_Buffer (Index) := '-'; + end if; + end loop; + + Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); + + declare + Expected_Name : constant Name_Id := Name_Find; + Extension : String_Access; + + begin + -- Output a warning if the actual name is not the expected name + + if not In_Configuration + and then (Name_From_Path /= No_Name) + and then Expected_Name /= Name_From_Path + then + Error_Msg_Name_1 := Expected_Name; + + if In_Configuration then + Extension := new String'(Config_Project_File_Extension); + + else + Extension := new String'(Project_File_Extension); + end if; + + Error_Msg ("?file name does not match project name, " & + "should be `%%" & Extension.all & "`", + Token_Ptr); + end if; + end; + + declare + From_Ext : Extension_Origin := None; + + begin + -- Extending_All is always propagated + + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + + -- Otherwise, From_Extended is set to Extending_Single if the + -- current project is an extending project. + + elsif Extended then + From_Ext := Extending_Simple; + end if; + + Post_Parse_Context_Clause + (In_Tree => In_Tree, + Context_Clause => First_With, + Limited_Withs => False, + Imported_Projects => Imported_Projects, + Project_Directory => Project_Directory, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir); + Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); + end; + + if not In_Configuration then + declare + Name_And_Node : Tree_Private_Part.Project_Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_First + (In_Tree.Projects_HT); + Project_Name : Name_Id := Name_And_Node.Name; + + begin + -- Check if we already have a project with this name + + while Project_Name /= No_Name + and then Project_Name /= Name_Of_Project + loop + Name_And_Node := + Tree_Private_Part.Projects_Htable.Get_Next + (In_Tree.Projects_HT); + Project_Name := Name_And_Node.Name; + end loop; + + -- Report an error if we already have a project with this name + + if Project_Name /= No_Name then + Duplicated := True; + Error_Msg_Name_1 := Project_Name; + Error_Msg + ("duplicate project name %%", + Location_Of (Project, In_Tree)); + Error_Msg_Name_1 := + Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); + Error_Msg + ("\already in %%", Location_Of (Project, In_Tree)); + end if; + end; + end if; + + end if; + + if Extending then + Expect (Tok_String_Literal, "literal string"); + + if Token = Tok_String_Literal then + Set_Extended_Project_Path_Of + (Project, + In_Tree, + Path_Name_Type (Token_Name)); + + declare + Original_Path_Name : constant String := + Get_Name_String (Token_Name); + + Extended_Project_Path_Name : constant String := + Project_Path_Name_Of + (Original_Path_Name, + Get_Name_String + (Project_Directory)); + + begin + if Extended_Project_Path_Name = "" then + + -- We could not find the project file to extend + + Error_Msg_Name_1 := Token_Name; + + 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 := + Name_Id + (Project_Stack.Table (Project_Stack.Last).Path_Name); + Error_Msg ("\extended by %%", Token_Ptr); + + for Index in reverse 1 .. Project_Stack.Last - 1 loop + Error_Msg_Name_1 := + Name_Id + (Project_Stack.Table (Index).Path_Name); + Error_Msg ("\imported by %%", Token_Ptr); + end loop; + end if; + + else + declare + From_Ext : Extension_Origin := None; + + begin + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + end if; + + Parse_Single_Project + (In_Tree => In_Tree, + Project => Extended_Project, + Extends_All => Extends_All, + Path_Name => Extended_Project_Path_Name, + Extended => True, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir); + end; + + if Present (Extended_Project) then + + -- A project that extends an extending-all project is + -- also an extending-all project. + + if Is_Extending_All (Extended_Project, In_Tree) then + Set_Is_Extending_All (Project, In_Tree); + end if; + + -- An abstract project can only extend an abstract + -- project, otherwise we may have an abstract project + -- with sources, if it inherits sources from the project + -- it extends. + + if Proj_Qualifier = Dry and then + Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + then + Error_Msg + ("an abstract project can only extend " & + "another abstract project", + Qualifier_Location); + end if; + end if; + end if; + end; + + Scan (In_Tree); -- past the extended project path + end if; + end if; + + -- Check that a non extending-all project does not import an + -- extending-all project. + + if not Is_Extending_All (Project, In_Tree) then + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project, In_Tree); + Imported : Project_Node_Id := Empty_Node; + + begin + With_Clause_Loop : + while Present (With_Clause) loop + Imported := Project_Node_Of (With_Clause, In_Tree); + + if Is_Extending_All (With_Clause, In_Tree) then + Error_Msg_Name_1 := Name_Of (Imported, In_Tree); + Error_Msg ("cannot import extending-all project %%", + Token_Ptr); + exit With_Clause_Loop; + end if; + + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop With_Clause_Loop; + end; + end if; + + -- Check that a project with a name including a dot either imports + -- or extends the project whose name precedes the last dot. + + if Name_Of_Project /= No_Name then + Get_Name_String (Name_Of_Project); + + else + Name_Len := 0; + end if; + + -- Look for the last dot + + while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop + Name_Len := Name_Len - 1; + end loop; + + -- If a dot was find, check if the parent project is imported + -- or extended. + + if Name_Len > 0 then + Name_Len := Name_Len - 1; + + declare + Parent_Name : constant Name_Id := Name_Find; + Parent_Found : Boolean := False; + Parent_Node : Project_Node_Id := Empty_Node; + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project, In_Tree); + + begin + -- If there is an extended project, check its name + + if Present (Extended_Project) then + Parent_Node := Extended_Project; + Parent_Found := + Name_Of (Extended_Project, In_Tree) = Parent_Name; + end if; + + -- If the parent project is not the extended project, + -- check each imported project until we find the parent project. + + while not Parent_Found and then Present (With_Clause) loop + Parent_Node := Project_Node_Of (With_Clause, In_Tree); + Parent_Found := Name_Of (Parent_Node, In_Tree) = Parent_Name; + With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); + end loop; + + if Parent_Found then + Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); + + else + -- If the parent project was not found, report an error + + Error_Msg_Name_1 := Name_Of_Project; + Error_Msg_Name_2 := Parent_Name; + Error_Msg ("project %% does not import or extend project %%", + Location_Of (Project, In_Tree)); + end if; + end; + end if; + + Expect (Tok_Is, "IS"); + Set_End_Of_Line (Project); + Set_Previous_Line_Node (Project); + Set_Next_End_Node (Project); + + declare + Project_Declaration : Project_Node_Id := Empty_Node; + + begin + -- No need to Scan past "is", Prj.Dect.Parse will do it + + Prj.Dect.Parse + (In_Tree => In_Tree, + Declarations => Project_Declaration, + Current_Project => Project, + Extends => Extended_Project, + Packages_To_Check => Packages_To_Check); + Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); + + if Present (Extended_Project) + and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + then + Set_Extending_Project_Of + (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, + To => Project); + end if; + end; + + Expect (Tok_End, "END"); + Remove_Next_End_Node; + + -- Skip "end" if present + + if Token = Tok_End then + Scan (In_Tree); + end if; + + -- Clear the Buffer + + Buffer_Last := 0; + + -- Store the name following "end" in the Buffer. The name may be made of + -- several simple names. + + loop + Expect (Tok_Identifier, "identifier"); + + -- If we don't have an identifier, clear the buffer before exiting to + -- avoid checking the name. + + if Token /= Tok_Identifier then + Buffer_Last := 0; + exit; + end if; + + -- Add the identifier to the Buffer + Get_Name_String (Token_Name); + Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); + + -- Scan past the identifier + + Scan (In_Tree); + exit when Token /= Tok_Dot; + Add_To_Buffer (".", Buffer, Buffer_Last); + Scan (In_Tree); + end loop; + + -- If we have a valid name, check if it is the name of the project + + if Name_Of_Project /= No_Name and then Buffer_Last > 0 then + if To_Lower (Buffer (1 .. Buffer_Last)) /= + Get_Name_String (Name_Of (Project, In_Tree)) + then + -- Invalid name: report an error + + Error_Msg ("expected """ & + Get_Name_String (Name_Of (Project, In_Tree)) & """", + Token_Ptr); + end if; + end if; + + Expect (Tok_Semicolon, "`;`"); + + -- Check that there is no more text following the end of the project + -- source. + + if Token = Tok_Semicolon then + Set_Previous_End_Node (Project); + Scan (In_Tree); + + if Token /= Tok_EOF then + Error_Msg + ("unexpected text following end of project", Token_Ptr); + end if; + end if; + + if not Duplicated and then Name_Of_Project /= No_Name then + + -- Add the name of the project to the hash table, so that we can + -- check that no other subsequent project will have the same name. + + Tree_Private_Part.Projects_Htable.Set + (T => In_Tree.Projects_HT, + K => Name_Of_Project, + E => (Name => Name_Of_Project, + Node => Project, + Canonical_Path => Canonical_Path_Name, + Extended => Extended, + Proj_Qualifier => Proj_Qualifier)); + end if; + + declare + From_Ext : Extension_Origin := None; + + begin + -- Extending_All is always propagated + + if From_Extended = Extending_All or else Extends_All then + From_Ext := Extending_All; + + -- Otherwise, From_Extended is set to Extending_Single if the + -- current project is an extending project. + + elsif Extended then + From_Ext := Extending_Simple; + end if; + + Post_Parse_Context_Clause + (In_Tree => In_Tree, + Context_Clause => First_With, + Limited_Withs => True, + Imported_Projects => Imported_Projects, + Project_Directory => Project_Directory, + From_Extended => From_Ext, + In_Limited => In_Limited, + Packages_To_Check => Packages_To_Check, + Depth => Depth + 1, + Current_Dir => Current_Dir); + Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); + end; + + -- Restore the scan state, in case we are not the main project + + Restore_Project_Scan_State (Project_Scan_State); + + -- And remove the project from the project stack + + Project_Stack.Decrement_Last; + + -- Indicate if there are unkept comments + + Tree.Set_Project_File_Includes_Unkept_Comments + (Node => Project, + In_Tree => In_Tree, + To => Tree.There_Are_Unkept_Comments); + + -- And restore the comment state that was saved + + Tree.Restore (Project_Comment_State); + 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 : Natural := First; + Index : Positive; + + begin + if Current_Verbosity = High then + Write_Str ("Project_Name_From ("""); + Write_Str (Canonical); + Write_Line (""")"); + end if; + + -- If the path name is empty, return No_Name to indicate failure + + if First = 0 then + return No_Name; + end if; + + Canonical_Case_File_Name (Canonical); + + -- Look for the last dot in the path name + + while First > 0 + and then + Canonical (First) /= '.' + loop + First := First - 1; + end loop; + + -- If we have a dot, check that it is followed by the correct extension + + if First > 0 and then Canonical (First) = '.' then + if (not In_Configuration + and then Canonical (First .. Last) = Project_File_Extension + and then First /= 1) + or else + (In_Configuration + and then + Canonical (First .. Last) = Config_Project_File_Extension + and then First /= 1) + then + -- Look for the last directory separator, if any + + 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 + -- Not the correct extension, return No_Name to indicate failure + + return No_Name; + end if; + + -- If no dot in the path name, return No_Name to indicate failure + + else + return No_Name; + end if; + + First := First + 1; + + -- If the extension is the file name, return No_Name to indicate failure + + if First > Last then + return No_Name; + end if; + + -- Put the name in lower case into Name_Buffer + + Name_Len := Last - First + 1; + Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last)); + + Index := 1; + + -- Check if it is a well formed project name. Return No_Name if it is + -- ill formed. + + loop + if not Is_Letter (Name_Buffer (Index)) then + return No_Name; + + else + loop + Index := Index + 1; + + exit when Index >= Name_Len; + + if Name_Buffer (Index) = '_' then + if Name_Buffer (Index + 1) = '_' then + return No_Name; + end if; + end if; + + exit when Name_Buffer (Index) = '-'; + + if Name_Buffer (Index) /= '_' + and then not Is_Alphanumeric (Name_Buffer (Index)) + then + return No_Name; + end if; + + end loop; + end if; + + if Index >= Name_Len then + if Is_Alphanumeric (Name_Buffer (Name_Len)) then + + -- All checks have succeeded. Return name in Name_Buffer + + return Name_Find; + + else + return No_Name; + end if; + + elsif Name_Buffer (Index) = '-' then + Index := Index + 1; + end if; + end loop; + end Project_Name_From; + + -------------------------- + -- Project_Path_Name_Of -- + -------------------------- + + function Project_Path_Name_Of + (Project_File_Name : String; + Directory : String) return String + is + + function Try_Path_Name (Path : String) return String_Access; + pragma Inline (Try_Path_Name); + -- Try the specified Path + + ------------------- + -- Try_Path_Name -- + ------------------- + + function Try_Path_Name (Path : String) return String_Access is + Prj_Path : constant String := Project_Path; + First : Natural; + Last : Natural; + Result : String_Access := null; + + begin + if Current_Verbosity = High then + Write_Str (" Trying "); + Write_Line (Path); + end if; + + if Is_Absolute_Path (Path) then + if Is_Regular_File (Path) then + Result := new String'(Path); + end if; + + else + -- Because we don't want to resolve symbolic links, we cannot use + -- Locate_Regular_File. So, we try each possible path + -- successively. + + First := Prj_Path'First; + while First <= Prj_Path'Last loop + while First <= Prj_Path'Last + and then Prj_Path (First) = Path_Separator + loop + First := First + 1; + end loop; + + exit when First > Prj_Path'Last; + + Last := First; + while Last < Prj_Path'Last + and then Prj_Path (Last + 1) /= Path_Separator + loop + Last := Last + 1; + end loop; + + Name_Len := 0; + + if not Is_Absolute_Path (Prj_Path (First .. Last)) then + Add_Str_To_Name_Buffer (Get_Current_Dir); + Add_Char_To_Name_Buffer (Directory_Separator); + end if; + + Add_Str_To_Name_Buffer (Prj_Path (First .. Last)); + Add_Char_To_Name_Buffer (Directory_Separator); + Add_Str_To_Name_Buffer (Path); + + if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then + Result := new String'(Name_Buffer (1 .. Name_Len)); + exit; + end if; + + First := Last + 1; + end loop; + end if; + + return Result; + end Try_Path_Name; + + -- Local Declarations + + Result : String_Access; + Result_Id : Path_Name_Type; + Has_Dot : Boolean := False; + Key : Name_Id; + + -- Start of processing for Project_Path_Name_Of + + begin + if Current_Verbosity = High then + Write_Str ("Project_Path_Name_Of ("""); + Write_Str (Project_File_Name); + Write_Str (""", """); + Write_Str (Directory); + Write_Line (""");"); + end if; + + -- Check the project cache + + Name_Len := Project_File_Name'Length; + Name_Buffer (1 .. Name_Len) := Project_File_Name; + Key := Name_Find; + Result_Id := Projects_Paths.Get (Key); + + if Result_Id /= No_Path then + return Get_Name_String (Result_Id); + end if; + + -- Check if Project_File_Name contains an extension (a dot before a + -- directory separator). If it is the case we do not try project file + -- with an added extension as it is not possible to have multiple dots + -- on a project file name. + + Check_Dot : for K in reverse Project_File_Name'Range loop + if Project_File_Name (K) = '.' then + Has_Dot := True; + exit Check_Dot; + end if; + + exit Check_Dot when Project_File_Name (K) = Directory_Separator + or else Project_File_Name (K) = '/'; + end loop Check_Dot; + + if not Is_Absolute_Path (Project_File_Name) then + + -- First we try <directory>/<file_name>.<extension> + + if not Has_Dot then + Result := Try_Path_Name + (Directory & Directory_Separator & + Project_File_Name & Project_File_Extension); + end if; + + -- Then we try <directory>/<file_name> + + if Result = null then + Result := Try_Path_Name + (Directory & Directory_Separator & Project_File_Name); + end if; + end if; + + -- Then we try <file_name>.<extension> + + if Result = null and then not Has_Dot then + Result := Try_Path_Name (Project_File_Name & Project_File_Extension); + end if; + + -- Then we try <file_name> + + if Result = null then + Result := Try_Path_Name (Project_File_Name); + end if; + + -- If we cannot find the project file, we return an empty string + + if Result = null then + return ""; + + else + declare + Final_Result : constant String := + GNAT.OS_Lib.Normalize_Pathname + (Result.all, + Directory => Directory, + Resolve_Links => False, + Case_Sensitive => True); + begin + Free (Result); + Name_Len := Final_Result'Length; + Name_Buffer (1 .. Name_Len) := Final_Result; + Result_Id := Name_Find; + + Projects_Paths.Set (Key, Result_Id); + return Final_Result; + end; + end if; + end Project_Path_Name_Of; + +end Prj.Part; |